revised back to 6/30/08 version
This commit is contained in:
george
parent
d7c01225d8
commit
c02138cd3d
|
|
@ -1,65 +1,60 @@
|
|||
PRCACM ;WASH-ISC@ALTOONA,PA/RGY-COMMENT ADJUSTMENT TRANSACTION ;6/2/95 2:41 PM
|
||||
;;4.5;Accounts Receivable;**8,67,125,169,254**;Mar 20, 1995;Build 2
|
||||
;;Per VHA Directive 2004-038, this routine should not be modified.
|
||||
; DBIA 3820-A used for direct global read into file 399.
|
||||
;
|
||||
;This is a routine for adjustment transaction.
|
||||
NEW PRCABN,PRCAEN,PRCAA1,DR,DIE,DA,D0,PRCAD,RCASK,PRCAA2,DIROUT,DIRUT,DIR,DUOUT,PRCA,PRCATY
|
||||
ADJUST D BEGIN G:('$D(PRCABN))!('$D(PRCAEN)) Q
|
||||
S PRCAA1=$S($D(^PRCA(433,PRCAEN,4,0)):+$P(^(0),U,4),1:0) G Q:PRCAA1'>0 S PRCAA2=$P(^(0),U,3) W !
|
||||
DIE S DR="[PRCA COMMENT]",DIE="^PRCA(433,",DA=PRCAEN D ^DIE K DIE,DR,DA
|
||||
I $P($G(^PRCA(433,PRCAEN,5)),"^",2)=""!'$P(^PRCA(433,PRCAEN,1),"^") S PRCACOMM="TRANSACTION INCOMPLETE" D DELETE^PRCAWO1 K PRCACOMM G:$D(DTOUT) Q G ADJUST
|
||||
W ! W:$D(IOF) @IOF S D0=PRCAEN K DXS D ^PRCATO4 K DXS
|
||||
I $P($G(^PRCA(433,PRCAEN,1)),"^")>$P($G(^(5)),"^",3),$P($G(^(5)),"^",3) W !!,*7,"You entered a date of follow-up before the date of contact!" S PRCACOMM="INVALID FOLLOW-UP DATE" D DELETE^PRCAWO1 K PRCACOMM G ADJUST
|
||||
ASK S %=2 W !!,"Is this correct" D YN^DICN I %=0 W !,"Answer 'Y' or 'YES' if this data is correct, answer 'N' or 'NO' if not",! G ASK
|
||||
I (%<0)!(%=2) S PRCACOMM="USER CANCELED" D DELETE^PRCAWO1 K PRCACOMM G ADJUST
|
||||
DONE I '$D(PRCAD("DELETE")) S RCASK=1 D TRANUP^PRCAUTL,UPPRIN^PRCADJ
|
||||
I $P($G(^RCD(340,+$P(^PRCA(430,PRCABN,0),"^",9),0)),"^")[";DPT(" D
|
||||
.S $P(^PRCA(433,PRCAEN,0),"^",10)=1
|
||||
.S DIR(0)="Y",DIR("A")="Should the BRIEF COMMENT print on the patient statement",DIR("B")="NO" D ^DIR K DIR
|
||||
.I Y=1 S DIR(0)="Y",DIR("A")="Are you SURE this BRIEF COMMENT should appear on the patient statement",DIR("B")="NO" D ^DIR K DIR I Y=1 D
|
||||
..W !!,*7,"*** OK, This comment will appear on the patient's statement! ***",!,"(If you change your mind, use the option Remove/Add Comment From Patient Statement)",!
|
||||
..S $P(^PRCA(433,PRCAEN,0),"^",10)=""
|
||||
..Q
|
||||
.Q
|
||||
G ADJUST
|
||||
Q Q
|
||||
EN1 Q:'$D(PRCABN)
|
||||
NEW X
|
||||
F X=0:0 S X=$O(^PRCA(433,"C",PRCABN,X)) Q:'X I $P($G(^PRCA(433,X,1)),"^",4) I $P(^(1),"^",2)=1!($P(^(1),"^",2)=35) S PRCAQNM=$P(^(1),"^",4)+1
|
||||
Q
|
||||
ASK1 ;ASK FOR STATUS
|
||||
NEW DTOUT,DUOUT,DIRUT,DIR,DIROUT
|
||||
S DIR("A")="Change 'BILL' status to?",DIR("B")="CANCELLED",DIR(0)="SB^1:CANCELLED;2:COLLECTED/CLOSED;" D ^DIR K DIR
|
||||
I Y=2 S PRCA("STATUS")=$O(^PRCA(430.3,"AC",108,0))
|
||||
Q
|
||||
RPT ;
|
||||
NEW %DT,BEG,END,DIC,L,FR,TO,FLDS,PRCACM,POP,PRCADEV
|
||||
ST W !! S %DT="AEX",%DT("A")="Follow-up Date(s) From: " D ^%DT G:Y<0 REPQ S BEG=Y
|
||||
S %DT="AEX",%DT("A")="Follow-up Date(s) To: " D ^%DT G:Y<0 REPQ S END=Y
|
||||
I BEG>END W !!,*7," (Ending date must be greater than Start date.)" G ST
|
||||
S %ZIS="MQ" D ^%ZIS G:POP REPQ S PRCADEV=ION_";"_IOST_";"_IOM_";"_IOSL_";"_$G(IO("DOC"))
|
||||
I $D(IO("Q")) S Y=$$TI() G:Y<0 REPQ F PRCACM=1,2 S ZTDTH=$H,ZTRTN="DQ"_PRCACM_"^PRCACM",ZTSAVE("BEG")="",ZTSAVE("PRCADEV")="",ZTSAVE("END")="",ZTDESC="Comment Follow-up List" D ^%ZTLOAD G REPQ:PRCACM=2
|
||||
D DQ1,DQ2:'$D(DTOUT)
|
||||
REPQ Q
|
||||
DQ1 ;
|
||||
S IOP=PRCADEV,DIC="^PRCA(433,",L=0,BY="[PRCA FOLLOW-UP]",FLDS="[PRCA FOLLOW-UP]",FR=BEG,TO=END D EN1^DIP
|
||||
D ^%ZISC K IOP
|
||||
I $E(IOST)="C" W !,*7,"OK, first part of report complete...",!,"press return to continue: " R X:DTIME W @IOF S:X["^"!'$T DTOUT=1
|
||||
Q
|
||||
DQ2 ;
|
||||
S IOP=PRCADEV D ^%ZIS
|
||||
I 'POP S IOP=PRCADEV,DIC="^RC(341,",L=0,BY="[RCAM COMMENT]",FLDS="[RCAM COMMENT]",FR=BEG,TO=END D EN1^DIP
|
||||
D ^%ZISC K IOP
|
||||
Q
|
||||
TI() ;
|
||||
N %DT D NOW^%DTC S %DT("A")="Request Time to Queue? ",%DT("B")="NOW"
|
||||
S %DT="AERX",%DT(0)=% D ^%DT
|
||||
Q Y
|
||||
BEGIN K PRCATERM,PRCABN,PRCAEN,PRCA("CKSITE"),PRCAIBS D BILL^PRCAUTL Q:('$D(PRCABN))
|
||||
S PRCAIBS=$P($G(^DGCR(399,PRCABN,0)),U,13) ; IB claim status - DBIA3820-A
|
||||
I PRCAIBS=1 W !!,"** You cannot add AR Comments to an Entered/Not Reviewed claim. **",!,*7 G BEGIN
|
||||
I PRCAIBS=2 W !!,"** You cannot add AR Comments to an MRA Request claim. **",!,*7 G BEGIN
|
||||
I '$D(^PRCA(430,PRCABN,2,0)),PRCAIBS=7 W !!,"** You cannot add AR Comments to a claim Cancelled/not passed to AR. **",!,*7 G BEGIN
|
||||
I $P($G(^PRCA(430,PRCABN,0)),"^",8)=49 W !!,"** Comments CANNOT be entered on an ARCHIVED bill. **",!,*7 G BEGIN
|
||||
D SETTR^PRCAUTL,PATTR^PRCAUTL S DIC="^PRCA(433," K PRCAMT,PRCAD("DELETE") Q
|
||||
PRCACM ;WASH-ISC@ALTOONA,PA/RGY-COMMENT ADJUSTMENT TRANSACTION ;6/2/95 2:41 PM
|
||||
V ;;4.5;Accounts Receivable;**8,67,125,169**;Mar 20, 1995
|
||||
;;Per VHA Directive 10-93-142, this routine should not be modified.
|
||||
;This is a routine for adjustment transaction.
|
||||
NEW PRCABN,PRCAEN,PRCAA1,DR,DIE,DA,D0,PRCAD,RCASK,PRCAA2,DIROUT,DIRUT,DIR,DUOUT,PRCA,PRCATY
|
||||
ADJUST D BEGIN G:('$D(PRCABN))!('$D(PRCAEN)) Q
|
||||
S PRCAA1=$S($D(^PRCA(433,PRCAEN,4,0)):+$P(^(0),U,4),1:0) G Q:PRCAA1'>0 S PRCAA2=$P(^(0),U,3) W !
|
||||
DIE S DR="[PRCA COMMENT]",DIE="^PRCA(433,",DA=PRCAEN D ^DIE K DIE,DR,DA
|
||||
I $P($G(^PRCA(433,PRCAEN,5)),"^",2)=""!'$P(^PRCA(433,PRCAEN,1),"^") S PRCACOMM="TRANSACTION INCOMPLETE" D DELETE^PRCAWO1 K PRCACOMM G:$D(DTOUT) Q G ADJUST
|
||||
W ! W:$D(IOF) @IOF S D0=PRCAEN K DXS D ^PRCATO4 K DXS
|
||||
I $P($G(^PRCA(433,PRCAEN,1)),"^")>$P($G(^(5)),"^",3),$P($G(^(5)),"^",3) W !!,*7,"You entered a date of follow-up before the date of contact!" S PRCACOMM="INVALID FOLLOW-UP DATE" D DELETE^PRCAWO1 K PRCACOMM G ADJUST
|
||||
ASK S %=2 W !!,"Is this correct" D YN^DICN I %=0 W !,"Answer 'Y' or 'YES' if this data is correct, answer 'N' or 'NO' if not",! G ASK
|
||||
I (%<0)!(%=2) S PRCACOMM="USER CANCELED" D DELETE^PRCAWO1 K PRCACOMM G ADJUST
|
||||
DONE I '$D(PRCAD("DELETE")) S RCASK=1 D TRANUP^PRCAUTL,UPPRIN^PRCADJ
|
||||
I $P($G(^RCD(340,+$P(^PRCA(430,PRCABN,0),"^",9),0)),"^")[";DPT(" D
|
||||
.S $P(^PRCA(433,PRCAEN,0),"^",10)=1
|
||||
.S DIR(0)="Y",DIR("A")="Should the BRIEF COMMENT print on the patient statement",DIR("B")="NO" D ^DIR K DIR
|
||||
.I Y=1 S DIR(0)="Y",DIR("A")="Are you SURE this BRIEF COMMENT should appear on the patient statement",DIR("B")="NO" D ^DIR K DIR I Y=1 D
|
||||
..W !!,*7,"*** OK, This comment will appear on the patient's statement! ***",!,"(If you change your mind, use the option Remove/Add Comment From Patient Statement)",!
|
||||
..S $P(^PRCA(433,PRCAEN,0),"^",10)=""
|
||||
..Q
|
||||
.Q
|
||||
G ADJUST
|
||||
Q Q
|
||||
EN1 Q:'$D(PRCABN)
|
||||
NEW X
|
||||
F X=0:0 S X=$O(^PRCA(433,"C",PRCABN,X)) Q:'X I $P($G(^PRCA(433,X,1)),"^",4) I $P(^(1),"^",2)=1!($P(^(1),"^",2)=35) S PRCAQNM=$P(^(1),"^",4)+1
|
||||
Q
|
||||
ASK1 ;ASK FOR STATUS
|
||||
NEW DTOUT,DUOUT,DIRUT,DIR,DIROUT
|
||||
S DIR("A")="Change 'BILL' status to?",DIR("B")="CANCELLED",DIR(0)="SB^1:CANCELLED;2:COLLECTED/CLOSED;" D ^DIR K DIR
|
||||
I Y=2 S PRCA("STATUS")=$O(^PRCA(430.3,"AC",108,0))
|
||||
Q
|
||||
RPT ;
|
||||
NEW %DT,BEG,END,DIC,L,FR,TO,FLDS,PRCACM,POP,PRCADEV
|
||||
ST W !! S %DT="AEX",%DT("A")="Follow-up Date(s) From: " D ^%DT G:Y<0 REPQ S BEG=Y
|
||||
S %DT="AEX",%DT("A")="Follow-up Date(s) To: " D ^%DT G:Y<0 REPQ S END=Y
|
||||
I BEG>END W !!,*7," (Ending date must be greater than Start date.)" G ST
|
||||
S %ZIS="MQ" D ^%ZIS G:POP REPQ S PRCADEV=ION_";"_IOST_";"_IOM_";"_IOSL_";"_$G(IO("DOC"))
|
||||
I $D(IO("Q")) S Y=$$TI() G:Y<0 REPQ F PRCACM=1,2 S ZTDTH=$H,ZTRTN="DQ"_PRCACM_"^PRCACM",ZTSAVE("BEG")="",ZTSAVE("PRCADEV")="",ZTSAVE("END")="",ZTDESC="Comment Follow-up List" D ^%ZTLOAD G REPQ:PRCACM=2
|
||||
D DQ1,DQ2:'$D(DTOUT)
|
||||
REPQ Q
|
||||
DQ1 ;
|
||||
S IOP=PRCADEV,DIC="^PRCA(433,",L=0,BY="[PRCA FOLLOW-UP]",FLDS="[PRCA FOLLOW-UP]",FR=BEG,TO=END D EN1^DIP
|
||||
D ^%ZISC K IOP
|
||||
I $E(IOST)="C" W !,*7,"OK, first part of report complete...",!,"press return to continue: " R X:DTIME W @IOF S:X["^"!'$T DTOUT=1
|
||||
Q
|
||||
DQ2 ;
|
||||
S IOP=PRCADEV D ^%ZIS
|
||||
I 'POP S IOP=PRCADEV,DIC="^RC(341,",L=0,BY="[RCAM COMMENT]",FLDS="[RCAM COMMENT]",FR=BEG,TO=END D EN1^DIP
|
||||
D ^%ZISC K IOP
|
||||
Q
|
||||
TI() ;
|
||||
N %DT D NOW^%DTC S %DT("A")="Request Time to Queue? ",%DT("B")="NOW"
|
||||
S %DT="AERX",%DT(0)=% D ^%DT
|
||||
Q Y
|
||||
BEGIN K PRCATERM,PRCABN,PRCAEN,PRCA("CKSITE") D BILL^PRCAUTL Q:('$D(PRCABN))
|
||||
I '$D(^PRCA(430,PRCABN,2,0)) W !!,"** This bill was cancelled in IB before it was passed to AR. **",!,*7 G BEGIN
|
||||
I $P($G(^PRCA(430,PRCABN,0)),"^",8)=49 W !!,"** Comments CANNOT be entered on an ARCHIVED bill. **",!,*7 G BEGIN
|
||||
D SETTR^PRCAUTL,PATTR^PRCAUTL S DIC="^PRCA(433," K PRCAMT,PRCAD("DELETE") Q
|
||||
|
|
|
|||
|
|
@ -1,54 +1,54 @@
|
|||
PRCAGST ;WASH-ISC@ALTOONA,PA/CMS-Print Patient Statement ;12/12/96 9:39 AM
|
||||
V ;;4.5;Accounts Receivable;**34,181,190,249**;Mar 20, 1995;Build 2
|
||||
;;Per VHA Directive 10-93-142, this routine should not be modified.
|
||||
;ENTRY WITH DEBTOR PRINT STATEMENT
|
||||
EN(DEB,TBAL,PDAT,PBAL,LDT) ;
|
||||
NEW ADD,DA,LN,NAM,PAGE,SSN,X,X1,X2,Y
|
||||
I '$D(SITE) D SITE^PRCAGU
|
||||
S SSN=$$SSN^RCFN01(DEB),SSN=$S(SSN=-1:"XXXXXXXXX",1:SSN)
|
||||
S ADD=$$SADD^RCFN01(8) I ADD="" S ADD=$$SADD^RCFN01(1)
|
||||
S X=0 F Y=1:1:3 I $P(ADD,U,Y)]"" S X=X+1 S ADD(X)=$P(ADD,U,Y)
|
||||
S X=X+1,ADD(X)=$P(ADD,U,4)_", "_$P(ADD,U,5)_" "_$P(ADD,U,6)
|
||||
S X=X+1,ADD(X)=$P(ADD,U,7)
|
||||
W @IOF
|
||||
W !!,"Department of Veterans Affairs",?50,"Acct No.: ",$P($$SITE^VASITE(),U,3)_"/"_$E(SSN,6,9)
|
||||
W !,$G(ADD(1))
|
||||
S Y=$$FPS^RCAMFN01($S($G(LDT)>0:$E(LDT,1,5),1:$E(DT,1,5))_$TR($J($$PST^RCAMFN01(DEB),2)," ",0),$S(+$E($G(LDT),6,7)>$$STD^RCCPCFN:2,1:1)) D DD^%DT
|
||||
W !,$G(ADD(2)),?50 I TBAL>0 W "Due: UPON RECEIPT"
|
||||
W !,$G(ADD(3)),?50,$S(TBAL>0:"Amount Due: $"_$J(TBAL,0,2),1:"NO AMOUNT DUE")
|
||||
W !,$G(ADD(4)),?50,$S(TBAL'>0:"*THIS IS NOT A BILL*",1:"Amount Paid: _____________")
|
||||
W !,$G(ADD(5)),?50,"Today's Date: " S Y=DT D DD^%DT W Y
|
||||
I TBAL'>0 D MES G LB
|
||||
W !!,?2,"Please Make your Check or Money Order payable to the ""Department of Veterans"
|
||||
W !,?2,"Affairs"" and send payment to the above address. If you have any questions"
|
||||
W !,?2,"regarding this statement, please call the number listed above.",!!!
|
||||
LB K ADD S NAM=$$NAM^RCFN01(DEB)
|
||||
W !,?7,NAM
|
||||
S ADD=$$DADD^RCAMADD(DEB,1) ; Get debtor address, confidential if applicable
|
||||
S X=0 F Y=1:1:3 I $P(ADD,U,Y)]"" S X=X+1 S ADD(X)=$P(ADD,U,Y)
|
||||
S X=X+1,ADD(X)=$P(ADD,U,4)_", "_$P(ADD,U,5)_" "_$P(ADD,U,6)
|
||||
F X=0:0 S X=$O(ADD(X)) Q:'X W !,?7,$E(ADD(X),1,40) I X=1 W ?50 X $G(SITE("SCAN"))
|
||||
W !
|
||||
I $G(SITE("COM1"))'="" W !,?2,SITE("COM1")
|
||||
I $$GMT(DEB) W !,?2,"REDUCTION OF INPATIENT COPAYMENT DUE TO GEOGRAPHIC MEANS TEST STATUS"
|
||||
W !! I TBAL>0 W !,?10,"Please Detach and Return Top Portion with Payment"
|
||||
S Y="",$P(Y,"=",80)="" W !,Y
|
||||
W !,"IMPORTANT: Please read the Notice of Rights accompanying this statement!",!
|
||||
D ^PRCAGST1
|
||||
Q
|
||||
MES ;text for no amount due
|
||||
W !!,?2,"This statement is being sent to you to provide you with information"
|
||||
W !,?2,"concerning transactions affecting your account. If a prepayment offset"
|
||||
W !,?2,"a bill or you have made one or more payments or charges were removed,"
|
||||
W !,?2,"from your account, you are being sent this statement to confirm these actions.",!!
|
||||
Q
|
||||
;
|
||||
; Detect GMT-related status for the statement (fetch all patient's bills)
|
||||
; Input: Temporary global ^TMP("PRCAGT",$J,PRDEB)
|
||||
; Output: 1 - 'Yes', 0 - 'No'
|
||||
GMT(PRDEB) N PRDAT,PRBN,PRGMT
|
||||
S PRGMT=0 ; Default
|
||||
I $G(PRDEB)'="" S PRDAT=0 F S PRDAT=$O(^TMP("PRCAGT",$J,PRDEB,PRDAT)) Q:'PRDAT D Q:PRGMT
|
||||
. S PRBN=0 F S PRBN=$O(^TMP("PRCAGT",$J,PRDEB,PRDAT,PRBN)) Q:'PRBN D Q:PRGMT
|
||||
.. I $$ISGMTBIL^IBAGMT($P($G(^PRCA(430,PRBN,0)),U,1)) S PRGMT=1
|
||||
Q PRGMT
|
||||
PRCAGST ;WASH-ISC@ALTOONA,PA/CMS-Print Patient Statement ;12/12/96 9:39 AM
|
||||
V ;;4.5;Accounts Receivable;**34,181,190**;Mar 20, 1995
|
||||
;;Per VHA Directive 10-93-142, this routine should not be modified.
|
||||
;ENTRY WITH DEBTOR PRINT STATEMENT
|
||||
EN(DEB,TBAL,PDAT,PBAL,LDT) ;
|
||||
NEW ADD,DA,LN,NAM,PAGE,SSN,X,X1,X2,Y
|
||||
I '$D(SITE) D SITE^PRCAGU
|
||||
S SSN=$$SSN^RCFN01(DEB),SSN=$S(SSN=-1:"XXXXXXXXX",1:SSN)
|
||||
S ADD=$$SADD^RCFN01(8) I ADD="" S ADD=$$SADD^RCFN01(1)
|
||||
S X=0 F Y=1:1:3 I $P(ADD,U,Y)]"" S X=X+1 S ADD(X)=$P(ADD,U,Y)
|
||||
S X=X+1,ADD(X)=$P(ADD,U,4)_", "_$P(ADD,U,5)_" "_$P(ADD,U,6)
|
||||
S X=X+1,ADD(X)=$P(ADD,U,7)
|
||||
W @IOF
|
||||
W !!,"Department of Veterans Affairs",?50,"Acct No.: ",SSN
|
||||
W !,$G(ADD(1))
|
||||
S Y=$$FPS^RCAMFN01($S($G(LDT)>0:$E(LDT,1,5),1:$E(DT,1,5))_$TR($J($$PST^RCAMFN01(DEB),2)," ",0),$S(+$E($G(LDT),6,7)>$$STD^RCCPCFN:2,1:1)) D DD^%DT
|
||||
W !,$G(ADD(2)),?50 I TBAL>0 W "Due: UPON RECEIPT"
|
||||
W !,$G(ADD(3)),?50,$S(TBAL>0:"Amount Due: $"_$J(TBAL,0,2),1:"NO AMOUNT DUE")
|
||||
W !,$G(ADD(4)),?50,$S(TBAL'>0:"*THIS IS NOT A BILL*",1:"Amount Paid: _____________")
|
||||
W !,$G(ADD(5)),?50,"Today's Date: " S Y=DT D DD^%DT W Y
|
||||
I TBAL'>0 D MES G LB
|
||||
W !!,?2,"Please Make your Check or Money Order payable to the ""Department of Veterans"
|
||||
W !,?2,"Affairs"" and send payment to the above address. If you have any questions"
|
||||
W !,?2,"regarding this statement, please call the number listed above.",!!!
|
||||
LB K ADD S NAM=$$NAM^RCFN01(DEB)
|
||||
W !,?7,NAM
|
||||
S ADD=$$DADD^RCAMADD(DEB,1) ; Get debtor address, confidential if applicable
|
||||
S X=0 F Y=1:1:3 I $P(ADD,U,Y)]"" S X=X+1 S ADD(X)=$P(ADD,U,Y)
|
||||
S X=X+1,ADD(X)=$P(ADD,U,4)_", "_$P(ADD,U,5)_" "_$P(ADD,U,6)
|
||||
F X=0:0 S X=$O(ADD(X)) Q:'X W !,?7,$E(ADD(X),1,40) I X=1 W ?50 X $G(SITE("SCAN"))
|
||||
W !
|
||||
I $G(SITE("COM1"))'="" W !,?2,SITE("COM1")
|
||||
I $$GMT(DEB) W !,?2,"REDUCTION OF INPATIENT COPAYMENT DUE TO GEOGRAPHIC MEANS TEST STATUS"
|
||||
W !! I TBAL>0 W !,?10,"Please Detach and Return Top Portion with Payment"
|
||||
S Y="",$P(Y,"=",80)="" W !,Y
|
||||
W !,"IMPORTANT: Please read the Notice of Rights accompanying this statement!",!
|
||||
D ^PRCAGST1
|
||||
Q
|
||||
MES ;text for no amount due
|
||||
W !!,?2,"This statement is being sent to you to provide you with information"
|
||||
W !,?2,"concerning transactions affecting your account. If a prepayment offset"
|
||||
W !,?2,"a bill or you have made one or more payments or charges were removed,"
|
||||
W !,?2,"from your account, you are being sent this statement to confirm these actions.",!!
|
||||
Q
|
||||
;
|
||||
; Detect GMT-related status for the statement (fetch all patient's bills)
|
||||
; Input: Temporary global ^TMP("PRCAGT",$J,PRDEB)
|
||||
; Output: 1 - 'Yes', 0 - 'No'
|
||||
GMT(PRDEB) N PRDAT,PRBN,PRGMT
|
||||
S PRGMT=0 ; Default
|
||||
I $G(PRDEB)'="" S PRDAT=0 F S PRDAT=$O(^TMP("PRCAGT",$J,PRDEB,PRDAT)) Q:'PRDAT D Q:PRGMT
|
||||
. S PRBN=0 F S PRBN=$O(^TMP("PRCAGT",$J,PRDEB,PRDAT,PRBN)) Q:'PRBN D Q:PRGMT
|
||||
.. I $$ISGMTBIL^IBAGMT($P($G(^PRCA(430,PRBN,0)),U,1)) S PRGMT=1
|
||||
Q PRGMT
|
||||
|
|
|
|||
|
|
@ -1,66 +1,66 @@
|
|||
PRCAGST1 ;WASH-ISC@ALTOONA,PA/CMS-Print Patient Statement Bottom ;10/16/96 11:13 AM
|
||||
V ;;4.5;Accounts Receivable;**2,48,104,176,249**;Mar 20, 1995;Build 2
|
||||
;;Per VHA Directive 10-93-142, this routine should not be modified.
|
||||
;ENTRY FROM PRCAGST PAGE 1
|
||||
NEW AMT,BN,DAT,DESC,I,REF,THNK,TN,TTY,X,Y,RCTOTAL
|
||||
D HDR
|
||||
S DESC(1)="Previous Balance",REF="" D WRL(PDAT,.DESC,PBAL,REF)
|
||||
S DAT=0
|
||||
F S DAT=$O(^TMP("PRCAGT",$J,DEB,DAT)) Q:'DAT S BN=0 F S BN=$O(^TMP("PRCAGT",$J,DEB,DAT,BN)) Q:'BN D
|
||||
. S REF=$P($G(^PRCA(430,BN,0)),"^") ; Get Bill Name
|
||||
. I $D(^TMP("PRCAGT",$J,DEB,DAT,BN,0)) S AMT=+^(0) I AMT D Q
|
||||
.. D BILLDESC(BN,.DESC) ; Compile bill description
|
||||
.. D WRL(DAT,.DESC,AMT,REF) ; Print the item
|
||||
. S TN=0 F S TN=$O(^TMP("PRCAGT",$J,DEB,DAT,BN,TN)) Q:'TN S AMT=^(TN) D
|
||||
.. S TTY=$P(AMT,U,2) S AMT=+AMT
|
||||
.. D AMOUNT(TN,TTY,.AMT,.THNK) ; Adjust Amount sign (+/-) and "Thank You" flag
|
||||
.. D TRANDESC(TN,.DESC) ; Compile description
|
||||
.. D WRL(DAT,.DESC,AMT,REF) ; Print the item
|
||||
I ($Y+9)>(IOSL-2) D D HDR
|
||||
. W !,"|" F I=12,46,9,12 S Y="",$P(Y,"_",I)="" W Y,"|"
|
||||
D SUM^PRCAGST2
|
||||
Q
|
||||
WRL(DAT,DESC,AMT,REF) ;Write transaction
|
||||
NEW LN,I,X,Y
|
||||
S LN=1,X=0 F S X=$O(DESC(X)) Q:'X S LN=$G(LN)+1
|
||||
I ($Y+LN)>(IOSL-2) D D HDR
|
||||
. W !,"|" F I=12,46,9,12 S Y="",$P(Y,"_",I)="" W Y,"|"
|
||||
W !,"|",$S($G(DAT):$$DAT(DAT),1:""),?12,"|",DESC(1),?58,"|",$J(AMT,8,2),?67,"|",?68,$G(REF),?79,"|"
|
||||
F X=1:0 S X=$O(DESC(X)) Q:'X W !,"|",?12,"|",DESC(X),?58,"|",?67,"|",?79,"|"
|
||||
Q
|
||||
;
|
||||
; Get transaction description array
|
||||
TRANDESC(PRTRAN,RCDESC) N RCTOTAL
|
||||
; RCTOTAL not used in reprinted statements.
|
||||
K RCDESC
|
||||
D TRANDESC^RCCPCPS1(PRTRAN,45) ; returns RCDESC() array (max. length 45 characters)
|
||||
Q
|
||||
;
|
||||
AMOUNT(BN,TTY,AMT,THNK) ;Adjust (+/-) amount depending on Transaction Type
|
||||
N BN0,CAT,TS
|
||||
S BN0=$G(^PRCA(430,BN,0)),CAT=$$CATN^PRCAFN(+$P(BN0,U,2))
|
||||
I ",2,8,9,10,11,14,19,47,34,35,29,"[(","_TTY_",") I AMT'<0 S AMT=-AMT
|
||||
I ",2,8,9,10,11,12,14,19,47,34,35,29,"'[(","_TTY_",") I AMT<0 S AMT=-AMT
|
||||
I +CAT=33,TTY=1 I AMT<0 S AMT=-AMT
|
||||
I +CAT=33,TTY=35 I AMT>0 S AMT=-AMT
|
||||
S TS=$P($G(^PRCA(430.3,TTY,0)),U,3) I '$D(THNK),(TS=2!(TS=20)) S THNK=1
|
||||
Q
|
||||
; Description for bills
|
||||
; Input: PRBILL - Bill IEN
|
||||
; Output: RCDESC(1..n) - Description Array
|
||||
BILLDESC(PRBILL,RCDESC) K RCDESC
|
||||
D BILLDESC^RCCPCPS1(PRBILL,45) ; returns RCDESC() array (max. length 45 characters)
|
||||
Q
|
||||
DAT(DAT) ;slash date
|
||||
I 'DAT Q ""
|
||||
Q $$SLH^RCFN01(DAT,"/")
|
||||
HDR ;statement transaction header
|
||||
NEW I,Y
|
||||
S PAGE=$G(PAGE)+1
|
||||
I PAGE>1 W @IOF I $G(^RC(342,1,5))]"" F I=1:1:18 W !
|
||||
W !,"Department of Veterans Affairs",?50,"Acct No.:",$P($$SITE^VASITE(),U,3)_"/"_$E(SSN,6,9)
|
||||
W !,NAM,?50,"Page ",PAGE
|
||||
S Y="",$P(Y,"_",80)="" W !,Y
|
||||
W !,"|Date Posted|",?13," Description",?58,"| Amount ",?67,"| Reference |"
|
||||
W !,"|" F I=12,46,9,12 S Y="",$P(Y,"_",I)="" W Y,"|"
|
||||
Q
|
||||
PRCAGST1 ;WASH-ISC@ALTOONA,PA/CMS-Print Patient Statement Bottom ;10/16/96 11:13 AM
|
||||
V ;;4.5;Accounts Receivable;**2,48,104,176**;Mar 20, 1995
|
||||
;;Per VHA Directive 10-93-142, this routine should not be modified.
|
||||
;ENTRY FROM PRCAGST PAGE 1
|
||||
NEW AMT,BN,DAT,DESC,I,REF,THNK,TN,TTY,X,Y,RCTOTAL
|
||||
D HDR
|
||||
S DESC(1)="Previous Balance",REF="" D WRL(PDAT,.DESC,PBAL,REF)
|
||||
S DAT=0
|
||||
F S DAT=$O(^TMP("PRCAGT",$J,DEB,DAT)) Q:'DAT S BN=0 F S BN=$O(^TMP("PRCAGT",$J,DEB,DAT,BN)) Q:'BN D
|
||||
. S REF=$P($G(^PRCA(430,BN,0)),"^") ; Get Bill Name
|
||||
. I $D(^TMP("PRCAGT",$J,DEB,DAT,BN,0)) S AMT=+^(0) I AMT D Q
|
||||
.. D BILLDESC(BN,.DESC) ; Compile bill description
|
||||
.. D WRL(DAT,.DESC,AMT,REF) ; Print the item
|
||||
. S TN=0 F S TN=$O(^TMP("PRCAGT",$J,DEB,DAT,BN,TN)) Q:'TN S AMT=^(TN) D
|
||||
.. S TTY=$P(AMT,U,2) S AMT=+AMT
|
||||
.. D AMOUNT(TN,TTY,.AMT,.THNK) ; Adjust Amount sign (+/-) and "Thank You" flag
|
||||
.. D TRANDESC(TN,.DESC) ; Compile description
|
||||
.. D WRL(DAT,.DESC,AMT,REF) ; Print the item
|
||||
I ($Y+9)>(IOSL-2) D D HDR
|
||||
. W !,"|" F I=12,46,9,12 S Y="",$P(Y,"_",I)="" W Y,"|"
|
||||
D SUM^PRCAGST2
|
||||
Q
|
||||
WRL(DAT,DESC,AMT,REF) ;Write transaction
|
||||
NEW LN,I,X,Y
|
||||
S LN=1,X=0 F S X=$O(DESC(X)) Q:'X S LN=$G(LN)+1
|
||||
I ($Y+LN)>(IOSL-2) D D HDR
|
||||
. W !,"|" F I=12,46,9,12 S Y="",$P(Y,"_",I)="" W Y,"|"
|
||||
W !,"|",$S($G(DAT):$$DAT(DAT),1:""),?12,"|",DESC(1),?58,"|",$J(AMT,8,2),?67,"|",?68,$G(REF),?79,"|"
|
||||
F X=1:0 S X=$O(DESC(X)) Q:'X W !,"|",?12,"|",DESC(X),?58,"|",?67,"|",?79,"|"
|
||||
Q
|
||||
;
|
||||
; Get transaction description array
|
||||
TRANDESC(PRTRAN,RCDESC) N RCTOTAL
|
||||
; RCTOTAL not used in reprinted statements.
|
||||
K RCDESC
|
||||
D TRANDESC^RCCPCPS1(PRTRAN,45) ; returns RCDESC() array (max. length 45 characters)
|
||||
Q
|
||||
;
|
||||
AMOUNT(BN,TTY,AMT,THNK) ;Adjust (+/-) amount depending on Transaction Type
|
||||
N BN0,CAT,TS
|
||||
S BN0=$G(^PRCA(430,BN,0)),CAT=$$CATN^PRCAFN(+$P(BN0,U,2))
|
||||
I ",2,8,9,10,11,14,19,47,34,35,29,"[(","_TTY_",") I AMT'<0 S AMT=-AMT
|
||||
I ",2,8,9,10,11,12,14,19,47,34,35,29,"'[(","_TTY_",") I AMT<0 S AMT=-AMT
|
||||
I +CAT=33,TTY=1 I AMT<0 S AMT=-AMT
|
||||
I +CAT=33,TTY=35 I AMT>0 S AMT=-AMT
|
||||
S TS=$P($G(^PRCA(430.3,TTY,0)),U,3) I '$D(THNK),(TS=2!(TS=20)) S THNK=1
|
||||
Q
|
||||
; Description for bills
|
||||
; Input: PRBILL - Bill IEN
|
||||
; Output: RCDESC(1..n) - Description Array
|
||||
BILLDESC(PRBILL,RCDESC) K RCDESC
|
||||
D BILLDESC^RCCPCPS1(PRBILL,45) ; returns RCDESC() array (max. length 45 characters)
|
||||
Q
|
||||
DAT(DAT) ;slash date
|
||||
I 'DAT Q ""
|
||||
Q $$SLH^RCFN01(DAT,"/")
|
||||
HDR ;statement transaction header
|
||||
NEW I,Y
|
||||
S PAGE=$G(PAGE)+1
|
||||
I PAGE>1 W @IOF I $G(^RC(342,1,5))]"" F I=1:1:18 W !
|
||||
W !,"Department of Veterans Affairs",?50,"Acct No.: ",SSN
|
||||
W !,NAM,?50,"Page ",PAGE
|
||||
S Y="",$P(Y,"_",80)="" W !,Y
|
||||
W !,"|Date Posted|",?13," Description",?58,"| Amount ",?67,"| Reference |"
|
||||
W !,"|" F I=12,46,9,12 S Y="",$P(Y,"_",I)="" W Y,"|"
|
||||
Q
|
||||
|
|
|
|||
|
|
@ -1,41 +1,41 @@
|
|||
PRCASVC ;SF-ISC/YJK-ACCEPT, AMMEND AND CANCEL AR BILL ;9/6/95 2:09 PM
|
||||
V ;;4.5;Accounts Receivable;**1,21,48,90,136,138,249**;Mar 20, 1995;Build 2
|
||||
;;Per VHA Directive 10-93-142, this routine should not be modified.
|
||||
REL ;Accept bill into AR
|
||||
N X,Y
|
||||
D ^PRCASVC6 G:$D(PRCAERR) Q3 S PRCADEBT=$O(^RCD(340,"B",PRCASV("DEBTOR"),0)) I 'PRCADEBT K DD,DO S DIC="^RCD(340,",DIC(0)="QL",X=PRCASV("DEBTOR"),DLAYGO=340 D FILE^DICN K DIC,DLAYGO,DO Q:Y<0 S PRCADEBT=+Y
|
||||
D FY S PRCAT=$P(^PRCA(430.2,PRCASV("CAT"),0),"^",6) F Y="IDNO^4","GPNO^6","GPNM^5","INPA^1" S:$D(PRCASV($P(Y,"^"))) $P(^PRCA(430,PRCASV("ARREC"),202),"^",$P(Y,"^",2))=PRCASV($P(Y,"^"))
|
||||
S DIE="^PRCA(430,",DR="[PRCASV REL]",DA=PRCASV("ARREC") D ^DIE
|
||||
Q3 K PRCAT,PRCAORA,PRCADEBT,DIE,DR,%
|
||||
; set the fund for the bill (set in routine rcxfmsuf)
|
||||
S:'$G(DA) DA=PRCASV("ARREC") S %=$$GETFUNDB^RCXFMSUF(DA)
|
||||
I "^27^28^"[("^"_PRCASV("CAT")_"^") D
|
||||
.N P
|
||||
.F P=6,8,10,15 S $P(^PRCA(430,DA,11),"^",P)=$S(P=6:1000,P=8:$G(PRCASV("SITE")),P=10:9,1:$P($G(PRCASV("FY")),"^"))
|
||||
.S $P(^PRCA(430,DA,11),"^",18,999)=""
|
||||
I PRCASV("CAT")=27 S $P(^PRCA(430,+PRCASV("ARREC"),0),"^",5)=$O(^PRCA(430.6,"B","CHMPV",0))
|
||||
I PRCASV("CAT")=29 S $P(^PRCA(430,DA,11),"^",18,999)=""
|
||||
I "^30^31^32^"[("^"_PRCASV("CAT")_"^") D
|
||||
.N RCCARE,P
|
||||
.F P=8,9,10,15 S $P(^PRCA(430,DA,11),"^",P)=$S(P=8:$P(^PRCA(430,DA,0),"^",12),P=9:1,P=10:"02",1:$P($G(PRCASV("FY")),"^"))
|
||||
.S $P(^PRCA(430,DA,11),"^",18)=""
|
||||
.S RCCARE=$$TYP^IBRFN(DA),RCCARE(1)=$S(RCCARE="I":8028,RCCARE="O":8029,1:8030),$P(^PRCA(430,DA,11),"^",6)=RCCARE(1)
|
||||
I $G(PRCASV("MEDCA"))!$G(PRCASV("MEDURE")) D MEDICARE
|
||||
K DA
|
||||
Q
|
||||
;
|
||||
;
|
||||
FY K:$D(^PRCA(430,PRCASV("ARREC"),2)) ^(2) S PRCAK1=1,PRCAORA=0,^PRCA(430,PRCASV("ARREC"),2,0)="^430.01IA^^"
|
||||
F J=1:1 S X=$P(PRCASV("FY"),U,PRCAK1),PRCAMT=+$P(PRCASV("FY"),U,PRCAK1+1) D FY1 S PRCAK1=PRCAK1+2 Q:$P(PRCASV("FY"),U,PRCAK1)=""
|
||||
EXITFY K PRCAK1,J,PRCAMT Q
|
||||
FY1 S DA(1)=PRCASV("ARREC"),DIC="^PRCA(430,"_DA(1)_",2,",DIC(0)="QL",DLAYGO=430 D ^DIC K DIC,DLAYGO Q:Y<0 S DA=+Y
|
||||
S PRCAORA=PRCAORA+PRCAMT,$P(^PRCA(430,PRCASV("ARREC"),0),"^",3)=PRCAORA,$P(^(7),"^")=PRCAORA,$P(^(2,DA,0),U,2)=PRCAMT,$P(^(0),"^",8)=PRCAMT
|
||||
K DA Q
|
||||
;
|
||||
MEDICARE ;Setup Medicare Supplemental amounts
|
||||
N DR,DIE
|
||||
I $G(PRCASV("MEDCA")) S DIE="^PRCA(430,",DR="131////"_PRCASV("MEDCA") D ^DIE
|
||||
I $G(PRCASV("MEDURE")) S DIE="^PRCA(430,",DR="132////"_PRCASV("MEDURE") D ^DIE
|
||||
K PRCASV("MEDCA"),PRCASV("MEDURE")
|
||||
Q ;MEDICARE
|
||||
;
|
||||
PRCASVC ;SF-ISC/YJK-ACCEPT, AMMEND AND CANCEL AR BILL ;9/6/95 2:09 PM
|
||||
V ;;4.5;Accounts Receivable;**1,21,48,90,136,138**;Mar 20, 1995
|
||||
;;Per VHA Directive 10-93-142, this routine should not be modified.
|
||||
REL ;Accept bill into AR
|
||||
N X,Y
|
||||
D ^PRCASVC6 G:$D(PRCAERR) Q3 S PRCADEBT=$O(^RCD(340,"B",PRCASV("DEBTOR"),0)) I 'PRCADEBT K DD,DO S DIC="^RCD(340,",DIC(0)="QL",X=PRCASV("DEBTOR"),DLAYGO=340 D FILE^DICN K DIC,DLAYGO,DO Q:Y<0 S PRCADEBT=+Y
|
||||
D FY S PRCAT=$P(^PRCA(430.2,PRCASV("CAT"),0),"^",6) F Y="IDNO^4","GPNO^6","GPNM^5","INPA^1" S:$D(PRCASV($P(Y,"^"))) $P(^PRCA(430,PRCASV("ARREC"),202),"^",$P(Y,"^",2))=PRCASV($P(Y,"^"))
|
||||
S DIE="^PRCA(430,",DR="[PRCASV REL]",DA=PRCASV("ARREC") D ^DIE
|
||||
Q3 K PRCAT,PRCAORA,PRCADEBT,DIE,DR,%
|
||||
; set the fund for the bill (set in routine rcxfmsuf)
|
||||
S %=$$GETFUNDB^RCXFMSUF(DA)
|
||||
I "^27^28^"[("^"_PRCASV("CAT")_"^") D
|
||||
.N P
|
||||
.F P=6,8,10,15 S $P(^PRCA(430,DA,11),"^",P)=$S(P=6:1000,P=8:$G(PRCASV("SITE")),P=10:9,1:$P($G(PRCASV("FY")),"^"))
|
||||
.S $P(^PRCA(430,DA,11),"^",18,999)=""
|
||||
I PRCASV("CAT")=27 S $P(^PRCA(430,+PRCASV("ARREC"),0),"^",5)=$O(^PRCA(430.6,"B","CHMPV",0))
|
||||
I PRCASV("CAT")=29 S $P(^PRCA(430,DA,11),"^",18,999)=""
|
||||
I "^30^31^32^"[("^"_PRCASV("CAT")_"^") D
|
||||
.N RCCARE,P
|
||||
.F P=8,9,10,15 S $P(^PRCA(430,DA,11),"^",P)=$S(P=8:$P(^PRCA(430,DA,0),"^",12),P=9:1,P=10:"02",1:$P($G(PRCASV("FY")),"^"))
|
||||
.S $P(^PRCA(430,DA,11),"^",18)=""
|
||||
.S RCCARE=$$TYP^IBRFN(DA),RCCARE(1)=$S(RCCARE="I":8028,RCCARE="O":8029,1:8030),$P(^PRCA(430,DA,11),"^",6)=RCCARE(1)
|
||||
I $G(PRCASV("MEDCA"))!$G(PRCASV("MEDURE")) D MEDICARE
|
||||
K DA
|
||||
Q
|
||||
;
|
||||
;
|
||||
FY K:$D(^PRCA(430,PRCASV("ARREC"),2)) ^(2) S PRCAK1=1,PRCAORA=0,^PRCA(430,PRCASV("ARREC"),2,0)="^430.01IA^^"
|
||||
F J=1:1 S X=$P(PRCASV("FY"),U,PRCAK1),PRCAMT=+$P(PRCASV("FY"),U,PRCAK1+1) D FY1 S PRCAK1=PRCAK1+2 Q:$P(PRCASV("FY"),U,PRCAK1)=""
|
||||
EXITFY K PRCAK1,J,PRCAMT Q
|
||||
FY1 S DA(1)=PRCASV("ARREC"),DIC="^PRCA(430,"_DA(1)_",2,",DIC(0)="QL",DLAYGO=430 D ^DIC K DIC,DLAYGO Q:Y<0 S DA=+Y
|
||||
S PRCAORA=PRCAORA+PRCAMT,$P(^PRCA(430,PRCASV("ARREC"),0),"^",3)=PRCAORA,$P(^(7),"^")=PRCAORA,$P(^(2,DA,0),U,2)=PRCAMT,$P(^(0),"^",8)=PRCAMT
|
||||
K DA Q
|
||||
;
|
||||
MEDICARE ;Setup Medicare Supplemental amounts
|
||||
N DR,DIE
|
||||
I $G(PRCASV("MEDCA")) S DIE="^PRCA(430,",DR="131////"_PRCASV("MEDCA") D ^DIE
|
||||
I $G(PRCASV("MEDURE")) S DIE="^PRCA(430,",DR="132////"_PRCASV("MEDURE") D ^DIE
|
||||
K PRCASV("MEDCA"),PRCASV("MEDURE")
|
||||
Q ;MEDICARE
|
||||
;
|
||||
|
|
|
|||
|
|
@ -1,196 +1,193 @@
|
|||
RCDMC90 ;WASH IRMFO@ALTOONA,PA/TJK-DMC 90 DAY ;7/17/97 8:13 AM
|
||||
V ;;4.5;Accounts Receivable;**45,108,133,121,163,190,192,236,237,229,253**;Mar 20, 1995;Build 9
|
||||
;;Per VHA Directive 2004-038, this routine should not be modified.
|
||||
ENTER ;Entry point from nightly process
|
||||
Q:'$D(RCDOC)
|
||||
;run the interest and admin for newly flagged Katrina Patients.
|
||||
I DT'<$P($G(^RC(342,1,30)),"^",1)&(DT'>$P($G(^RC(342,1,30)),"^",2)) D ^RCEXINAD
|
||||
N DEBTOR,BILL,DEBTOR0,B0,B6,B7,LTRDT3,P30DT,PRIN,INT,ADMIN,B4,B12
|
||||
N TPRIN,TINT,TADMIN,ESTDT,CATYP,DFN,CNTR,SITE,LN,FN,MN,STNM,DOB,SITE
|
||||
N PHONE,QUIT,TOTAL,ZIPCODE,FULLNM,XN,P91DT,OFFAMT,RCNT,TLINE,REPAY,X1,X2
|
||||
N LKUP,ADDR,ADDRPHO,CHKPHONE,PSSN
|
||||
K ^XTMP("RCDMC90",$J),^TMP($J,"RCDMC90") S ^XTMP("RCDMC90",0)=DT
|
||||
S SITE=$$SITE^RCMSITE(),TLINE="0^0^0"
|
||||
S X1=DT,X2=-91 D C^%DTC S P91DT=X
|
||||
S X1=DT,X2=-30 D C^%DTC S P30DT=X
|
||||
S (CNTR,DEBTOR)=0,RCNT=2 G UPDATE:$G(RCDOC)="W"
|
||||
;MASTER SHEET COMPILATION
|
||||
F S DEBTOR=$O(^PRCA(430,"C",DEBTOR)) Q:DEBTOR'?1N.N D
|
||||
.N X,RCDFN
|
||||
.S RCDFN=$P($G(^RCD(340,DEBTOR,0)),"^",1) I $P(RCDFN,";",2)'["DPT" Q
|
||||
.S X=$$EMERES^PRCAUTL(+RCDFN) I X]""&('$D(^RCD(340,"DMC",1,DEBTOR))) Q ;stop the master sheet compilation for hurricane Katrina sites
|
||||
.K ^TMP($J,"RCDMC90","BILL")
|
||||
.S QUIT=1,OFFAMT=+$P($G(^RCD(340,DEBTOR,3)),U,9)
|
||||
.D PROC(DEBTOR,.QUIT) Q:QUIT
|
||||
.;COMPILES FIELDS UNIQUE TO MASTER CODE SHEETS
|
||||
.S FULLNM=$$NM(DFN),FN=$P(FULLNM,U,3),MN=$P(FULLNM,U,4)
|
||||
.S LN=$P(FULLNM,U,1),XN=$P(FULLNM,U,2)
|
||||
.S FULLNM=FN_" "_$S(MN'="":$P(MN,".")_" ",1:"")_LN_$S(XN'="":" "_$P(XN,"."),1:"")
|
||||
.S STNM=$$LJ^XLFSTR($E(FN)_$S(MN'="":$E(MN),1:" ")_$E(LN,1,5),7," ")
|
||||
.S DOB=$$DATE8(+VADM(3))
|
||||
.;SET HOLDING GLOBAL FOR MASTER SHEETS
|
||||
.S CNTR=CNTR+1
|
||||
.S ^XTMP("RCDMC90",$J,CNTR)=$E($$LJ^XLFSTR($P(VADM(2),U),9),1,9)_STNM_SITE_DOB_PHONE_$$LJ^XLFSTR(FULLNM,40)_$$LJ^XLFSTR($E($P(ADDR,U,1),1,2),2)
|
||||
.S CNTR=CNTR+1
|
||||
.S ^XTMP("RCDMC90",$J,CNTR)=$$LJ^XLFSTR($E($P(ADDR,U,1),3,40),38)_$$LJ^XLFSTR($E($P(ADDR,U,2),1,40),40)_$$LJ^XLFSTR($E($P(ADDR,U,3)),1)
|
||||
.S CNTR=CNTR+1
|
||||
.S ^XTMP("RCDMC90",$J,CNTR)=$$LJ^XLFSTR($E($P(ADDR,U,3),2,40),39)_$$LJ^XLFSTR($E($P(ADDR,U,4),1,40),40)
|
||||
.S CNTR=CNTR+1
|
||||
.S ^XTMP("RCDMC90",$J,CNTR)=$$LJ^XLFSTR($E($P(ADDR,U,5),1,40),40)_$$LJ^XLFSTR(ZIPCODE,9)_$$DATE8(ESTDT)_$$AMT(TPRIN)_$$AMT(TINT)_$E($$AMT(TADMIN),1,4)
|
||||
.S CNTR=CNTR+1
|
||||
.S ^XTMP("RCDMC90",$J,CNTR)=$E($$AMT(TADMIN),5,9)_$$DATE8(DT)_CATYP_$$AMT(OFFAMT)_$$AMT($$BAL(DEBTOR))_$E("0000000000",1,10-$L(DEBTOR))_DEBTOR_"$"
|
||||
.S $P(^RCD(340,DEBTOR,3),U)=1,$P(^(3),U,2)=DT,$P(^(3),U,3)=ESTDT,$P(^(3),U,5)=TOTAL,$P(^(3),U,6)=TPRIN,$P(^(3),U,7)=TINT,$P(^(3),U,8)=TADMIN,^RCD(340,"DMC",1,DEBTOR)=""
|
||||
.S X=0 F S X=$O(^TMP($J,"RCDMC90","BILL",X)) Q:'X S ^PRCA(430,X,12)=^(X)
|
||||
.D SETREC
|
||||
.Q
|
||||
D COMPILE^RCDMC90U(375,CNTR,5,TLINE),KVAR
|
||||
Q
|
||||
UPDATE ;WEEKLY UPDATE COMPILATION
|
||||
F S DEBTOR=$O(^RCD(340,"DMC",1,DEBTOR)) Q:DEBTOR'?1N.N D
|
||||
.I '$G(^RCD(340,DEBTOR,3)) K ^RCD(340,"DMC",1,DEBTOR) Q
|
||||
.S QUIT=1,OFFAMT=+$P(^RCD(340,DEBTOR,3),U,9)
|
||||
.D PROC(DEBTOR,.QUIT) Q:QUIT
|
||||
.;SET HOLDING GLOBAL FOR WEEKLY UPDATES
|
||||
.S CNTR=CNTR+1
|
||||
.S ^XTMP("RCDMC90",$J,CNTR)=$E($$LJ^XLFSTR($P(VADM(2),U),9),1,9)_$$LJ^XLFSTR($E($P(ADDR,U,1),1,40),40)_$$LJ^XLFSTR($E($P(ADDR,U,2),1,30),30)
|
||||
.S CNTR=CNTR+1
|
||||
.S ^XTMP("RCDMC90",$J,CNTR)=$$LJ^XLFSTR($E($P(ADDR,U,2),31,40),10)_$$LJ^XLFSTR($E($P(ADDR,U,3),1,40),40)_$$LJ^XLFSTR($E($P(ADDR,U,4),1,29),29)
|
||||
.S CNTR=CNTR+1
|
||||
.S ^XTMP("RCDMC90",$J,CNTR)=$$LJ^XLFSTR($E($P(ADDR,U,4),30,40),11)_$$LJ^XLFSTR($E($P(ADDR,U,5),1,40),40)_$$LJ^XLFSTR(ZIPCODE,9)_SITE_PHONE_$E($$AMT(TPRIN),1,6)
|
||||
.S CNTR=CNTR+1
|
||||
.S ^XTMP("RCDMC90",$J,CNTR)=$E($$AMT(TPRIN),7,9)_$$AMT(TINT)_$$AMT(TADMIN)_$$DATE8(DT)_CATYP_$$AMT(OFFAMT)_$$AMT($$BAL(DEBTOR))_"$"
|
||||
.S:TOTAL $P(^RCD(340,DEBTOR,3),U,5)=TOTAL,$P(^(3),U,6)=TPRIN,$P(^(3),U,7)=TINT,$P(^(3),U,8)=TADMIN
|
||||
.D SETREC
|
||||
.Q
|
||||
D COMPILE^RCDMC90U(300,CNTR,4,TLINE),KVAR
|
||||
Q
|
||||
KVAR D KVAR^VADPT
|
||||
K RCDOC,^XTMP("RCDMC90",$J),VA("BID"),XMDUZ
|
||||
Q
|
||||
PROC(DEBTOR,QUIT) ;PROCESS BILLS FOR A SPECIFIC DEBTOR
|
||||
;SETS DATA COMMON TO BOTH WEEKLY & MASTER CODESHEETS
|
||||
S DEBTOR0=$G(^RCD(340,DEBTOR,0))
|
||||
Q:$P(DEBTOR0,U)'["DPT"
|
||||
S DFN=+DEBTOR0 D DEM^VADPT Q:$E(VADM(2),1,5)="00000"
|
||||
F X=1:1:6 S CATYP(X)=""
|
||||
S (BILL,TOTAL,TPRIN,TINT,TADMIN,REPAY)=0,ESTDT=P91DT
|
||||
I RCDOC="W",$P(^RCD(340,DEBTOR,3),U,10) G TOTAL
|
||||
F S BILL=$O(^PRCA(430,"C",DEBTOR,BILL)) Q:BILL'?1N.N D K:PRIN=0 ^PRCA(430,BILL,12) Q:REPAY
|
||||
.S (PRIN,INT,ADMIN)=0
|
||||
.I +VADM(6) Q
|
||||
.S B0=$G(^PRCA(430,BILL,0)),B4=$G(^(4)),B6=$G(^(6)),B7=$G(^(7)),B12=$G(^(12))
|
||||
.Q:$P(B0,U,8)'=16
|
||||
.I B4 D Q
|
||||
..S (TOTAL,TPRIN,TINT,TADMIN)=0
|
||||
..S X=0 F S X=$O(^PRCA(430,"C",DEBTOR,X)) Q:X'?1N.N K ^PRCA(430,X,12)
|
||||
..S REPAY=1
|
||||
..Q
|
||||
.I RCDOC="W",'$P(B12,U) Q
|
||||
.S PRIN=$P(B7,U),INT=$P(B7,U,2),ADMIN=$P(B7,U,3)+$P(B7,U,4)+$P(B7,U,5)
|
||||
.I PRIN'>0,INT+ADMIN>0 D Q
|
||||
..N XMSUB,XMY,XMTEXT,MSG
|
||||
..S XMSUB="Notice Of Active Bill Without Principal Balance"
|
||||
..S XMY("G.DMR")=""
|
||||
..S XMDUZ="AR PACKAGE"
|
||||
..S XMTEXT="MSG("
|
||||
..S MSG(1)="The following bill has a 0 principal balance,"
|
||||
..S MSG(2)="but has interest/admin charges remaining."
|
||||
..S MSG(3)="These charges should be exempted"
|
||||
..S MSG(4)=" "
|
||||
..S MSG(5)="BILL #: "_$P(B0,U)
|
||||
..D ^XMD
|
||||
..Q
|
||||
.Q:$P(B4,U)
|
||||
.S LTRDT3=$P(B6,U,3) Q:'LTRDT3 Q:LTRDT3>P30DT
|
||||
.;CHECK FOR DC REFERRAL HERE
|
||||
.I $P(B6,U,4),($P(B6,U,5)="DC")!($P(B6,U,5)="RC") Q
|
||||
.;Q:$$INSURED^IBCNS1(DFN,$P(B0,U,10)) ;Commented out w/patch *121
|
||||
.S X=$P(B0,U,2),X=$S(X=22:1,X=23:1,(X>2)&(X<6):2,X=18:2,X=24:2,X=25:2,X=1:3,X=2:4,(X>26)&(X<30):5,X>29:6,1:"")
|
||||
.Q:X="" K CATYP(X)
|
||||
.;Check if bill should be deferred from being sent to DMC if Veteran is
|
||||
.;SC 50% to 100% or Receiving VA Pension (Hold Debt to DMC project, sbw)
|
||||
.Q:+$$HOLDCHK^RCDMCUT1(BILL,DFN)>0
|
||||
.I $P(B6,U,21),$P(B6,U,21)<ESTDT S ESTDT=$P($P(B6,U,21),".")
|
||||
.I $P(B12,U,2),PRIN>$P(B12,U,2) S PRIN=$P(B12,U,2)
|
||||
.S ^TMP($J,"RCDMC90","BILL",BILL)=$S($P(B12,U):$P(B12,U),1:DT)_U_PRIN_U_INT_U_ADMIN
|
||||
.S TPRIN=TPRIN+PRIN,TINT=TINT+INT,TADMIN=TADMIN+ADMIN
|
||||
.Q
|
||||
TOTAL S TOTAL=TPRIN+TINT+TADMIN
|
||||
I RCDOC="M" Q:TPRIN'>0 ;PRCA*4.5*229
|
||||
I RCDOC="M",'+$$SWSTAT^IBBAPI() Q:TOTAL<25 ;PRCA*4.5*229
|
||||
;
|
||||
I RCDOC="M",$P(VADM(2),U)["P" S PSSN=$P(VADM(2),U) D PSEUDO^RCDMC90U(DFN,PSSN) Q
|
||||
I RCDOC="W" Q:(TOTAL_U_TPRIN_U_TINT_U_TADMIN)=$P(^RCD(340,DEBTOR,3),U,5,8)
|
||||
S DFN=+DEBTOR0
|
||||
;SETS CATEGORY CODE 1=MEANS TEST,2=PHARMACY,3=INEL.,4=EMER./HUM.
|
||||
;5=CHAMPVA,6=TRICARE OR ANY COMBINATION THEREOF
|
||||
S CATYP="" F X=1:1:6 S:'$D(CATYP(X)) CATYP=CATYP_X
|
||||
S CATYP=$$LJ^XLFSTR(CATYP,6)
|
||||
;
|
||||
;Send Master/Weekly error msg if Unknown or Invalid address
|
||||
;If Master update, quit and don't refer to DMC
|
||||
;If Weekly update, send a zero balance
|
||||
S LKUP=$$CHKADD(DEBTOR)
|
||||
I LKUP D ERROR^RCDMC90U(RCDOC,LKUP,DFN) Q:RCDOC="M" S (TOTAL,TPRIN,TINT,TADMIN)=0
|
||||
;
|
||||
S ZIPCODE=$TR($P(ADDR,U,6),"-")
|
||||
;
|
||||
;Retrieve and format patient phone number
|
||||
S ADDRPHO=$P(ADDR,U,7),PHONE=""
|
||||
F I=1:1:$L(ADDRPHO) S CHKPHONE=$E(ADDRPHO,I) I CHKPHONE?1N S PHONE=PHONE_CHKPHONE
|
||||
S PHONE=$S(PHONE?10N:PHONE,PHONE?7N:" "_PHONE,1:" ")
|
||||
;
|
||||
I RCDOC="W",TOTAL=0 D
|
||||
.K ^RCD(340,"DMC",1,DEBTOR),^RCD(340,DEBTOR,3)
|
||||
.N NM,XMSUB,XMY,XMTEXT,MSG
|
||||
.S XMSUB="Deletion of Debtor from DMC"
|
||||
.S XMY("G.DMX")=""
|
||||
.S XMDUZ="AR PACKAGE"
|
||||
.S XMTEXT="MSG("
|
||||
.S MSG(1)="The following patient has a DMC balance of '0'"
|
||||
.S MSG(2)="and will be deleted from the DMC system:"
|
||||
.S MSG(3)=" "
|
||||
.S MSG(4)=$P(^DPT(DFN,0),U)_" SSN: "_$P(^(0),U,9)
|
||||
.D ^XMD
|
||||
.Q
|
||||
S QUIT=0
|
||||
PROCQ Q
|
||||
DATE8(X) ;CHANGES FILEMAN DATE INTO 8 DIGIT DATE IN FORMAT MMDDYYYY
|
||||
S X=$E(X,4,7)_($E(X,1,3)+1700)
|
||||
Q X
|
||||
AMT(X) ;CHANGES AMOUNT TO ZERO FILLED, RIGHT JUSTIFIED
|
||||
S X=$TR($J(X,0,2),".")
|
||||
S X=$E("000000000",1,9-$L(X))_X
|
||||
Q X
|
||||
NM(DFN) ;Returns first, middle, and last name in 3 different variables
|
||||
N FN,LN,MN,NM,XN
|
||||
S NM=$P($G(^DPT(DFN,0)),"^")
|
||||
S LN=$TR($P(NM,",")," .'-"),MN=$P($P(NM,",",2)," ",2)
|
||||
I ($E(MN,1,2)="SR")!($E(MN,1,2)="JR")!(MN?2.3"I")!(MN?0.1"I"1"V"1.3"I") S XN=MN,MN=""
|
||||
I $G(XN)="" S XN=$P($P($G(NM),",",2)," ",3)
|
||||
S FN=$P($P(NM,",",2)," ")
|
||||
QNM Q LN_"^"_XN_"^"_FN_"^"_MN
|
||||
BAL(DEBTOR) ;COMPUTES TOTAL OF ACTIVE BILLS THAT COULD BE SENT TO DMC
|
||||
N BILL,BAL
|
||||
S (BILL,BAL)=0
|
||||
F S BILL=$O(^PRCA(430,"C",DEBTOR,BILL)) Q:BILL'?1N.N D
|
||||
.S B0=$G(^PRCA(430,BILL,0)),B7=$G(^(7))
|
||||
.Q:$P(B0,U,8)'=16
|
||||
.S X=$P(B0,U,2),X=$S((X>0)&(X<6):1,X=18:1,(X>21)&(X<26):1,(X>26)&(X<33):1,1:"")
|
||||
.Q:X=""
|
||||
.S BAL=BAL+$P(B7,U)+$P(B7,U,2)+$P(B7,U,3)+$P(B7,U,4)+$P(B7,U,5)
|
||||
.Q
|
||||
BALQ Q BAL
|
||||
SETREC ;SETS TEMPORARY GLOBAL FOR MAIL MESSAGE TO USERS
|
||||
S RCNT=RCNT+1 D PID^VADPT S:$L(VA("BID"))=4 VA("BID")=" "_VA("BID")
|
||||
S TLINE=($P(TLINE,U)+TPRIN)_U_($P(TLINE,U,2)+TINT)_U_($P(TLINE,U,3)+TADMIN)
|
||||
S ^XTMP("RCDMC90",$J,"REC",$P(^DPT(DFN,0),U)_";"_DFN)=$$LJ^XLFSTR($E($P(^DPT(DFN,0),U),1,28),29)_" "_VA("BID")_" "_$J(TPRIN,10,2)_$J(TINT,10,2)_$J(TADMIN,10,2)_$J(TOTAL,10,2)
|
||||
Q
|
||||
;
|
||||
CHKADD(DEBTOR) ; Checks for invalid and unknown addresses
|
||||
N CHK S CHK=0,ADDR=""
|
||||
I $P($G(^RCD(340,+DEBTOR,1)),"^",9)=1 S CHK=1 G CHKADDQ
|
||||
S ADDR=$$DADD^RCAMADD(+DEBTOR,1) ;get address (confidential if possible)
|
||||
I ADDR'?.ANP!(ADDR["$")!(ADDR["**")!(ADDR["///")!(ADDR["ZZZ") S CHK=2
|
||||
CHKADDQ Q CHK
|
||||
;
|
||||
RCDMC90 ;WASH IRMFO@ALTOONA,PA/TJK-DMC 90 DAY ;7/17/97 8:13 AM
|
||||
V ;;4.5;Accounts Receivable;**45,108,133,121,163,190,192,236,237,229**;Mar 20, 1995
|
||||
;;Per VHA Directive 10-93-142, this routine should not be modified.
|
||||
ENTER ;Entry point from nightly process
|
||||
Q:'$D(RCDOC)
|
||||
;run the interest and admin for newly flagged Katrina Patients.
|
||||
I DT'<$P($G(^RC(342,1,30)),"^",1)&(DT'>$P($G(^RC(342,1,30)),"^",2)) D ^RCEXINAD
|
||||
N DEBTOR,BILL,DEBTOR0,B0,B6,B7,LTRDT3,P30DT,PRIN,INT,ADMIN,B4,B12
|
||||
N TPRIN,TINT,TADMIN,ESTDT,CATYP,DFN,CNTR,SITE,LN,FN,MN,STNM,DOB,SITE
|
||||
N PHONE,QUIT,TOTAL,ZIPCODE,FULLNM,XN,P91DT,OFFAMT,RCNT,TLINE,REPAY,X1,X2
|
||||
N LKUP,ADDR,ADDRPHO,CHKPHONE,PSSN
|
||||
K ^XTMP("RCDMC90",$J),^TMP($J,"RCDMC90") S ^XTMP("RCDMC90",0)=DT
|
||||
S SITE=$$SITE^RCMSITE(),TLINE="0^0^0"
|
||||
S X1=DT,X2=-91 D C^%DTC S P91DT=X
|
||||
S X1=DT,X2=-30 D C^%DTC S P30DT=X
|
||||
S (CNTR,DEBTOR)=0,RCNT=2 G UPDATE:$G(RCDOC)="W"
|
||||
;MASTER SHEET COMPILATION
|
||||
F S DEBTOR=$O(^PRCA(430,"C",DEBTOR)) Q:DEBTOR'?1N.N D
|
||||
.N X,RCDFN
|
||||
.S RCDFN=$P($G(^RCD(340,DEBTOR,0)),"^",1) I $P(RCDFN,";",2)'["DPT" Q
|
||||
.S X=$$EMERES^PRCAUTL(+RCDFN) I X]""&('$D(^RCD(340,"DMC",1,DEBTOR))) Q ;stop the master sheet compilation for hurricane Katrina sites
|
||||
.K ^TMP($J,"RCDMC90","BILL")
|
||||
.S QUIT=1,OFFAMT=+$P($G(^RCD(340,DEBTOR,3)),U,9)
|
||||
.D PROC(DEBTOR,.QUIT) Q:QUIT
|
||||
.;COMPILES FIELDS UNIQUE TO MASTER CODE SHEETS
|
||||
.S FULLNM=$$NM(DFN),FN=$P(FULLNM,U,3),MN=$P(FULLNM,U,4)
|
||||
.S LN=$P(FULLNM,U,1),XN=$P(FULLNM,U,2)
|
||||
.S FULLNM=FN_" "_$S(MN'="":$P(MN,".")_" ",1:"")_LN_$S(XN'="":" "_$P(XN,"."),1:"")
|
||||
.S STNM=$$LJ^XLFSTR($E(FN)_$S(MN'="":$E(MN),1:" ")_$E(LN,1,5),7," ")
|
||||
.S DOB=$$DATE8(+VADM(3))
|
||||
.;SET HOLDING GLOBAL FOR MASTER SHEETS
|
||||
.S CNTR=CNTR+1
|
||||
.S ^XTMP("RCDMC90",$J,CNTR)=$E($$LJ^XLFSTR($P(VADM(2),U),9),1,9)_STNM_SITE_DOB_PHONE_$$LJ^XLFSTR(FULLNM,40)_$$LJ^XLFSTR($E($P(ADDR,U,1),1,2),2)
|
||||
.S CNTR=CNTR+1
|
||||
.S ^XTMP("RCDMC90",$J,CNTR)=$$LJ^XLFSTR($E($P(ADDR,U,1),3,40),38)_$$LJ^XLFSTR($E($P(ADDR,U,2),1,40),40)_$$LJ^XLFSTR($E($P(ADDR,U,3)),1)
|
||||
.S CNTR=CNTR+1
|
||||
.S ^XTMP("RCDMC90",$J,CNTR)=$$LJ^XLFSTR($E($P(ADDR,U,3),2,40),39)_$$LJ^XLFSTR($E($P(ADDR,U,4),1,40),40)
|
||||
.S CNTR=CNTR+1
|
||||
.S ^XTMP("RCDMC90",$J,CNTR)=$$LJ^XLFSTR($E($P(ADDR,U,5),1,40),40)_$$LJ^XLFSTR(ZIPCODE,9)_$$DATE8(ESTDT)_$$AMT(TPRIN)_$$AMT(TINT)_$E($$AMT(TADMIN),1,4)
|
||||
.S CNTR=CNTR+1
|
||||
.S ^XTMP("RCDMC90",$J,CNTR)=$E($$AMT(TADMIN),5,9)_$$DATE8(DT)_CATYP_$$AMT(OFFAMT)_$$AMT($$BAL(DEBTOR))_$E("0000000000",1,10-$L(DEBTOR))_DEBTOR_"$"
|
||||
.S $P(^RCD(340,DEBTOR,3),U)=1,$P(^(3),U,2)=DT,$P(^(3),U,3)=ESTDT,$P(^(3),U,5)=TOTAL,$P(^(3),U,6)=TPRIN,$P(^(3),U,7)=TINT,$P(^(3),U,8)=TADMIN,^RCD(340,"DMC",1,DEBTOR)=""
|
||||
.S X=0 F S X=$O(^TMP($J,"RCDMC90","BILL",X)) Q:'X S ^PRCA(430,X,12)=^(X)
|
||||
.D SETREC
|
||||
.Q
|
||||
D COMPILE^RCDMC90U(375,CNTR,5,TLINE),KVAR
|
||||
Q
|
||||
UPDATE ;WEEKLY UPDATE COMPILATION
|
||||
F S DEBTOR=$O(^RCD(340,"DMC",1,DEBTOR)) Q:DEBTOR'?1N.N D
|
||||
.I '$G(^RCD(340,DEBTOR,3)) K ^RCD(340,"DMC",1,DEBTOR) Q
|
||||
.S QUIT=1,OFFAMT=+$P(^RCD(340,DEBTOR,3),U,9)
|
||||
.D PROC(DEBTOR,.QUIT) Q:QUIT
|
||||
.;SET HOLDING GLOBAL FOR WEEKLY UPDATES
|
||||
.S CNTR=CNTR+1
|
||||
.S ^XTMP("RCDMC90",$J,CNTR)=$E($$LJ^XLFSTR($P(VADM(2),U),9),1,9)_$$LJ^XLFSTR($E($P(ADDR,U,1),1,40),40)_$$LJ^XLFSTR($E($P(ADDR,U,2),1,30),30)
|
||||
.S CNTR=CNTR+1
|
||||
.S ^XTMP("RCDMC90",$J,CNTR)=$$LJ^XLFSTR($E($P(ADDR,U,2),31,40),10)_$$LJ^XLFSTR($E($P(ADDR,U,3),1,40),40)_$$LJ^XLFSTR($E($P(ADDR,U,4),1,29),29)
|
||||
.S CNTR=CNTR+1
|
||||
.S ^XTMP("RCDMC90",$J,CNTR)=$$LJ^XLFSTR($E($P(ADDR,U,4),30,40),11)_$$LJ^XLFSTR($E($P(ADDR,U,5),1,40),40)_$$LJ^XLFSTR(ZIPCODE,9)_SITE_PHONE_$E($$AMT(TPRIN),1,6)
|
||||
.S CNTR=CNTR+1
|
||||
.S ^XTMP("RCDMC90",$J,CNTR)=$E($$AMT(TPRIN),7,9)_$$AMT(TINT)_$$AMT(TADMIN)_$$DATE8(DT)_CATYP_$$AMT(OFFAMT)_$$AMT($$BAL(DEBTOR))_"$"
|
||||
.S:TOTAL $P(^RCD(340,DEBTOR,3),U,5)=TOTAL,$P(^(3),U,6)=TPRIN,$P(^(3),U,7)=TINT,$P(^(3),U,8)=TADMIN
|
||||
.D SETREC
|
||||
.Q
|
||||
D COMPILE^RCDMC90U(300,CNTR,4,TLINE),KVAR
|
||||
Q
|
||||
KVAR D KVAR^VADPT
|
||||
K RCDOC,^XTMP("RCDMC90",$J),VA("BID"),XMDUZ
|
||||
Q
|
||||
PROC(DEBTOR,QUIT) ;PROCESS BILLS FOR A SPECIFIC DEBTOR
|
||||
;SETS DATA COMMON TO BOTH WEEKLY & MASTER CODESHEETS
|
||||
S DEBTOR0=$G(^RCD(340,DEBTOR,0))
|
||||
Q:$P(DEBTOR0,U)'["DPT"
|
||||
S DFN=+DEBTOR0 D DEM^VADPT Q:$E(VADM(2),1,5)="00000"
|
||||
F X=1:1:6 S CATYP(X)=""
|
||||
S (BILL,TOTAL,TPRIN,TINT,TADMIN,REPAY)=0,ESTDT=P91DT
|
||||
I RCDOC="W",$P(^RCD(340,DEBTOR,3),U,10) G TOTAL
|
||||
F S BILL=$O(^PRCA(430,"C",DEBTOR,BILL)) Q:BILL'?1N.N D K:PRIN=0 ^PRCA(430,BILL,12) Q:REPAY
|
||||
.S (PRIN,INT,ADMIN)=0
|
||||
.I +VADM(6) Q
|
||||
.S B0=$G(^PRCA(430,BILL,0)),B4=$G(^(4)),B6=$G(^(6)),B7=$G(^(7)),B12=$G(^(12))
|
||||
.Q:$P(B0,U,8)'=16
|
||||
.I B4 D Q
|
||||
..S (TOTAL,TPRIN,TINT,TADMIN)=0
|
||||
..S X=0 F S X=$O(^PRCA(430,"C",DEBTOR,X)) Q:X'?1N.N K ^PRCA(430,X,12)
|
||||
..S REPAY=1
|
||||
..Q
|
||||
.I RCDOC="W",'$P(B12,U) Q
|
||||
.S PRIN=$P(B7,U),INT=$P(B7,U,2),ADMIN=$P(B7,U,3)+$P(B7,U,4)+$P(B7,U,5)
|
||||
.I PRIN'>0,INT+ADMIN>0 D Q
|
||||
..N XMSUB,XMY,XMTEXT,MSG
|
||||
..S XMSUB="Notice Of Active Bill Without Principal Balance"
|
||||
..S XMY("G.DMR")=""
|
||||
..S XMDUZ="AR PACKAGE"
|
||||
..S XMTEXT="MSG("
|
||||
..S MSG(1)="The following bill has a 0 principal balance,"
|
||||
..S MSG(2)="but has interest/admin charges remaining."
|
||||
..S MSG(3)="These charges should be exempted"
|
||||
..S MSG(4)=" "
|
||||
..S MSG(5)="BILL #: "_$P(B0,U)
|
||||
..D ^XMD
|
||||
..Q
|
||||
.Q:$P(B4,U)
|
||||
.S LTRDT3=$P(B6,U,3) Q:'LTRDT3 Q:LTRDT3>P30DT
|
||||
.;CHECK FOR DC REFERRAL HERE
|
||||
.I $P(B6,U,4),($P(B6,U,5)="DC")!($P(B6,U,5)="RC") Q
|
||||
.;Q:$$INSURED^IBCNS1(DFN,$P(B0,U,10)) ;Commented out w/patch *121
|
||||
.S X=$P(B0,U,2),X=$S(X=22:1,X=23:1,(X>2)&(X<6):2,X=18:2,X=24:2,X=25:2,X=1:3,X=2:4,(X>26)&(X<30):5,X>29:6,1:"")
|
||||
.Q:X="" K CATYP(X)
|
||||
.I $P(B6,U,21),$P(B6,U,21)<ESTDT S ESTDT=$P($P(B6,U,21),".")
|
||||
.I $P(B12,U,2),PRIN>$P(B12,U,2) S PRIN=$P(B12,U,2)
|
||||
.S ^TMP($J,"RCDMC90","BILL",BILL)=$S($P(B12,U):$P(B12,U),1:DT)_U_PRIN_U_INT_U_ADMIN
|
||||
.S TPRIN=TPRIN+PRIN,TINT=TINT+INT,TADMIN=TADMIN+ADMIN
|
||||
.Q
|
||||
TOTAL S TOTAL=TPRIN+TINT+TADMIN
|
||||
I RCDOC="M" Q:TPRIN'>0 ;PRCA*4.5*229
|
||||
I RCDOC="M",'+$$SWSTAT^IBBAPI() Q:TOTAL<25 ;PRCA*4.5*229
|
||||
;
|
||||
I RCDOC="M",$P(VADM(2),U)["P" S PSSN=$P(VADM(2),U) D PSEUDO^RCDMC90U(DFN,PSSN) Q
|
||||
I RCDOC="W" Q:(TOTAL_U_TPRIN_U_TINT_U_TADMIN)=$P(^RCD(340,DEBTOR,3),U,5,8)
|
||||
S DFN=+DEBTOR0
|
||||
;SETS CATEGORY CODE 1=MEANS TEST,2=PHARMACY,3=INEL.,4=EMER./HUM.
|
||||
;5=CHAMPVA,6=TRICARE OR ANY COMBINATION THEREOF
|
||||
S CATYP="" F X=1:1:6 S:'$D(CATYP(X)) CATYP=CATYP_X
|
||||
S CATYP=$$LJ^XLFSTR(CATYP,6)
|
||||
;
|
||||
;Send Master/Weekly error msg if Unknown or Invalid address
|
||||
;If Master update, quit and don't refer to DMC
|
||||
;If Weekly update, send a zero balance
|
||||
S LKUP=$$CHKADD(DEBTOR)
|
||||
I LKUP D ERROR^RCDMC90U(RCDOC,LKUP,DFN) Q:RCDOC="M" S (TOTAL,TPRIN,TINT,TADMIN)=0
|
||||
;
|
||||
S ZIPCODE=$TR($P(ADDR,U,6),"-")
|
||||
;
|
||||
;Retrieve and format patient phone number
|
||||
S ADDRPHO=$P(ADDR,U,7),PHONE=""
|
||||
F I=1:1:$L(ADDRPHO) S CHKPHONE=$E(ADDRPHO,I) I CHKPHONE?1N S PHONE=PHONE_CHKPHONE
|
||||
S PHONE=$S(PHONE?10N:PHONE,PHONE?7N:" "_PHONE,1:" ")
|
||||
;
|
||||
I RCDOC="W",TOTAL=0 D
|
||||
.K ^RCD(340,"DMC",1,DEBTOR),^RCD(340,DEBTOR,3)
|
||||
.N NM,XMSUB,XMY,XMTEXT,MSG
|
||||
.S XMSUB="Deletion of Debtor from DMC"
|
||||
.S XMY("G.DMX")=""
|
||||
.S XMDUZ="AR PACKAGE"
|
||||
.S XMTEXT="MSG("
|
||||
.S MSG(1)="The following patient has a DMC balance of '0'"
|
||||
.S MSG(2)="and will be deleted from the DMC system:"
|
||||
.S MSG(3)=" "
|
||||
.S MSG(4)=$P(^DPT(DFN,0),U)_" SSN: "_$P(^(0),U,9)
|
||||
.D ^XMD
|
||||
.Q
|
||||
S QUIT=0
|
||||
PROCQ Q
|
||||
DATE8(X) ;CHANGES FILEMAN DATE INTO 8 DIGIT DATE IN FORMAT MMDDYYYY
|
||||
S X=$E(X,4,7)_($E(X,1,3)+1700)
|
||||
Q X
|
||||
AMT(X) ;CHANGES AMOUNT TO ZERO FILLED, RIGHT JUSTIFIED
|
||||
S X=$TR($J(X,0,2),".")
|
||||
S X=$E("000000000",1,9-$L(X))_X
|
||||
Q X
|
||||
NM(DFN) ;Returns first, middle, and last name in 3 different variables
|
||||
N FN,LN,MN,NM,XN
|
||||
S NM=$P($G(^DPT(DFN,0)),"^")
|
||||
S LN=$TR($P(NM,",")," .'-"),MN=$P($P(NM,",",2)," ",2)
|
||||
I ($E(MN,1,2)="SR")!($E(MN,1,2)="JR")!(MN?2.3"I")!(MN?0.1"I"1"V"1.3"I") S XN=MN,MN=""
|
||||
I $G(XN)="" S XN=$P($P($G(NM),",",2)," ",3)
|
||||
S FN=$P($P(NM,",",2)," ")
|
||||
QNM Q LN_"^"_XN_"^"_FN_"^"_MN
|
||||
BAL(DEBTOR) ;COMPUTES TOTAL OF ACTIVE BILLS THAT COULD BE SENT TO DMC
|
||||
N BILL,BAL
|
||||
S (BILL,BAL)=0
|
||||
F S BILL=$O(^PRCA(430,"C",DEBTOR,BILL)) Q:BILL'?1N.N D
|
||||
.S B0=$G(^PRCA(430,BILL,0)),B7=$G(^(7))
|
||||
.Q:$P(B0,U,8)'=16
|
||||
.S X=$P(B0,U,2),X=$S((X>0)&(X<6):1,X=18:1,(X>21)&(X<26):1,(X>26)&(X<33):1,1:"")
|
||||
.Q:X=""
|
||||
.S BAL=BAL+$P(B7,U)+$P(B7,U,2)+$P(B7,U,3)+$P(B7,U,4)+$P(B7,U,5)
|
||||
.Q
|
||||
BALQ Q BAL
|
||||
SETREC ;SETS TEMPORARY GLOBAL FOR MAIL MESSAGE TO USERS
|
||||
S RCNT=RCNT+1 D PID^VADPT S:$L(VA("BID"))=4 VA("BID")=" "_VA("BID")
|
||||
S TLINE=($P(TLINE,U)+TPRIN)_U_($P(TLINE,U,2)+TINT)_U_($P(TLINE,U,3)+TADMIN)
|
||||
S ^XTMP("RCDMC90",$J,"REC",$P(^DPT(DFN,0),U)_";"_DFN)=$$LJ^XLFSTR($E($P(^DPT(DFN,0),U),1,28),29)_" "_VA("BID")_" "_$J(TPRIN,10,2)_$J(TINT,10,2)_$J(TADMIN,10,2)_$J(TOTAL,10,2)
|
||||
Q
|
||||
;
|
||||
CHKADD(DEBTOR) ; Checks for invalid and unknown addresses
|
||||
N CHK S CHK=0,ADDR=""
|
||||
I $P($G(^RCD(340,+DEBTOR,1)),"^",9)=1 S CHK=1 G CHKADDQ
|
||||
S ADDR=$$DADD^RCAMADD(+DEBTOR,1) ;get address (confidential if possible)
|
||||
I ADDR'?.ANP!(ADDR["$")!(ADDR["**")!(ADDR["///")!(ADDR["ZZZ") S CHK=2
|
||||
CHKADDQ Q CHK
|
||||
;
|
||||
|
|
|
|||
|
|
@ -1,166 +1,166 @@
|
|||
RCDPEM ;ALB/TMK - POST EFT, ERA MATCHING TO EFT ;05-NOV-02
|
||||
;;4.5;Accounts Receivable;**173,255**;Mar 20, 1995;Build 1
|
||||
;;Per VHA Directive 10-93-142, this routine should not be modified.
|
||||
; IA 4050 covers call to SPL1^IBCEOBAR
|
||||
Q
|
||||
; Note - keep processing in line with RCDPXPAP
|
||||
EN ; Post EFT deposits, auto-match EFT's and ERA's
|
||||
;
|
||||
K ^TMP($J,"RCDPETOT")
|
||||
; ^TMP($J,"RCDPETOT",344.3 or 344.31,file ien)=
|
||||
; (1) match (0/1/-1) (2) total $ (3) posted (0/1) (4) error ref
|
||||
; (5) EFT deposit ien 344.1 if added for EFT
|
||||
;
|
||||
N RCZ,RCSUM,RCDEP,RECTDA,RC0,RCER,RCDUZ,Z,Z0,Z1,DA,X,Y,DIE,DR
|
||||
M RCDUZ=DUZ
|
||||
N DUZ S DUZ=+$O(^VA(200,"B","EDILOCKBOX,AUTOMATIC",0)),DUZ(0)="" S:'DUZ DUZ=.5
|
||||
K ^TMP($J,"RCXM"),^TMP($J,"RCTOT")
|
||||
S ZTREQ="@"
|
||||
L +^RCY(344.3,"ALOCK"):5 I '$T D G ENQ ; Lock record
|
||||
. ; Send bulletin that job could not be run
|
||||
. S ^TMP($J,"RCXM",1)="The nightly job to post EFT deposits and match EFTs to ERAs could not be run",^TMP($J,"RCXM",2)="Another match process was already running (lock on ^RCY(344.3,""ALOCK"") )"
|
||||
. D SENDBULL^RCDPEM1
|
||||
;
|
||||
; Post deposits for any unposted EFTs in file 344.3
|
||||
; 'Unposted' EFTs have a 0 in AMOUNT POSTED field
|
||||
S ^TMP($J,"RCTOT","EFT_DEP")=0
|
||||
S RCZ=0 F S RCZ=$O(^RCY(344.3,"APOST",0,RCZ)) Q:'RCZ S RC0=$G(^RCY(344.3,RCZ,0)) I RC0'="",$P(RC0,U,8),($E($P(RC0,U,6),1,3)="469")!($E($P(RC0,U,6),1,3)="569") D
|
||||
. S ^TMP($J,"RCTOT","EFT_DEP")=^TMP($J,"RCTOT","EFT_DEP")+1
|
||||
. ; Verify check sums
|
||||
. S RCSUM=$$CHKSUM^RCDPESR3(RCZ)
|
||||
. I RCSUM'=$P(RC0,U,9) D Q
|
||||
.. ; Bulletin that check sums do not match
|
||||
.. ; Update record error list and checksum error field
|
||||
.. S RCER(1)=$$SETERR^RCDPEM0(2)
|
||||
.. S RCER(2)=" Checksum is invalid and the EFT deposit record is corrupted.",RCER(3)=" Stored Checksum = "_$P(RC0,U,9)_" Calculated Checksum: "_RCSUM,RCER(4)=" This EFT deposit cannot be sent to FMS. You must ask for it to be"
|
||||
.. S RCER(5)=" retransmitted to your site."
|
||||
.. D BULL^RCDPEM1(344.3,RC0,.RCER)
|
||||
.. S $P(^TMP($J,"RCDPETOT",344.3,RCZ),U,4)=+$G(^TMP($J,"RCXM",0))
|
||||
.. D STORERR^RCDPEM0(RCZ,.RCER)
|
||||
.. S DIE="^RCY(344.3,",DA=RCZ,DR=".1////1" D ^DIE
|
||||
.. S ^TMP($J,"RCTOT","CSUM")=$G(^TMP($J,"RCTOT","CSUM"))+1
|
||||
. ;
|
||||
. S RCDEP=+$P(RC0,U,3),RECTDA=+$O(^RCY(344,"AD",RCDEP,0))
|
||||
. I RCDEP D LOCKDEP(RCDEP,1)
|
||||
. I 'RCDEP!'RECTDA D ; Add deposit and/or receipt to files 344.1, 344
|
||||
.. I 'RCDEP D ; Add dep record RCDEP, update field .03 with the pointer
|
||||
... S RCDEP=+$$ADDDEP^RCDPEM0($P(RC0,U,6),$P(RC0,U,7),RCZ)
|
||||
... S ^TMP($J,"RCTOT","DEPOSIT")=$G(^TMP($J,"RCTOT","DEPOSIT"))+1
|
||||
.. ;
|
||||
.. I 'RECTDA,RCDEP D ; Add receipt record, post to rev source cd 8NZZ
|
||||
... S RECTDA=+$$ADDREC^RCDPEM0(RCDEP,RCZ)
|
||||
.. ;
|
||||
. I RCDEP D LOCKDEP(RCDEP,0)
|
||||
. ;
|
||||
. I 'RCDEP!'RECTDA D Q ; Could not add entry to file 344.1 or 344
|
||||
.. ; Send a bulletin, update error text
|
||||
.. S RCER(1)=$$SETERR^RCDPEM0(2),RCER(2)=" "_$S('RCDEP:"Neither a deposit nor a receipt were able",1:"A receipt was not able")_" to be added - no match attempted"
|
||||
.. I RCDEP,'RECTDA S RCER(3)=" Deposit Ticket # created: "_$P($G(^RCY(344.1,+$P(RC0,U,3),0)),U)
|
||||
.. S RCER($O(RCER(""),-1)+1)="This EFT deposit can't be sent to FMS. You must ask Austin to retransmit"
|
||||
.. D BULL^RCDPEM1(344.3,RC0,.RCER)
|
||||
.. S $P(^TMP($J,"RCDPETOT",344.3,RCZ),U,4)=+$G(^TMP($J,"RCXM",0))
|
||||
.. D STORERR^RCDPEM0(RCZ,.RCER)
|
||||
.. S ^TMP($J,"RCTOT","ERR")=$G(^TMP($J,"RCTOT","ERR"))+1
|
||||
. ;
|
||||
. S DIE="^RCY(344.31," S Z=0 F S Z=$O(^RCY(344.31,"B",RCZ,Z)) Q:'Z S DA=Z,DR=".11////1" D ^DIE
|
||||
;
|
||||
D MATCH(0,1)
|
||||
L -^RCY(344.3,"ALOCK")
|
||||
ENQ K ^TMP($J,"RCDPETOT")
|
||||
Q
|
||||
;
|
||||
MATCH(RCMAN,RCPROC) ; Try to matched unmatched EFTs
|
||||
; RCMAN = 1 if job run manually, outside of nightly processing
|
||||
; RCPROC = 1 if called from EFT-EOB automatch, 0 if from manual match
|
||||
;
|
||||
N RC0,RCER,RCZ,RCHAC
|
||||
I '$O(^RCY(344.31,"AMATCH",0,0)) D G MATCHQ
|
||||
. ; Send bulletin - no unmatched EFTs found
|
||||
. N RCT
|
||||
. S RCT=+$O(^TMP($J,"RCXM"," "),-1)+1
|
||||
. S ^TMP($J,"RCXM",RCT)=$S('$G(RCMAN):"The nightly job",1:"The manual option")_" to match EFTs has found no EFTs are currently unmatched on your system"
|
||||
. I $G(RCMAN) S ^TMP($J,"RCXM",RCT+1)="The action was initiated by "_$P($G(^VA(200,DUZ,0)),U)
|
||||
. D SENDBULL^RCDPEM1
|
||||
;
|
||||
S RCZ=0 F S RCZ=$O(^RCY(344.31,"AMATCH",0,RCZ)) Q:'RCZ D
|
||||
. K RCER
|
||||
. S RC0=$G(^RCY(344.31,RCZ,0)),RCHAC=($E($P($G(^RCY(344.3,+RC0,0)),U,6),1,3)="HAC")
|
||||
. Q:RC0="" ; Bad xref
|
||||
. Q:$S('RCHAC:'$P(RC0,U,11),1:0) ; EFT deposit must have been recorded
|
||||
. S ^TMP($J,"RCTOT","EFT")=$G(^TMP($J,"RCTOT","EFT"))+1
|
||||
. I RCHAC S ^TMP($J,"RCTOT","EFT_HAC")=$G(^TMP($J,"RCTOT","EFT_HAC"))+1
|
||||
. S ^TMP($J,"RCDPETOT",344.31,RCZ)=""
|
||||
. ;
|
||||
. D MATCH^RCDPEM0(RCZ,RCPROC)
|
||||
;
|
||||
I '$O(^TMP($J,"RCXM",0)) K RCER S RCER(1)="",RCER(2)="NO EXCEPTIONS WHILE MATCHING EFTs-ERAs OR IN RECORDING THE DEPOSITS TO FMS" D BULL^RCDPEM1("","",.RCER) K RCER
|
||||
D EN2^RCDPEM1,BULL^RCDPEM1("","",.RCER)
|
||||
D SENDBULL^RCDPEM1
|
||||
;
|
||||
MATCHQ K ^TMP($J,"RCDPETOT"),^TMP($J,"RCTOT")
|
||||
Q
|
||||
;
|
||||
LOCKDEP(RCDEP,LOCK) ; Lock/confirm deposit ien RCDEP file 341.1
|
||||
; If LOCK = 1 lock deposit
|
||||
; If LOCK = 0 unlock deposit
|
||||
I $G(LOCK) D
|
||||
. L +^RCY(344.1,RCDEP,0)
|
||||
. D CONFIRM^RCDPUDEP(RCDEP) ; confirm to prevent changes
|
||||
I '$G(LOCK) L -^RCY(344.1,RCDEP,0)
|
||||
Q
|
||||
;
|
||||
RCPTDET(RCRZ,RECTDA1,RCER) ; Adds detail to a receipt based on file 344.49
|
||||
; RCRZ = ien of ERA entry in file 344.49
|
||||
; RECTDA1 = ien of receipt entry in file 344
|
||||
; RCER = error array returned if passed by reference
|
||||
;
|
||||
N RCR,RCSPL,RCZ0,RCTRANDA,RCQ,DR,DA,DIE,X,Y,Q,Z0,Z1,Z
|
||||
;
|
||||
S RCR=0 F S RCR=$O(^RCY(344.49,RCRZ,1,RCR)) Q:'RCR D
|
||||
. S RCZ0=$G(^RCY(344.49,RCRZ,1,RCR,0))
|
||||
. I $P(RCZ0,U)'["." S RCSPL(+RCZ0)=$P(RCZ0,U,9) Q
|
||||
. I $S(+$P(RCZ0,U,3)=0:$P($G(^RCY(344.49,RCRZ,0)),U,3),1:$P(RCZ0,U,3)<0) S RCSPL(RCZ0\1,+RCZ0)=RCZ0 Q
|
||||
. S RCTRANDA=$$ADDTRAN^RCDPURET(RECTDA1)
|
||||
. ;
|
||||
. I 'RCTRANDA D Q ; Error adding receipt detail
|
||||
.. S RCER(1)=$$SETERR^RCDPEM0() S RCER($O(RCER(""),-1)+1)=" NO DETAIL LINE ADDED TO RECEIPT "_$P($G(^RCY(344,RECTDA1,0)),U)_" FOR LINE #"_$P(RCZ0,U)_" IN EEOB WORKLIST SCRATCH PAD"
|
||||
. ;
|
||||
. ;Store receipt line detail
|
||||
. D DET(RCRZ,RCR,RECTDA1,RCTRANDA)
|
||||
. S RCSPL(RCZ0\1,+RCZ0)=RCZ0
|
||||
S Z=0 F S Z=$O(RCSPL(Z)) Q:'Z S RCQ=+$G(RCSPL(Z)) I RCQ D
|
||||
. S Z1=$O(RCSPL(Z,"")) Q:$O(RCSPL(Z,""),-1)=Z1 ; No split occurred
|
||||
. S Z1=0 F S Z1=$O(RCSPL(Z,Z1)) Q:'Z1 S Z0=$G(RCSPL(Z,Z1)) D
|
||||
.. S Q=+$P($G(^RCY(344.4,RCRZ,1,RCQ,0)),U,2) ; EOB detail rec
|
||||
.. Q:'Q
|
||||
.. I '$P(Z0,U,7)!($P(Z0,U,2)="") D ; Suspensed
|
||||
... D SPL1^IBCEOBAR(Q,$S($P(Z0,U,2)="":"NO BILL",1:$P(Z0,U,2)),"",$P(Z0,U,6)) ; IA 4050
|
||||
.. E D
|
||||
... D SPL1^IBCEOBAR(Q,$P(Z0,U,2),$P(Z0,U,7),$P(Z0,U,6)) ; Add the split bill # ; IA 4050
|
||||
;
|
||||
Q
|
||||
;
|
||||
DET(RCZ,RCR,RECTDA1,RCTRANDA) ; Store receipt detail
|
||||
; RCZ = ien of entry file 344.49
|
||||
; RCR = ien of entry in file 344.491
|
||||
; RCPROC = Function calling this subroutine
|
||||
; = 1 EFT match to ERA = 0 manual add receipt
|
||||
; RECTDA1 = ien of entry in file 344
|
||||
; RCTRANDA = ien of entry in subfile 344.01
|
||||
;
|
||||
N DIE,DA,DR,X,Y,Z,RCUP,RCCOM,RCZ0,RC0
|
||||
S RC0=$G(^RCY(344.49,RCZ,0))
|
||||
S RCZ0=$G(^RCY(344.49,RCZ,1,RCR,0))
|
||||
S DR="",RCUP=+$O(^RCY(344.49,RCZ,1,"B",+RCZ0/1,0)),RCUP=$G(^RCY(344.49,RCZ,1,RCUP,0))
|
||||
I $P(RCZ0,U,7) S DR=".09////^S X="_+$P(RCZ0,U,7)_"_$C(59)_""PRCA(430,"";"
|
||||
S DR=DR_".04////"_(+$P(RCZ0,U,3))_";"_$S($P(RC0,U,4)'="":".13////"_$P(RC0,U,4)_";",1:"")_".27////"_RCR_";"
|
||||
I $P(RC0,U,5)'="" S DR=DR_".1////"_$P(RC0,U,5)_";"
|
||||
I $P(RC0,U,6)'="" S DR=DR_".08////"_$P(RC0,U,6)_";"
|
||||
S RCCOM=$P(RCZ0,U,10)
|
||||
S Z=0 F S Z=$O(^RCY(344.49,RCZ,1,RCR,1,Z)) Q:'Z I $P($G(^(Z,0)),U,5)=1 S DR=DR_".28////1;" Q ; Update receipt line with dec adj flag
|
||||
I $P(RCUP,U,2)["**ADJ" S DR=DR_"1.02////"_$E($S(RCCOM'="":RCCOM_"/",1:"")_$S($P($P(RCUP,U,2),"ADJ",2):"ERA adjustment - no bill referenced",1:"Total of EFT mismatched to ERA"),1,60)_";"
|
||||
I $P($G(^RCY(344.49,RCZ,0)),U,4)'="" S DR=DR_".07////"_$P($G(^RCY(344.49,RCZ,0)),U,4)_";"
|
||||
S DA(1)=RECTDA1,DA=RCTRANDA,DIE="^RCY(344,"_DA(1)_",1,"
|
||||
D ^DIE
|
||||
Q
|
||||
;
|
||||
RCDPEM ;ALB/TMK - POST EFT, ERA MATCHING TO EFT ;05-NOV-02
|
||||
;;4.5;Accounts Receivable;**173**;Mar 20, 1995
|
||||
;;Per VHA Directive 10-93-142, this routine should not be modified.
|
||||
; IA 4050 covers call to SPL1^IBCEOBAR
|
||||
Q
|
||||
; Note - keep processing in line with RCDPXPAP
|
||||
EN ; Post EFT deposits, auto-match EFT's and ERA's
|
||||
;
|
||||
K ^TMP($J,"RCDPETOT")
|
||||
; ^TMP($J,"RCDPETOT",344.3 or 344.31,file ien)=
|
||||
; (1) match (0/1/-1) (2) total $ (3) posted (0/1) (4) error ref
|
||||
; (5) EFT deposit ien 344.1 if added for EFT
|
||||
;
|
||||
N RCZ,RCSUM,RCDEP,RECTDA,RC0,RCER,RCDUZ,Z,Z0,Z1,DA,X,Y,DIE,DR
|
||||
M RCDUZ=DUZ
|
||||
N DUZ S DUZ=+$O(^VA(200,"B","EDILOCKBOX,AUTOMATIC",0)),DUZ(0)="" S:'DUZ DUZ=.5
|
||||
K ^TMP($J,"RCXM"),^TMP($J,"RCTOT")
|
||||
S ZTREQ="@"
|
||||
L +^RCY(344.3,"ALOCK"):5 I '$T D G ENQ ; Lock record
|
||||
. ; Send bulletin that job could not be run
|
||||
. S ^TMP($J,"RCXM",1)="The nightly job to post EFT deposits and match EFTs to ERAs could not be run",^TMP($J,"RCXM",2)="Another match process was already running (lock on ^RCY(344.3,""ALOCK"") )"
|
||||
. D SENDBULL^RCDPEM1
|
||||
;
|
||||
; Post deposits for any unposted EFTs in file 344.3
|
||||
; 'Unposted' EFTs have a 0 in AMOUNT POSTED field
|
||||
S ^TMP($J,"RCTOT","EFT_DEP")=0
|
||||
S RCZ=0 F S RCZ=$O(^RCY(344.3,"APOST",0,RCZ)) Q:'RCZ S RC0=$G(^RCY(344.3,RCZ,0)) I RC0'="",$E($P(RC0,U,6),1,3)="469",$P(RC0,U,8) D
|
||||
. S ^TMP($J,"RCTOT","EFT_DEP")=^TMP($J,"RCTOT","EFT_DEP")+1
|
||||
. ; Verify check sums
|
||||
. S RCSUM=$$CHKSUM^RCDPESR3(RCZ)
|
||||
. I RCSUM'=$P(RC0,U,9) D Q
|
||||
.. ; Bulletin that check sums do not match
|
||||
.. ; Update record error list and checksum error field
|
||||
.. S RCER(1)=$$SETERR^RCDPEM0(2)
|
||||
.. S RCER(2)=" Checksum is invalid and the EFT deposit record is corrupted.",RCER(3)=" Stored Checksum = "_$P(RC0,U,9)_" Calculated Checksum: "_RCSUM,RCER(4)=" This EFT deposit cannot be sent to FMS. You must ask for it to be"
|
||||
.. S RCER(5)=" retransmitted to your site."
|
||||
.. D BULL^RCDPEM1(344.3,RC0,.RCER)
|
||||
.. S $P(^TMP($J,"RCDPETOT",344.3,RCZ),U,4)=+$G(^TMP($J,"RCXM",0))
|
||||
.. D STORERR^RCDPEM0(RCZ,.RCER)
|
||||
.. S DIE="^RCY(344.3,",DA=RCZ,DR=".1////1" D ^DIE
|
||||
.. S ^TMP($J,"RCTOT","CSUM")=$G(^TMP($J,"RCTOT","CSUM"))+1
|
||||
. ;
|
||||
. S RCDEP=+$P(RC0,U,3),RECTDA=+$O(^RCY(344,"AD",RCDEP,0))
|
||||
. I RCDEP D LOCKDEP(RCDEP,1)
|
||||
. I 'RCDEP!'RECTDA D ; Add deposit and/or receipt to files 344.1, 344
|
||||
.. I 'RCDEP D ; Add dep record RCDEP, update field .03 with the pointer
|
||||
... S RCDEP=+$$ADDDEP^RCDPEM0($P(RC0,U,6),$P(RC0,U,7),RCZ)
|
||||
... S ^TMP($J,"RCTOT","DEPOSIT")=$G(^TMP($J,"RCTOT","DEPOSIT"))+1
|
||||
.. ;
|
||||
.. I 'RECTDA,RCDEP D ; Add receipt record, post to rev source cd 8NZZ
|
||||
... S RECTDA=+$$ADDREC^RCDPEM0(RCDEP,RCZ)
|
||||
.. ;
|
||||
. I RCDEP D LOCKDEP(RCDEP,0)
|
||||
. ;
|
||||
. I 'RCDEP!'RECTDA D Q ; Could not add entry to file 344.1 or 344
|
||||
.. ; Send a bulletin, update error text
|
||||
.. S RCER(1)=$$SETERR^RCDPEM0(2),RCER(2)=" "_$S('RCDEP:"Neither a deposit nor a receipt were able",1:"A receipt was not able")_" to be added - no match attempted"
|
||||
.. I RCDEP,'RECTDA S RCER(3)=" Deposit Ticket # created: "_$P($G(^RCY(344.1,+$P(RC0,U,3),0)),U)
|
||||
.. S RCER($O(RCER(""),-1)+1)="This EFT deposit can't be sent to FMS. You must ask Austin to retransmit"
|
||||
.. D BULL^RCDPEM1(344.3,RC0,.RCER)
|
||||
.. S $P(^TMP($J,"RCDPETOT",344.3,RCZ),U,4)=+$G(^TMP($J,"RCXM",0))
|
||||
.. D STORERR^RCDPEM0(RCZ,.RCER)
|
||||
.. S ^TMP($J,"RCTOT","ERR")=$G(^TMP($J,"RCTOT","ERR"))+1
|
||||
. ;
|
||||
. S DIE="^RCY(344.31," S Z=0 F S Z=$O(^RCY(344.31,"B",RCZ,Z)) Q:'Z S DA=Z,DR=".11////1" D ^DIE
|
||||
;
|
||||
D MATCH(0,1)
|
||||
L -^RCY(344.3,"ALOCK")
|
||||
ENQ K ^TMP($J,"RCDPETOT")
|
||||
Q
|
||||
;
|
||||
MATCH(RCMAN,RCPROC) ; Try to matched unmatched EFTs
|
||||
; RCMAN = 1 if job run manually, outside of nightly processing
|
||||
; RCPROC = 1 if called from EFT-EOB automatch, 0 if from manual match
|
||||
;
|
||||
N RC0,RCER,RCZ,RCHAC
|
||||
I '$O(^RCY(344.31,"AMATCH",0,0)) D G MATCHQ
|
||||
. ; Send bulletin - no unmatched EFTs found
|
||||
. N RCT
|
||||
. S RCT=+$O(^TMP($J,"RCXM"," "),-1)+1
|
||||
. S ^TMP($J,"RCXM",RCT)=$S('$G(RCMAN):"The nightly job",1:"The manual option")_" to match EFTs has found no EFTs are currently unmatched on your system"
|
||||
. I $G(RCMAN) S ^TMP($J,"RCXM",RCT+1)="The action was initiated by "_$P($G(^VA(200,DUZ,0)),U)
|
||||
. D SENDBULL^RCDPEM1
|
||||
;
|
||||
S RCZ=0 F S RCZ=$O(^RCY(344.31,"AMATCH",0,RCZ)) Q:'RCZ D
|
||||
. K RCER
|
||||
. S RC0=$G(^RCY(344.31,RCZ,0)),RCHAC=($E($P($G(^RCY(344.3,+RC0,0)),U,6),1,3)="HAC")
|
||||
. Q:RC0="" ; Bad xref
|
||||
. Q:$S('RCHAC:'$P(RC0,U,11),1:0) ; EFT deposit must have been recorded
|
||||
. S ^TMP($J,"RCTOT","EFT")=$G(^TMP($J,"RCTOT","EFT"))+1
|
||||
. I RCHAC S ^TMP($J,"RCTOT","EFT_HAC")=$G(^TMP($J,"RCTOT","EFT_HAC"))+1
|
||||
. S ^TMP($J,"RCDPETOT",344.31,RCZ)=""
|
||||
. ;
|
||||
. D MATCH^RCDPEM0(RCZ,RCPROC)
|
||||
;
|
||||
I '$O(^TMP($J,"RCXM",0)) K RCER S RCER(1)="",RCER(2)="NO EXCEPTIONS WHILE MATCHING EFTs-ERAs OR IN RECORDING THE DEPOSITS TO FMS" D BULL^RCDPEM1("","",.RCER) K RCER
|
||||
D EN2^RCDPEM1,BULL^RCDPEM1("","",.RCER)
|
||||
D SENDBULL^RCDPEM1
|
||||
;
|
||||
MATCHQ K ^TMP($J,"RCDPETOT"),^TMP($J,"RCTOT")
|
||||
Q
|
||||
;
|
||||
LOCKDEP(RCDEP,LOCK) ; Lock/confirm deposit ien RCDEP file 341.1
|
||||
; If LOCK = 1 lock deposit
|
||||
; If LOCK = 0 unlock deposit
|
||||
I $G(LOCK) D
|
||||
. L +^RCY(344.1,RCDEP,0)
|
||||
. D CONFIRM^RCDPUDEP(RCDEP) ; confirm to prevent changes
|
||||
I '$G(LOCK) L -^RCY(344.1,RCDEP,0)
|
||||
Q
|
||||
;
|
||||
RCPTDET(RCRZ,RECTDA1,RCER) ; Adds detail to a receipt based on file 344.49
|
||||
; RCRZ = ien of ERA entry in file 344.49
|
||||
; RECTDA1 = ien of receipt entry in file 344
|
||||
; RCER = error array returned if passed by reference
|
||||
;
|
||||
N RCR,RCSPL,RCZ0,RCTRANDA,RCQ,DR,DA,DIE,X,Y,Q,Z0,Z1,Z
|
||||
;
|
||||
S RCR=0 F S RCR=$O(^RCY(344.49,RCRZ,1,RCR)) Q:'RCR D
|
||||
. S RCZ0=$G(^RCY(344.49,RCRZ,1,RCR,0))
|
||||
. I $P(RCZ0,U)'["." S RCSPL(+RCZ0)=$P(RCZ0,U,9) Q
|
||||
. I $S(+$P(RCZ0,U,3)=0:$P($G(^RCY(344.49,RCRZ,0)),U,3),1:$P(RCZ0,U,3)<0) S RCSPL(RCZ0\1,+RCZ0)=RCZ0 Q
|
||||
. S RCTRANDA=$$ADDTRAN^RCDPURET(RECTDA1)
|
||||
. ;
|
||||
. I 'RCTRANDA D Q ; Error adding receipt detail
|
||||
.. S RCER(1)=$$SETERR^RCDPEM0() S RCER($O(RCER(""),-1)+1)=" NO DETAIL LINE ADDED TO RECEIPT "_$P($G(^RCY(344,RECTDA1,0)),U)_" FOR LINE #"_$P(RCZ0,U)_" IN EEOB WORKLIST SCRATCH PAD"
|
||||
. ;
|
||||
. ;Store receipt line detail
|
||||
. D DET(RCRZ,RCR,RECTDA1,RCTRANDA)
|
||||
. S RCSPL(RCZ0\1,+RCZ0)=RCZ0
|
||||
S Z=0 F S Z=$O(RCSPL(Z)) Q:'Z S RCQ=+$G(RCSPL(Z)) I RCQ D
|
||||
. S Z1=$O(RCSPL(Z,"")) Q:$O(RCSPL(Z,""),-1)=Z1 ; No split occurred
|
||||
. S Z1=0 F S Z1=$O(RCSPL(Z,Z1)) Q:'Z1 S Z0=$G(RCSPL(Z,Z1)) D
|
||||
.. S Q=+$P($G(^RCY(344.4,RCRZ,1,RCQ,0)),U,2) ; EOB detail rec
|
||||
.. Q:'Q
|
||||
.. I '$P(Z0,U,7)!($P(Z0,U,2)="") D ; Suspensed
|
||||
... D SPL1^IBCEOBAR(Q,$S($P(Z0,U,2)="":"NO BILL",1:$P(Z0,U,2)),"",$P(Z0,U,6)) ; IA 4050
|
||||
.. E D
|
||||
... D SPL1^IBCEOBAR(Q,$P(Z0,U,2),$P(Z0,U,7),$P(Z0,U,6)) ; Add the split bill # ; IA 4050
|
||||
;
|
||||
Q
|
||||
;
|
||||
DET(RCZ,RCR,RECTDA1,RCTRANDA) ; Store receipt detail
|
||||
; RCZ = ien of entry file 344.49
|
||||
; RCR = ien of entry in file 344.491
|
||||
; RCPROC = Function calling this subroutine
|
||||
; = 1 EFT match to ERA = 0 manual add receipt
|
||||
; RECTDA1 = ien of entry in file 344
|
||||
; RCTRANDA = ien of entry in subfile 344.01
|
||||
;
|
||||
N DIE,DA,DR,X,Y,Z,RCUP,RCCOM,RCZ0,RC0
|
||||
S RC0=$G(^RCY(344.49,RCZ,0))
|
||||
S RCZ0=$G(^RCY(344.49,RCZ,1,RCR,0))
|
||||
S DR="",RCUP=+$O(^RCY(344.49,RCZ,1,"B",+RCZ0/1,0)),RCUP=$G(^RCY(344.49,RCZ,1,RCUP,0))
|
||||
I $P(RCZ0,U,7) S DR=".09////^S X="_+$P(RCZ0,U,7)_"_$C(59)_""PRCA(430,"";"
|
||||
S DR=DR_".04////"_(+$P(RCZ0,U,3))_";"_$S($P(RC0,U,4)'="":".13////"_$P(RC0,U,4)_";",1:"")_".27////"_RCR_";"
|
||||
I $P(RC0,U,5)'="" S DR=DR_".1////"_$P(RC0,U,5)_";"
|
||||
I $P(RC0,U,6)'="" S DR=DR_".08////"_$P(RC0,U,6)_";"
|
||||
S RCCOM=$P(RCZ0,U,10)
|
||||
S Z=0 F S Z=$O(^RCY(344.49,RCZ,1,RCR,1,Z)) Q:'Z I $P($G(^(Z,0)),U,5)=1 S DR=DR_".28////1;" Q ; Update receipt line with dec adj flag
|
||||
I $P(RCUP,U,2)["**ADJ" S DR=DR_"1.02////"_$E($S(RCCOM'="":RCCOM_"/",1:"")_$S($P($P(RCUP,U,2),"ADJ",2):"ERA adjustment - no bill referenced",1:"Total of EFT mismatched to ERA"),1,60)_";"
|
||||
I $P($G(^RCY(344.49,RCZ,0)),U,4)'="" S DR=DR_".07////"_$P($G(^RCY(344.49,RCZ,0)),U,4)_";"
|
||||
S DA(1)=RECTDA1,DA=RCTRANDA,DIE="^RCY(344,"_DA(1)_",1,"
|
||||
D ^DIE
|
||||
Q
|
||||
;
|
||||
|
|
|
|||
|
|
@ -1,178 +1,176 @@
|
|||
RCDPESR2 ;ALB/TMK - Server auto-upd - EDI Lockbox ;06/03/02
|
||||
;;4.5;Accounts Receivable;**173,216,208,230,252**;Mar 20, 1995;Build 63
|
||||
;;Per VHA Directive 2004-038, this routine should not be modified.
|
||||
; IA 4042 (IBCEOB)
|
||||
;
|
||||
TASKERA(RCTDA) ; Task to upd ERA
|
||||
; RCTDA = ien 344.5
|
||||
N ZTDTH,ZTUCI,ZTSAVE,ZTIO,ZTDESC,ZTRTN,ZTSK,DIE,DR,DA
|
||||
S (ZTSAVE("DT"),ZTSAVE("U"),ZTSAVE("DUZ"))="",ZTSAVE("ZTREQ")="@",ZTRTN="NEWERA^RCDPESR2("_RCTDA_",0)",ZTDTH=$H,ZTIO=""
|
||||
D ^%ZTLOAD
|
||||
Q
|
||||
;
|
||||
NEWERA(RCTDA,RCREFILE) ;Tasked
|
||||
; Add new EOB's to IB & ERA tot rec to AR
|
||||
; RCTDA = ien 344.5
|
||||
; RCREFILE = 1: re-filing rec via exc proc
|
||||
N RCDUPERR,RCPAYER,RCRTOT,RCE,RCEC,RCERR,RCR1,RCADJ,DIE,DR,DA,Z,Q
|
||||
S ZTREQ="@"
|
||||
K ^TMP($J,"RCDPERA")
|
||||
L +^RCY(344.5,RCTDA):5
|
||||
I $D(ZTQUEUED) S DIE="^RCY(344.5,",DA=RCTDA,DR=".05////"_ZTSK_";.04////1" D ^DIE
|
||||
I $P($G(^RCY(344.5,RCTDA,0)),U,5),'$G(RCREFILE) S DIE="^RCY(344.5,",DA=RCTDA,DR=".1////4;.08///1" D ^DIE
|
||||
S RCR1=$P($G(^RCY(344.5,RCTDA,0)),U,7),RCPAYER=$P($G(^RCY(344.5,RCTDA,3)),U)
|
||||
S RCRTOT=$S(RCR1:RCR1,1:$$ERATOT^RCDPESR6(RCTDA,.RCERR)) ; ERA rec
|
||||
S RCDUPERR=$S($G(RCERR)="DUP"!($G(RCERR(1))=-2):$G(RCERR(1)),1:0) K RCERR(1)
|
||||
I RCRTOT,'RCR1 S DIE="^RCY(344.5,",DR=".07////"_RCRTOT,DA=RCTDA D ^DIE
|
||||
D:RCDUPERR'=-2 UPDEOB(RCTDA,5,$S('$G(RCREFILE):RCDUPERR,1:-1)) ; Add EOB det to IB
|
||||
I RCRTOT D UPDCON^RCDPESR6(RCRTOT),UPDADJ^RCDPESR6(RCRTOT),UPD3444^RCDPESR6(.RCRTOT) ; Bills added 344.41
|
||||
I RCRTOT,RCTDA S DIE="^RCY(344.5,",DR=".08////0;.1///@",DA=RCTDA D ^DIE
|
||||
I 'RCRTOT D G QNEW
|
||||
.I RCDUPERR Q:'RCTDA D S RCTDA="" Q
|
||||
..I RCDUPERR=-2 D BULLERA^RCDPESR0("D",RCTDA,$P($G(^RCY(344.5,RCTDA,0)),U,11),"EDI LBOX - DUPLICATE ERA NOT FILED "_$E(RCPAYER,1,20),.RCERR,0)
|
||||
..D TEMPDEL^RCDPESR1(RCTDA)
|
||||
.S RCE(1)=$$FMTE^XLFDT($$NOW^XLFDT(),2)_" An error occurred while storing ERA data.",RCE(2)="No totals data was stored for this ERA record"_$S('$G(RCREFILE):" and an",1:" on this re-file attempt.")
|
||||
.S RCE(3)=$S('$G(RCREFILE):"ERA transmission exception was created.",1:"")
|
||||
.D WP^DIE(344.5,RCTDA_",",5,"A","RCE")
|
||||
.S DIE="^RCY(344.5,",DA=RCTDA,DR=".07///@;.08////1;.1////1" D ^DIE
|
||||
.K RCERR
|
||||
.S RCERR(1)=$$FMTE^XLFDT($$NOW^XLFDT(),2)_" The ERA data could not be stored. The AR receipt",RCERR(2)=" for this data must be created/processed manually for the bills included"
|
||||
.S RCERR(3)=" in this ERA."_$S('$G(RCREFILE):"",1:" This error occurred during a refile attempt."),RCERR(4)=" "
|
||||
.D BULLERA^RCDPESR0("DF",RCTDA,$P($G(^RCY(344.5,RCTDA,0)),U,11),"EDI LBOX - TOTALS FILE EXCEPTION "_$E(RCPAYER,1,20),.RCERR,0)
|
||||
.K RCERR
|
||||
I $$ADJ^RCDPEU(RCRTOT,.RCADJ) D ;Bulletin adjs
|
||||
.S RCEC=$$ADJERR^RCDPESR3(.RCERR)
|
||||
.I RCADJ'=2 S RCEC=RCEC+1,RCERR(RCEC)=" THERE ARE ERA LEVEL ADJUSTMENT(S)",RCEC=RCEC+1,RCERR(RCEC)=" "
|
||||
.I RCADJ'=1 S RCEC=RCEC+1,RCERR(RCEC)=" THE FOLLOWING BILL(S) HAVE RETRACTIONS:" D
|
||||
..S (Q,Z)=0 S Z=0 F S Z=$O(RCADJ(RCRTOT,Z)) Q:'Z S:'Q RCEC=RCEC+1,RCERR(RCEC)=" " S Q=Q+1,RCERR(RCEC)=RCERR(RCEC)_" "_RCADJ(RCRTOT,Z) S:Q=4 Q=0
|
||||
..S RCEC=RCEC+1,RCERR(RCEC)=" "
|
||||
.D BULLERA^RCDPESR0("D",RCTDA,$P($G(^RCY(344.5,RCTDA,0)),U,11),"EDI LBOX - ERA HAS ADJ/TAKEBACKS "_$E(RCPAYER,1,20),.RCERR,0)
|
||||
;
|
||||
QNEW I RCTDA,'$P($G(^RCY(344.5,RCTDA,0)),U,8) D TEMPDEL^RCDPESR1(RCTDA) S RCTDA=""
|
||||
I RCTDA,$P($G(^RCY(344.5,RCTDA,0)),U)'="" S DIE="^RCY(344.5,",DR=".04////0;.05///@"_$S('$G(RCR1)&$G(RCRTOT):";.07////"_RCRTOT,1:""),DA=RCTDA D ^DIE
|
||||
K ^TMP($J,"RCDPERA")
|
||||
I RCTDA L -^RCY(344.5,RCTDA)
|
||||
Q
|
||||
;
|
||||
UPDEOB(RCTDA,RCFILE,DUP) ;Upd 361.1 from ERA msg in 344.5 or .4
|
||||
;RCTDA = ien ERA msg in 344.5 or ;subfile in 344.4
|
||||
;RCFILE = 4 file 344.4, 5 if 344.5
|
||||
;DUP = msg # if dup msg, but not same # or -1 if same msg #
|
||||
;Returned for each bill in ERA:
|
||||
;^TMP($J,"RCDPEOB",n)=Bill ien^AR bill#^SrvDt
|
||||
;^TMP($J,"RCDPEOB",n,"EOB")=EOB ien^amt pd^ins co ptr^rev flg^EEOB pn^amtbld^^^^BPNPI^RNPI^ETQual^LN^FN
|
||||
;^TMP($J,"RCDPEOB","ADJ",x)=adj rec ('02')
|
||||
;Also:
|
||||
;^TMP($J,"RCDPEOB","HDR")=hdr rec from txmn
|
||||
;^TMP($J,"RCDPEOB","CONTACT")=ERA contact rec ('01')
|
||||
;
|
||||
N RCGBL,RC,RC0,RCCT,RCCT1,RCEOB,RCBILL,RCDPBNPI,RCMNUM,RCIFN,RCIB,RCERR,RCSTAR,RCET,RCX,RCXMG,Z,Q,DA,DR,DIE,RCPAYER,RCFILED,RCEOBD,RCNOUPD,REFORM,RCSD,RCERR1,C5
|
||||
K ^TMP($J,"RCDP-EOB"),^TMP("RCDPERR-EOB",$J)
|
||||
;
|
||||
S RCPAYER="",RCFILED=1,RCNOUPD=0
|
||||
I RCFILE=5 D
|
||||
.S RCGBL=$NA(^RCY(344.5,RCTDA,2))
|
||||
.S RCMNUM=+$G(^RCY(344.5,RCTDA,0)),RCXMG=$P($G(^(0)),U,11)
|
||||
.I $G(DUP) S RCNOUPD=$S(DUP>0:+DUP,1:RCXMG)
|
||||
.S ^TMP($J,"RCDPEOB","HDR")=$G(^RCY(344.5,RCTDA,2,1,0))
|
||||
.I $P(^TMP($J,"RCDPEOB","HDR"),U)["XFR",'$P($G(^RCY(344.5,RCTDA,0)),U,14) D
|
||||
..D SENDACK^RCDPESR5(RCTDA,1)
|
||||
..S DR=".14////1",DIE="^RCY(344.5,",DA=RCTDA D ^DIE
|
||||
;
|
||||
I RCFILE=4 D
|
||||
.S RCGBL=$NA(^RCY(344.4,+RCTDA,1,+$P(RCTDA,";",2),1))
|
||||
.S RCMNUM=$P($G(^RCY(344.4,+RCTDA,0)),U,12),RCXMG=$P($G(^(0)),U,12)
|
||||
.S ^TMP($J,"RCDPEOB","HDR")=$G(^RCY(344.4,+RCTDA,1,+$P(RCTDA,";",2),1,1,0))
|
||||
;
|
||||
S RCPAYER=$P($G(^TMP($J,"RCDPEOB","HDR")),U,6)
|
||||
S RCDPBNPI=$P($G(^TMP($J,"RCDPEOB","HDR")),U,18)
|
||||
;
|
||||
;srv dates
|
||||
S RCSD=$NA(^TMP($J,"RCSRVDT")) K @RCSD
|
||||
S RC=1,C5=0
|
||||
F S RC=$O(@RCGBL@(RC)) Q:'RC S RC0=$G(^(RC,0)) D
|
||||
.I RC0<5 Q
|
||||
.I +RC0=5 S C5=RC Q
|
||||
.I +RC0=40,$P(RC0,U,2)?1.7N,C5,'$D(@RCSD@(C5)) S @RCSD@(C5)=$P(RC0,U,19) ;serv date
|
||||
;
|
||||
S RC=1,(RCCT,RCCT1,RCX,REFORM)=0,RCBILL=""
|
||||
S RCERR1=$NA(^TMP("RCERR1",$J)) K @RCERR1
|
||||
F S RC=$O(@RCGBL@(RC)) Q:'RC S RC0=$G(^(RC,0)) D
|
||||
.I RCFILE=5,+RC0=1 D Q
|
||||
..S ^TMP($J,"RCDPEOB","CONTACT")=RC0
|
||||
.;
|
||||
.I RCFILE=5,+RC0=2 D Q
|
||||
..S RCX=RCX+1,^TMP($J,"RCDPEOB","ADJ",RCX)=RC0
|
||||
.;
|
||||
.I +RC0=5 S RCCT=RCCT+1,RCCT1=0 D
|
||||
..S REFORM=0
|
||||
..S Z=$$BILL^RCDPESR1($P(RC0,U,2),$G(@RCSD@(RC)),.RCIB)
|
||||
..I Z S RCBILL=$P($G(^PRCA(430,Z,0)),U) I RCBILL'="",RCBILL'=$P(RC0,U,2) S REFORM=1,$P(RC0,U,2)=RCBILL
|
||||
..S RCBILL=$P(RC0,U,2)
|
||||
..S Z=$S(Z>0:$S($G(RCIB):Z,1:-1),1:-1)
|
||||
..S ^TMP($J,"RCDP-EOB",RCCT,0)=Z_U_RCBILL_U_$G(@RCSD@(RC))
|
||||
..S $P(^TMP($J,"RCDPEOB",RCCT,"EOB"),U,5)=$P(RC0,U,3)_","_$P(RC0,U,4)_" "_$P(RC0,U,5) ;Save pt nm
|
||||
..I Z>0 S Q=+$P($G(^PRCA(430,Z,0)),U,9) I $P($G(^RCD(340,Q,0)),U)["DIC(36," S $P(^TMP($J,"RCDPEOB",RCCT,"EOB"),U,3)=+^RCD(340,Q,0) ;Save ins co
|
||||
.;
|
||||
.I +RC0>5,REFORM S $P(RC0,U,2)=RCBILL ;
|
||||
.I +RC0=10 D ;Save amt pd/billed, rev flg
|
||||
..S $P(^TMP($J,"RCDPEOB",RCCT,"EOB"),U,2)=$S(+$P(RC0,U,11):$J($P(RC0,U,11)/100,"",2),1:0),$P(^TMP($J,"RCDPEOB",RCCT,"EOB"),U,6)=$J($P(RC0,U,11),"",2)
|
||||
..I $P(RC0,U,6)="Y"!($P(RC0,U,7)=22) S $P(^TMP($J,"RCDPEOB",RCCT,"EOB"),U,4)=1
|
||||
..S $P(^TMP($J,"RCDPEOB",RCCT,"EOB"),U,10,14)=RCDPBNPI_U_$P(RC0,U,16,19)
|
||||
.I RCBILL=$P(RC0,U,2) S RCCT1=RCCT1+1,^TMP($J,"RCDP-EOB",RCCT,RCCT1,0)=RC0
|
||||
;
|
||||
S RCSTAR=$TR($J("",15)," ","*"),RCET=RCSTAR_"ERROR/WARNING EEOB DETAIL SEQ #"
|
||||
S RCCT=0 F S RCCT=$O(^TMP($J,"RCDP-EOB",RCCT)) Q:'RCCT S RCIFN=+$G(^(RCCT,0)),RCBILL=$P($G(^(0)),U,2),^TMP($J,"RCDPEOB",RCCT)=$G(^TMP($J,"RCDP-EOB",RCCT,0)) D
|
||||
.S RCEOB=-1,RCEOBD=""
|
||||
.I $S(RCIFN>0:$P(^PRCA(430.3,+$P($G(^PRCA(430,+RCIFN,0)),U,8),0),U,3)'=102,RCIFN'>0&($G(DUP)'>0):1,1:0) D
|
||||
..S @RCERR1@(RCCT)=" ",@RCERR1@(RCCT,1)=RCET_RCCT_RCSTAR
|
||||
..S @RCERR1@(RCCT,2)="Bill "_RCBILL_" is"_$S(RCIFN>0:" not in an ACTIVE status in your A/R",1:"n't valid/wasn't found so its detail wasn't stored in IB")
|
||||
..S:RCFILE=5 @RCERR1@(RCCT,"*")=@RCERR1@(RCCT,2)
|
||||
..S @RCERR1@(RCCT,3)=" The reported amount paid on this bill was: "_$P(^TMP($J,"RCDPEOB",RCCT,"EOB"),U,2)
|
||||
..I RCIFN'>0 D
|
||||
...S @RCERR1@(RCCT,4)=" If the bill is not for your site, it must be transferred to the"
|
||||
...S @RCERR1@(RCCT,5)=" correct site and manually adjusted in your AR."
|
||||
...S @RCERR1@(RCCT,6)=" You can perform this transfer using EDI Lockbox ERA/EEOB exception process."
|
||||
...S @RCERR1@(RCCT,7)=" "
|
||||
..D DISP1^RCDPESR5(RCCT,1)
|
||||
..S Q=0 F S Q=$O(^TMP($J,"RCDP-EOB",RCCT,Q)) Q:'Q S ^TMP($J,"RCDPEOB",RCCT,Q)=$G(^TMP($J,"RCDP-EOB",RCCT,Q,0))
|
||||
..S ^TMP($J,"RCDPEOB",RCCT)=^TMP($J,"RCDP-EOB",RCCT,0) M ^TMP($J,"RCDPEOB",RCCT,"ERR")=@RCERR1@(RCCT)
|
||||
..I RCFILE=5 D ;Store err if trans-in failed
|
||||
...N RCE,RC,DIE,X,Y,DA,DR
|
||||
...S RCE(1)=$$FMTE^XLFDT($$NOW^XLFDT(),2)_" "_$G(@RCERR1@(RCCT,"*"))
|
||||
...S RCE(2)=" ",RCFILED=0
|
||||
...D WP^DIE(344.5,RCTDA_",",5,"A","RCE")
|
||||
.I RCIFN>0 D
|
||||
..N RCDUPEOB,RCALLDUP
|
||||
..;Chk rec exists
|
||||
..S RCDUPEOB=0
|
||||
..S RCEOB=$$DUP^RCDPESR3(RCMNUM,RCIFN,$P($G(^TMP($J,"RCDPEOB",RCCT,"EOB")),U,2),$P($G(^TMP($J,"RCDPEOB",RCCT,"EOB")),U,6)) ;Same msg for update?
|
||||
..I RCEOB,$P(RCEOB,U,2) S RCEOB=0 ;If chksum exists, let below check it
|
||||
..S ^TMP($J,"RCDP-EOB",RCCT,.5,0)="835ERA" ;Needed - checksum
|
||||
..S RCALLDUP=$$DUP^IBCEOB("^TMP("_$J_",""RCDP-EOB"","_RCCT_")",RCIFN)
|
||||
..I $S(RCALLDUP:1,RCEOB:$G(DUP)'>0,1:0) D
|
||||
...S RCDUPEOB=1
|
||||
...D DUPREC^RCDPESR6(RCET,RCCT,RCSTAR,RCFILE,RCALLDUP,RCEOB,RCBILL,.RCDUPEOB)
|
||||
...S:RCALLDUP RCEOBD=RCALLDUP
|
||||
..;Add stub to 361.1
|
||||
..I 'RCDUPEOB S RCEOB=+$$ADD3611^IBCEOB(RCMNUM,"","",RCIFN,1,"^TMP("_$J_",""RCDP-EOB"","_RCCT_")") ;IA 4042
|
||||
..K ^TMP($J,"RCDP-EOB",RCCT,.5,0)
|
||||
..I RCEOB<0 D:$G(DUP)'>0 Q
|
||||
...S @RCERR1@(RCCT)=" ",^(RCCT,1)=RCET_RCCT_RCSTAR,RCFILED=0
|
||||
...S @RCERR1@(RCCT,2)="Error - EEOB detail not added to IB for bill "_RCBILL,$P(^TMP($J,"RCDPEOB",RCCT,"EOB"),U)=""
|
||||
...S:RCFILE=5 @RCERR1@(RCCT,"*")=@RCERR1@(RCCT,2)
|
||||
...D DISP1^RCDPESR5(RCCT,1)
|
||||
...S Q=0 F S Q=$O(^TMP($J,"RCDP-EOB",RCCT,Q)) Q:'Q S ^TMP($J,"RCDPEOB",RCCT,Q)=$G(^TMP($J,"RCDP-EOB",RCCT,Q,0))
|
||||
...S ^TMP($J,"RCDPEOB",RCCT)=^TMP($J,"RCDP-EOB",RCCT,0) M ^TMP($J,"RCDPEOB",RCCT,"ERR")=@RCERR1@(RCCT)
|
||||
..;Upd 361.1, needs ^TMP($J,"RCDPEOB","HDR" and $J,"RCDP-EOB"
|
||||
..I RCDUPEOB'<0 S RCNOUPD=0 D UPD3611^IBCEOB(RCEOB,RCCT,1)
|
||||
..;errors in ^TMP("RCDPERR-EOB",$J
|
||||
..I $O(^TMP("RCDPERR-EOB",$J,0)) D ERRUPD^IBCEOB(RCEOB,"RCDPERR-EOB")
|
||||
..S $P(^TMP($J,"RCDPEOB",RCCT,"EOB"),U)=$S('$G(RCEOBD):RCEOB,1:RCEOBD)
|
||||
.K ^TMP("RCDPERR-EOB",$J)
|
||||
;
|
||||
I RCNOUPD D DUPERA^RCDPESR3($G(DUP),RCNOUPD)
|
||||
I $O(@RCERR1@("")) D BULLS^RCDPESR3(RCFILE,RCTDA,$S(RCNOUPD:RCNOUPD,1:$G(DUP)),$G(RCXMG))
|
||||
K ^TMP("RCDPERR-EOB",$J),^TMP($J,"RCDP-EOB"),@RCERR1,@RCSD
|
||||
D CLEAN^DILF
|
||||
Q
|
||||
RCDPESR2 ;ALB/TMK - Server auto-upd - EDI Lockbox ;06/03/02
|
||||
;;4.5;Accounts Receivable;**173,216,208,230**;Mar 20, 1995
|
||||
;;Per VHA Directive 10-93-142, this routine should not be modified.
|
||||
; IA 4042 (IBCEOB)
|
||||
;
|
||||
TASKERA(RCTDA) ; Task to upd ERA
|
||||
; RCTDA = ien 344.5
|
||||
N ZTDTH,ZTUCI,ZTSAVE,ZTIO,ZTDESC,ZTRTN,ZTSK,DIE,DR,DA
|
||||
S (ZTSAVE("DT"),ZTSAVE("U"),ZTSAVE("DUZ"))="",ZTSAVE("ZTREQ")="@",ZTRTN="NEWERA^RCDPESR2("_RCTDA_",0)",ZTDTH=$H,ZTIO=""
|
||||
D ^%ZTLOAD
|
||||
Q
|
||||
;
|
||||
NEWERA(RCTDA,RCREFILE) ;Tasked
|
||||
; Add new EOB's to IB & ERA tot rec to AR
|
||||
; RCTDA = ien 344.5
|
||||
; RCREFILE = 1: re-filing rec via exc proc
|
||||
N RCDUPERR,RCPAYER,RCRTOT,RCE,RCEC,RCERR,RCR1,RCADJ,DIE,DR,DA,Z,Q
|
||||
S ZTREQ="@"
|
||||
K ^TMP($J,"RCDPERA")
|
||||
L +^RCY(344.5,RCTDA):5
|
||||
I $D(ZTQUEUED) S DIE="^RCY(344.5,",DA=RCTDA,DR=".05////"_ZTSK_";.04////1" D ^DIE
|
||||
I $P($G(^RCY(344.5,RCTDA,0)),U,5),'$G(RCREFILE) S DIE="^RCY(344.5,",DA=RCTDA,DR=".1////4;.08///1" D ^DIE
|
||||
S RCR1=$P($G(^RCY(344.5,RCTDA,0)),U,7),RCPAYER=$P($G(^RCY(344.5,RCTDA,3)),U)
|
||||
S RCRTOT=$S(RCR1:RCR1,1:$$ERATOT^RCDPESR6(RCTDA,.RCERR)) ; ERA rec
|
||||
S RCDUPERR=$S($G(RCERR)="DUP"!($G(RCERR(1))=-2):$G(RCERR(1)),1:0) K RCERR(1)
|
||||
I RCRTOT,'RCR1 S DIE="^RCY(344.5,",DR=".07////"_RCRTOT,DA=RCTDA D ^DIE
|
||||
D:RCDUPERR'=-2 UPDEOB(RCTDA,5,$S('$G(RCREFILE):RCDUPERR,1:-1)) ; Add EOB det to IB
|
||||
I RCRTOT D UPDCON^RCDPESR6(RCRTOT),UPDADJ^RCDPESR6(RCRTOT),UPD3444^RCDPESR6(.RCRTOT) ; Bills added 344.41
|
||||
I RCRTOT,RCTDA S DIE="^RCY(344.5,",DR=".08////0;.1///@",DA=RCTDA D ^DIE
|
||||
I 'RCRTOT D G QNEW
|
||||
.I RCDUPERR Q:'RCTDA D S RCTDA="" Q
|
||||
..I RCDUPERR=-2 D BULLERA^RCDPESR0("D",RCTDA,$P($G(^RCY(344.5,RCTDA,0)),U,11),"EDI LBOX - DUPLICATE ERA NOT FILED "_$E(RCPAYER,1,20),.RCERR,0)
|
||||
..D TEMPDEL^RCDPESR1(RCTDA)
|
||||
.S RCE(1)=$$FMTE^XLFDT($$NOW^XLFDT(),2)_" An error occurred while storing ERA data.",RCE(2)="No totals data was stored for this ERA record"_$S('$G(RCREFILE):" and an",1:" on this re-file attempt.")
|
||||
.S RCE(3)=$S('$G(RCREFILE):"ERA transmission exception was created.",1:"")
|
||||
.D WP^DIE(344.5,RCTDA_",",5,"A","RCE")
|
||||
.S DIE="^RCY(344.5,",DA=RCTDA,DR=".07///@;.08////1;.1////1" D ^DIE
|
||||
.K RCERR
|
||||
.S RCERR(1)=$$FMTE^XLFDT($$NOW^XLFDT(),2)_" The ERA data could not be stored. The AR receipt",RCERR(2)=" for this data must be created/processed manually for the bills included"
|
||||
.S RCERR(3)=" in this ERA."_$S('$G(RCREFILE):"",1:" This error occurred during a refile attempt."),RCERR(4)=" "
|
||||
.D BULLERA^RCDPESR0("DF",RCTDA,$P($G(^RCY(344.5,RCTDA,0)),U,11),"EDI LBOX - TOTALS FILE EXCEPTION "_$E(RCPAYER,1,20),.RCERR,0)
|
||||
.K RCERR
|
||||
I $$ADJ^RCDPEU(RCRTOT,.RCADJ) D ;Bulletin adjs
|
||||
.S RCEC=$$ADJERR^RCDPESR3(.RCERR)
|
||||
.I RCADJ'=2 S RCEC=RCEC+1,RCERR(RCEC)=" THERE ARE ERA LEVEL ADJUSTMENT(S)",RCEC=RCEC+1,RCERR(RCEC)=" "
|
||||
.I RCADJ'=1 S RCEC=RCEC+1,RCERR(RCEC)=" THE FOLLOWING BILL(S) HAVE RETRACTIONS:" D
|
||||
..S (Q,Z)=0 S Z=0 F S Z=$O(RCADJ(RCRTOT,Z)) Q:'Z S:'Q RCEC=RCEC+1,RCERR(RCEC)=" " S Q=Q+1,RCERR(RCEC)=RCERR(RCEC)_" "_RCADJ(RCRTOT,Z) S:Q=4 Q=0
|
||||
..S RCEC=RCEC+1,RCERR(RCEC)=" "
|
||||
.D BULLERA^RCDPESR0("D",RCTDA,$P($G(^RCY(344.5,RCTDA,0)),U,11),"EDI LBOX - ERA HAS ADJ/TAKEBACKS "_$E(RCPAYER,1,20),.RCERR,0)
|
||||
;
|
||||
QNEW I RCTDA,'$P($G(^RCY(344.5,RCTDA,0)),U,8) D TEMPDEL^RCDPESR1(RCTDA) S RCTDA=""
|
||||
I RCTDA,$P($G(^RCY(344.5,RCTDA,0)),U)'="" S DIE="^RCY(344.5,",DR=".04////0;.05///@"_$S('$G(RCR1)&$G(RCRTOT):";.07////"_RCRTOT,1:""),DA=RCTDA D ^DIE
|
||||
K ^TMP($J,"RCDPERA")
|
||||
I RCTDA L -^RCY(344.5,RCTDA)
|
||||
Q
|
||||
;
|
||||
UPDEOB(RCTDA,RCFILE,DUP) ;Upd 361.1 from ERA msg in 344.5 or .4
|
||||
; RCTDA = ien ERA msg in 344.5 or ;subfile in 344.4
|
||||
; RCFILE = 4 file 344.4, 5 if 344.5
|
||||
; DUP = msg # if dup msg, but not same # or -1 if same msg #
|
||||
;Returned for each bill in ERA:
|
||||
; ^TMP($J,"RCDPEOB",n)=Bill ien^AR bill#^Service Date
|
||||
; ^TMP($J,"RCDPEOB",n,"EOB")=EOB ien^amt pd^ins co ptr^reversal flag^pt name on EEOB^amt billed
|
||||
; ^TMP($J,"RCDPEOB","ADJ",x)=adj rec ('02')
|
||||
;Also:
|
||||
; ^TMP($J,"RCDPEOB","HDR")=hdr rec from txmn
|
||||
; ^TMP($J,"RCDPEOB","CONTACT")=ERA contact rec ('01')
|
||||
;
|
||||
N RCGBL,RC,RC0,RCCT,RCCT1,RCEOB,RCBILL,RCMNUM,RCIFN,RCIB,RCERR,RCSTAR,RCET,RCX,RCXMG,Z,Q,DA,DR,DIE,RCPAYER,RCFILED,RCEOBD,RCNOUPD,REFORM,RCSD,RCERR1,C5
|
||||
K ^TMP($J,"RCDP-EOB"),^TMP("RCDPERR-EOB",$J)
|
||||
;
|
||||
S RCPAYER="",RCFILED=1,RCNOUPD=0
|
||||
I RCFILE=5 D
|
||||
.S RCGBL=$NA(^RCY(344.5,RCTDA,2))
|
||||
.S RCMNUM=+$G(^RCY(344.5,RCTDA,0)),RCXMG=$P($G(^(0)),U,11)
|
||||
.I $G(DUP) S RCNOUPD=$S(DUP>0:+DUP,1:RCXMG)
|
||||
.S ^TMP($J,"RCDPEOB","HDR")=$G(^RCY(344.5,RCTDA,2,1,0))
|
||||
.I $P(^TMP($J,"RCDPEOB","HDR"),U)["XFR",'$P($G(^RCY(344.5,RCTDA,0)),U,14) D
|
||||
..D SENDACK^RCDPESR5(RCTDA,1)
|
||||
..S DR=".14////1",DIE="^RCY(344.5,",DA=RCTDA D ^DIE
|
||||
;
|
||||
I RCFILE=4 D
|
||||
.S RCGBL=$NA(^RCY(344.4,+RCTDA,1,+$P(RCTDA,";",2),1))
|
||||
.S RCMNUM=$P($G(^RCY(344.4,+RCTDA,0)),U,12),RCXMG=$P($G(^(0)),U,12)
|
||||
.S ^TMP($J,"RCDPEOB","HDR")=$G(^RCY(344.4,+RCTDA,1,+$P(RCTDA,";",2),1,1,0))
|
||||
;
|
||||
S RCPAYER=$P($G(^TMP($J,"RCDPEOB","HDR")),U,6)
|
||||
;
|
||||
;srv dates
|
||||
S RCSD=$NA(^TMP($J,"RCSRVDT")) K @RCSD
|
||||
S RC=1,C5=0
|
||||
F S RC=$O(@RCGBL@(RC)) Q:'RC S RC0=$G(^(RC,0)) D
|
||||
.I RC0<5 Q
|
||||
.I +RC0=5 S C5=RC Q
|
||||
.I +RC0=40,$P(RC0,U,2)?1.7N,C5,'$D(@RCSD@(C5)) S @RCSD@(C5)=$P(RC0,U,19) ;serv date
|
||||
;
|
||||
S RC=1,(RCCT,RCCT1,RCX,REFORM)=0,RCBILL=""
|
||||
S RCERR1=$NA(^TMP("RCERR1",$J)) K @RCERR1
|
||||
F S RC=$O(@RCGBL@(RC)) Q:'RC S RC0=$G(^(RC,0)) D
|
||||
.I RCFILE=5,+RC0=1 D Q
|
||||
..S ^TMP($J,"RCDPEOB","CONTACT")=RC0
|
||||
.;
|
||||
.I RCFILE=5,+RC0=2 D Q
|
||||
..S RCX=RCX+1,^TMP($J,"RCDPEOB","ADJ",RCX)=RC0
|
||||
.;
|
||||
.I +RC0=5 S RCCT=RCCT+1,RCCT1=0 D
|
||||
..S REFORM=0
|
||||
..S Z=$$BILL^RCDPESR1($P(RC0,U,2),$G(@RCSD@(RC)),.RCIB)
|
||||
..I Z S RCBILL=$P($G(^PRCA(430,Z,0)),U) I RCBILL'="",RCBILL'=$P(RC0,U,2) S REFORM=1,$P(RC0,U,2)=RCBILL
|
||||
..S RCBILL=$P(RC0,U,2)
|
||||
..S Z=$S(Z>0:$S($G(RCIB):Z,1:-1),1:-1)
|
||||
..S ^TMP($J,"RCDP-EOB",RCCT,0)=Z_U_RCBILL_U_$G(@RCSD@(RC))
|
||||
..S $P(^TMP($J,"RCDPEOB",RCCT,"EOB"),U,5)=$P(RC0,U,3)_","_$P(RC0,U,4)_" "_$P(RC0,U,5) ;Save pt nm
|
||||
..I Z>0 S Q=+$P($G(^PRCA(430,Z,0)),U,9) I $P($G(^RCD(340,Q,0)),U)["DIC(36," S $P(^TMP($J,"RCDPEOB",RCCT,"EOB"),U,3)=+^RCD(340,Q,0) ;Save ins co
|
||||
.;
|
||||
.I +RC0>5,REFORM S $P(RC0,U,2)=RCBILL ;
|
||||
.I +RC0=10 D ;Save amt pd/billed, rev flg
|
||||
..S $P(^TMP($J,"RCDPEOB",RCCT,"EOB"),U,2)=$S(+$P(RC0,U,11):$J($P(RC0,U,11)/100,"",2),1:0),$P(^TMP($J,"RCDPEOB",RCCT,"EOB"),U,6)=$J($P(RC0,U,11),"",2)
|
||||
..I $P(RC0,U,6)="Y"!($P(RC0,U,7)=22) S $P(^TMP($J,"RCDPEOB",RCCT,"EOB"),U,4)=1
|
||||
.I RCBILL=$P(RC0,U,2) S RCCT1=RCCT1+1,^TMP($J,"RCDP-EOB",RCCT,RCCT1,0)=RC0
|
||||
;
|
||||
S RCSTAR=$TR($J("",15)," ","*"),RCET=RCSTAR_"ERROR/WARNING EEOB DETAIL SEQ #"
|
||||
S RCCT=0 F S RCCT=$O(^TMP($J,"RCDP-EOB",RCCT)) Q:'RCCT S RCIFN=+$G(^(RCCT,0)),RCBILL=$P($G(^(0)),U,2),^TMP($J,"RCDPEOB",RCCT)=$G(^TMP($J,"RCDP-EOB",RCCT,0)) D
|
||||
.S RCEOB=-1,RCEOBD=""
|
||||
.I $S(RCIFN>0:$P(^PRCA(430.3,+$P($G(^PRCA(430,+RCIFN,0)),U,8),0),U,3)'=102,RCIFN'>0&($G(DUP)'>0):1,1:0) D
|
||||
..S @RCERR1@(RCCT)=" ",@RCERR1@(RCCT,1)=RCET_RCCT_RCSTAR
|
||||
..S @RCERR1@(RCCT,2)="Bill "_RCBILL_" is"_$S(RCIFN>0:" not in an ACTIVE status in your A/R",1:"n't valid/wasn't found so its detail wasn't stored in IB")
|
||||
..S:RCFILE=5 @RCERR1@(RCCT,"*")=@RCERR1@(RCCT,2)
|
||||
..S @RCERR1@(RCCT,3)=" The reported amount paid on this bill was: "_$P(^TMP($J,"RCDPEOB",RCCT,"EOB"),U,2)
|
||||
..I RCIFN'>0 D
|
||||
...S @RCERR1@(RCCT,4)=" If the bill is not for your site, it must be transferred to the"
|
||||
...S @RCERR1@(RCCT,5)=" correct site and manually adjusted in your AR."
|
||||
...S @RCERR1@(RCCT,6)=" You can perform this transfer using EDI Lockbox ERA/EEOB exception process."
|
||||
...S @RCERR1@(RCCT,7)=" "
|
||||
..D DISP1^RCDPESR5(RCCT,1)
|
||||
..S Q=0 F S Q=$O(^TMP($J,"RCDP-EOB",RCCT,Q)) Q:'Q S ^TMP($J,"RCDPEOB",RCCT,Q)=$G(^TMP($J,"RCDP-EOB",RCCT,Q,0))
|
||||
..S ^TMP($J,"RCDPEOB",RCCT)=^TMP($J,"RCDP-EOB",RCCT,0) M ^TMP($J,"RCDPEOB",RCCT,"ERR")=@RCERR1@(RCCT)
|
||||
..I RCFILE=5 D ;Store err if trans-in failed
|
||||
...N RCE,RC,DIE,X,Y,DA,DR
|
||||
...S RCE(1)=$$FMTE^XLFDT($$NOW^XLFDT(),2)_" "_$G(@RCERR1@(RCCT,"*"))
|
||||
...S RCE(2)=" ",RCFILED=0
|
||||
...D WP^DIE(344.5,RCTDA_",",5,"A","RCE")
|
||||
.I RCIFN>0 D
|
||||
..N RCDUPEOB,RCALLDUP
|
||||
..;Chk rec exists
|
||||
..S RCDUPEOB=0
|
||||
..S RCEOB=$$DUP^RCDPESR3(RCMNUM,RCIFN,$P($G(^TMP($J,"RCDPEOB",RCCT,"EOB")),U,2),$P($G(^TMP($J,"RCDPEOB",RCCT,"EOB")),U,6)) ;Same msg for update?
|
||||
..I RCEOB,$P(RCEOB,U,2) S RCEOB=0 ;If chksum exists, let below check it
|
||||
..S ^TMP($J,"RCDP-EOB",RCCT,.5,0)="835ERA" ;Needed - checksum
|
||||
..S RCALLDUP=$$DUP^IBCEOB("^TMP("_$J_",""RCDP-EOB"","_RCCT_")",RCIFN)
|
||||
..I $S(RCALLDUP:1,RCEOB:$G(DUP)'>0,1:0) D
|
||||
...S RCDUPEOB=1
|
||||
...D DUPREC^RCDPESR6(RCET,RCCT,RCSTAR,RCFILE,RCALLDUP,RCEOB,RCBILL,.RCDUPEOB)
|
||||
...S:RCALLDUP RCEOBD=RCALLDUP
|
||||
..;Add stub to 361.1
|
||||
..I 'RCDUPEOB S RCEOB=+$$ADD3611^IBCEOB(RCMNUM,"","",RCIFN,1,"^TMP("_$J_",""RCDP-EOB"","_RCCT_")") ;IA 4042
|
||||
..K ^TMP($J,"RCDP-EOB",RCCT,.5,0)
|
||||
..I RCEOB<0 D:$G(DUP)'>0 Q
|
||||
...S @RCERR1@(RCCT)=" ",^(RCCT,1)=RCET_RCCT_RCSTAR,RCFILED=0
|
||||
...S @RCERR1@(RCCT,2)="Error - EEOB detail not added to IB for bill "_RCBILL,$P(^TMP($J,"RCDPEOB",RCCT,"EOB"),U)=""
|
||||
...S:RCFILE=5 @RCERR1@(RCCT,"*")=@RCERR1@(RCCT,2)
|
||||
...D DISP1^RCDPESR5(RCCT,1)
|
||||
...S Q=0 F S Q=$O(^TMP($J,"RCDP-EOB",RCCT,Q)) Q:'Q S ^TMP($J,"RCDPEOB",RCCT,Q)=$G(^TMP($J,"RCDP-EOB",RCCT,Q,0))
|
||||
...S ^TMP($J,"RCDPEOB",RCCT)=^TMP($J,"RCDP-EOB",RCCT,0) M ^TMP($J,"RCDPEOB",RCCT,"ERR")=@RCERR1@(RCCT)
|
||||
..;Upd 361.1, needs ^TMP($J,"RCDPEOB","HDR" and $J,"RCDP-EOB"
|
||||
..I RCDUPEOB'<0 S RCNOUPD=0 D UPD3611^IBCEOB(RCEOB,RCCT,1)
|
||||
..;errors in ^TMP("RCDPERR-EOB",$J
|
||||
..I $O(^TMP("RCDPERR-EOB",$J,0)) D ERRUPD^IBCEOB(RCEOB,"RCDPERR-EOB")
|
||||
..S $P(^TMP($J,"RCDPEOB",RCCT,"EOB"),U)=$S('$G(RCEOBD):RCEOB,1:RCEOBD)
|
||||
.K ^TMP("RCDPERR-EOB",$J)
|
||||
;
|
||||
I RCNOUPD D DUPERA^RCDPESR3($G(DUP),RCNOUPD)
|
||||
I $O(@RCERR1@("")) D BULLS^RCDPESR3(RCFILE,RCTDA,$S(RCNOUPD:RCNOUPD,1:$G(DUP)),$G(RCXMG))
|
||||
K ^TMP("RCDPERR-EOB",$J),^TMP($J,"RCDP-EOB"),@RCERR1,@RCSD
|
||||
D CLEAN^DILF
|
||||
Q
|
||||
|
|
|
|||
|
|
@ -1,182 +1,182 @@
|
|||
RCDPESR3 ;ALB/TMK - Server auto-update utilities - EDI Lockbox ;06/06/02
|
||||
;;4.5;Accounts Receivable;**173,214,208,255**;Mar 20, 1995;Build 1
|
||||
Q
|
||||
;
|
||||
EFTIN(RCTXN,RCD,XMZ,RCGBL,RCEFLG) ; Adds a new EFT record to AR file 344.3
|
||||
; from Lockbox EFT msg
|
||||
; RCTXN = the data on the header record of the message text
|
||||
; RCD = array containing formatted mail message header data
|
||||
; XMZ = the mail message number
|
||||
; RCGBL = the name of the array or global where the message is stored
|
||||
; RCEFLG = error flag returned if passed by reference
|
||||
;
|
||||
N CT,RC,RC1,RCLAST,RCEFT,RCTDA,RCERR,RCTYP1,DA,DIK,RCZ,Z,Z0,DLAYGO
|
||||
;
|
||||
; Take data out of mail message
|
||||
S (RCEFLG,RCLAST)=0,CT=0,RCTYP1="835EFT"
|
||||
F X XMREC Q:XMER<0 D Q:RCLAST
|
||||
. I +XMRG=99,$P(XMRG,U,2)="$" S RCLAST=1 Q
|
||||
. S:XMRG'="" CT=CT+1,@RCGBL@(2,"D",CT)=XMRG
|
||||
;
|
||||
I 'RCLAST,'$G(RCERR) K @RCGBL S RCERR=2 ;No $ as last character of msg
|
||||
;
|
||||
I $G(RCERR)>0 D G EFTQ
|
||||
. D ERRUPD^RCDPESR1(RCGBL,.RCD,RCTYP1,.RCERR)
|
||||
. S RCEFLG=1
|
||||
;
|
||||
; Add top-level entry to file 344.3
|
||||
S RCEFT=$$ADDEFT(RCTXN,XMZ,RCGBL,.RCERR)
|
||||
;
|
||||
I $G(RCERR) D G EFTQ ; 'BAD' EFT's
|
||||
. D ERRUPD^RCDPESR1(RCGBL,.RCD,RCTYP1,.RCERR)
|
||||
. S RCEFLG=1
|
||||
;
|
||||
G:'RCEFT EFTQ
|
||||
;
|
||||
; Add the detail data to file 344.31 for this EFT record
|
||||
S Z=0 F S Z=$O(^RCY(344.31,"B",RCEFT,Z)) Q:'Z S DA=Z,DIK="^RCY(344.31," D ^DIK ; Delete any detail data already there
|
||||
;
|
||||
S (RC,RC1,RCZ)=0
|
||||
F S RCZ=$O(@RCGBL@(2,"D",RCZ)) Q:'RCZ S Z0=$G(^(RCZ)) I Z0'="" D Q:$G(RCERR)
|
||||
. I $P(Z0,U)="01" D ; Each payer's data
|
||||
.. N DA,DIE,DR,X,Y,DO,DD,DIC
|
||||
.. S X=RCEFT
|
||||
.. S DIC("DR")=".11////0;.04////"_$P(Z0,U,2)_";.08////0"_$S($P(Z0,U,5)'="":";.02////"_$P(Z0,U,5),1:"")_$S($P(Z0,U,6)'="":";.03////"_$P(Z0,U,6),1:"")_";.07////"_$J(+$P(Z0,U,4)/100,"",2)_";.06////"_$S($P(Z0,U,8)'="":1,1:0)
|
||||
.. S DIC("DR")=DIC("DR")_";.12///"_$$FDT^RCDPESR9($P(Z0,U,3))_";.13////"_DT_$S($P(Z0,U,7)'="":";.05////"_$P(Z0,U,7),1:"")_$S($P(Z0,U,9)'="":";.15////"_$P(Z0,U,9),1:"")
|
||||
.. ;
|
||||
.. I $P(Z0,U,8)'="" D ; tax id error
|
||||
... D TAXERR^RCDPESR1("EFT",$P(Z0,U,5)_" Payer ID: "_$P(RCTXN,U,6),$P(RCTXN,U,7),$P(RCTXN,U,8)) ; Send bad tax id bulletin
|
||||
.. ;
|
||||
.. S DIC(0)="L",DIC="^RCY(344.31,",DLAYGO=344.31 D FILE^DICN K DIC,DLAYGO,DO,DD
|
||||
.. I Y'>0 D ; Error filing data
|
||||
... S DIK="^RCY(344.3,",DA=RCEFT D ^DIK
|
||||
... S Z=0 F S Z=$O(^RCY(344.31,"B",RCEFT,Z)) Q:'Z S DIK="^RCY(344.31,",DA=Z D ^DIK
|
||||
... S RCEFLG=1,RCERR=3
|
||||
... D ERRUPD^RCDPESR1(RCGBL,.RCD,RCTYP1,RCERR)
|
||||
;
|
||||
I '$G(RCEFLG) D
|
||||
. S DIE="^RCY(344.3,",DA=RCEFT,DR=".09////"_$$CHKSUM(RCEFT) D ^DIE
|
||||
;
|
||||
EFTQ ;
|
||||
D CLEAN^DILF
|
||||
Q
|
||||
;
|
||||
ADDEFT(RCTXN,RCXMZ,RCGBL,RCERR) ; File EFT TOTAL record in file 344.3
|
||||
; RCTXN = the data on the header record of the message text
|
||||
; RCXMZ = the mail message number
|
||||
; RCGBL = the name of the array or global where the message is stored
|
||||
; Function returns the ien of the total record found/added
|
||||
; and also returns RCERR if passed by reference
|
||||
;
|
||||
N RCTDA,RCRCPT,RCDUP,RCHAC,Z,Z0
|
||||
S (RCERR,RCTDA)=""
|
||||
;
|
||||
I $E($P(RCTXN,U,6),1,3)'="469",$E($P(RCTXN,U,6),1,3)'="569",$E($P(RCTXN,U,6),1,3)'="HAC" D G ADDQ ; Invalid EFT deposit number
|
||||
. N RCDXM,RCCT
|
||||
. S RCCT=0
|
||||
. S RCCT=RCCT+1,RCDXM(RCCT)="This EFT has an invalid deposit number for EDI Lockbox and has been rejected.",RCCT=RCCT+1,RCDXM(RCCT)=" "
|
||||
. S RCCT=RCCT+1,RCDXM(RCCT)=" ",RCCT=RCCT+1,RCDXM(RCCT)="Here are the contents of this message:"
|
||||
. D DISP("EDI LBOX INVALID EFT DEPOSIT #",RCCT,.RCDXM,RCXMZ)
|
||||
;
|
||||
; Make sure it's not already there or if so, it has no ptr to a deposit
|
||||
; or if a deposit exists, that the deposit does not yet have a receipt
|
||||
S RCDUP=0,RCHAC=$E($P(RCTXN,U,6),1,3)="HAC" ; This is a HAC deposit
|
||||
I $P(RCTXN,U,6)'="" D
|
||||
. S Z=0 ; Lookup deposit by deposit #
|
||||
. F S Z=$O(^RCY(344.3,"C",$P(RCTXN,U,6),Z)) Q:'Z S Z0=$G(^RCY(344.3,Z,0)) S:'$P(Z0,U,3) RCTDA=Z Q:RCTDA D Q
|
||||
.. ; Deposit found - find receipt
|
||||
.. I $O(^RCY(344,"AD",$P(Z0,U,3),0)) S RCDUP=Z Q
|
||||
.. S RCTDA=Z
|
||||
;
|
||||
I RCDUP D ; Send bulletin that duplicate EFT received
|
||||
. N RCDXM,RCCT
|
||||
. S RCCT=0
|
||||
. S RCCT=RCCT+1,RCDXM(RCCT)="This EFT appears to be a duplicate transaction and has been rejected.",RCCT=RCCT+1,RCDXM(RCCT)=" "
|
||||
. S RCCT=RCCT+1,RCDXM(RCCT)=" ",RCCT=RCCT+1,RCDXM(RCCT)="Here are the contents of this message:"
|
||||
. D DISP("EDI LBOX DUP EFT DEPOSIT RECEIVED",RCCT,.RCDXM,RCXMZ)
|
||||
;
|
||||
I 'RCDUP D ; Add or update the record
|
||||
. N RCX,RCDTTM,DIE,DIC,DLAYGO,DD,DA,DO,DR,X,Y,%DT,DINUM
|
||||
. ;
|
||||
. S X=$$FDT^RCDPESR9($P(RCTXN,U,3))_"@"_$P(RCTXN,U,4)
|
||||
. S %DT="XTS" D ^%DT S:Y>0 RCDTTM=Y
|
||||
. ;
|
||||
. S DIC("DR")=""
|
||||
. S DIC("DR")=$S(RCDTTM'="":".02////"_RCDTTM,1:"")
|
||||
. S DIC("DR")=DIC("DR")_$S(DIC("DR")'="":";",1:"")_".06////"_$P(RCTXN,U,6)_";.07///"_$$FDT^RCDPESR9($P(RCTXN,U,7))
|
||||
. S DIC("DR")=DIC("DR")_";.08////"_$$ZERO^RCDPESR9($P(RCTXN,U,8),1)_";.13////"_$$NOW^XLFDT()_";.05////"_RCXMZ_";.14////0;.12////0"
|
||||
. ;
|
||||
. I RCTDA D ; Overwrite the data already there
|
||||
.. L +^RCY(344.3,RCTDA):1 I '$T S RCTDA=-1 Q
|
||||
.. S DIE="^RCY(344.3,",DA=RCTDA,DR=DIC("DR") K DIC D ^DIE
|
||||
.. L -^RCY(344.3,RCTDA)
|
||||
. ;
|
||||
. I 'RCTDA D
|
||||
.. S RCX=+$O(^RCY(344.3," "),-1)
|
||||
.. F RCX=RCX+1:1 I '$D(^RCY(344.3,RCX,0)) L +^RCY(344.3,RCX,0):1 I $T S X=RCX Q
|
||||
.. S DIC(0)="L",DIC="^RCY(344.3,",DLAYGO=344.3,DINUM=RCX
|
||||
.. D FILE^DICN K DO,DD,DLAYGO,DIC,DINUM
|
||||
.. L -^RCY(344.3,RCX,0)
|
||||
.. S RCTDA=$S(Y<0:"",1:+Y)
|
||||
. ;
|
||||
. I 'RCTDA S RCERR=3 ; Error in add of EFT record to file 344.3
|
||||
;
|
||||
ADDQ Q $S(RCTDA>0:RCTDA,1:"")
|
||||
;
|
||||
CHKSUM(RCTDA) ; Calc the checksum for EFT record stored in RCTDA in 344.3
|
||||
;
|
||||
N RCDPCSUM,RCDPDATA,X,Y,Z,Z0
|
||||
;
|
||||
S (RCDPCSUM,X)=0,Z0=$G(^RCY(344.3,RCTDA,0))
|
||||
; Use pcs 1-8, leaving out piece 3
|
||||
S RCDPDATA=$P(Z0,U,1,8),$P(RCDPDATA,U,3)=""
|
||||
S X=RCDPCSUM_RCDPDATA X $S($G(^%ZOSF("LPC"))'="":^("LPC"),1:"S Y=""""") S RCDPCSUM=Y
|
||||
; Use detail iens and pieces 3,4,7 to complete the checksum
|
||||
S Z=0 F S Z=$O(^RCY(344.31,"B",RCTDA,Z)) Q:'Z S Z0=$G(^RCY(344.31,Z,0)),RCDPDATA=Z_U_$P(Z0,U,3,4)_U_$P(Z0,U,7),X=RCDPCSUM_RCDPDATA X $S($G(^%ZOSF("LPC"))'="":^("LPC"),1:"S Y=""""") S RCDPCSUM=Y
|
||||
Q RCDPCSUM
|
||||
;
|
||||
DISP(RCTIT,RCCT,RCDXM,RCXMZ) ; Sends bulletin with formatted data from message
|
||||
; RCTIT = title of bulletin
|
||||
; RCCT = # of lines previously populated
|
||||
; RCXDM = array containing the text of the bulletin
|
||||
N RC,Z
|
||||
K ^TMP("RC1",$J),^TMP("RC",$J),^TMP("RCTEMP",$J)
|
||||
S RC=1,^TMP("RCTEMP",$J,RC)=$G(^TMP("RCMSGH",$J,0))
|
||||
S Z=0 F S Z=$O(^TMP("RCMSG",$J,2,"D",Z)) Q:'Z S RC=RC+1,^TMP("RCTEMP",$J,RC)=$G(^TMP("RCMSG",$J,2,"D",Z))
|
||||
D DISP^RCDPESR8("^TMP(""RCTEMP"",$J)","^TMP(""RC1"",$J)",1,"^TMP(""RC"",$J)",75)
|
||||
S Z=0 F S Z=$O(^TMP("RC",$J,Z)) Q:'Z S RCCT=RCCT+1,RCDXM(RCCT)=$G(^TMP("RC",$J,Z))
|
||||
D BULLEFT^RCDPESR0("",RCXMZ,RCTIT,.RCDXM)
|
||||
K ^TMP("RC1",$J),^TMP("RC",$J),^TMP("RCTEMP",$J)
|
||||
Q
|
||||
;
|
||||
DUP(RCM,RCIFN,RCAMT,RCAMT1) ; EOB in mail message already stored in 361.1?
|
||||
; RCM = msg # EOB was received in
|
||||
; RCIFN = bill ien
|
||||
; RCAMT = amt pd
|
||||
; RCAMT1 = amt reported billed
|
||||
; Returns 0 if none found, entry #^message checksum on file if found
|
||||
N Z,DUP,DUP1
|
||||
S (DUP,DUP1,Z)=0
|
||||
F S Z=$O(^IBM(361.1,"AC",RCM,Z)) Q:'Z I +$G(^IBM(361.1,Z,0))=RCIFN D Q:DUP
|
||||
. I '$P($G(^IBM(361.1,Z,100)),U,5) S DUP1=Z Q ; Partially filed before
|
||||
. I +$G(^IBM(361.1,Z,1))=+RCAMT,+$P($G(^IBM(361.1,1,Z,2)),U,4)=+RCAMT1 S DUP=Z_U_+$P($G(^IBM(361.1,Z,100)),U,5) Q
|
||||
I 'DUP,DUP1 S DUP=DUP1_"^0"
|
||||
Q DUP
|
||||
;
|
||||
DUPERA(DUP,RCNOUPD) ; Msg for duplicate ERA
|
||||
; RCNOUPD = # of message with duplicate data
|
||||
; DUP = flag = -1 if duplicate message received in same mail msg #
|
||||
K ^TMP("RCERR1",$J)
|
||||
S ^TMP("RCERR1",$J,1)=$S(DUP>0:"This an exact duplicate of an ERA received previously in mail msg "_RCNOUPD,1:"This ERA message was already fully processed - message was ignored")
|
||||
Q
|
||||
;
|
||||
BULLS(RCFILE,RCTDA,DUP,RCXMSG) ; Error bulletins for ERA
|
||||
I RCFILE=5 D BULL1^RCDPESR5(RCTDA,"^TMP(""RCERR1"",$J)",$S($G(DUP)>0:$G(DUP),1:""))
|
||||
I RCFILE=4 D BULL2^RCDPESR5(RCTDA,"^TMP(""RCERR1"",$J)",RCXMSG)
|
||||
Q
|
||||
;
|
||||
ADJERR(RCERR) ; Set up adj error text in RCERR(n) - pass by ref
|
||||
; Function returns # of lines for error text
|
||||
S RCERR(1)="At least 1 adjustment transaction has been found on this ERA. Before the",RCERR(2)=" receipt for this ERA can be processed, the appropriate adjustments",RCERR(3)=" must be made using the EEOB Worklist",RCERR(4)=" "
|
||||
Q 4
|
||||
;
|
||||
RCDPESR3 ;ALB/TMK - Server auto-update utilities - EDI Lockbox ;06/06/02
|
||||
;;4.5;Accounts Receivable;**173,214,208**;Mar 20, 1995
|
||||
Q
|
||||
;
|
||||
EFTIN(RCTXN,RCD,XMZ,RCGBL,RCEFLG) ; Adds a new EFT record to AR file 344.3
|
||||
; from Lockbox EFT msg
|
||||
; RCTXN = the data on the header record of the message text
|
||||
; RCD = array containing formatted mail message header data
|
||||
; XMZ = the mail message number
|
||||
; RCGBL = the name of the array or global where the message is stored
|
||||
; RCEFLG = error flag returned if passed by reference
|
||||
;
|
||||
N CT,RC,RC1,RCLAST,RCEFT,RCTDA,RCERR,RCTYP1,DA,DIK,RCZ,Z,Z0,DLAYGO
|
||||
;
|
||||
; Take data out of mail message
|
||||
S (RCEFLG,RCLAST)=0,CT=0,RCTYP1="835EFT"
|
||||
F X XMREC Q:XMER<0 D Q:RCLAST
|
||||
. I +XMRG=99,$P(XMRG,U,2)="$" S RCLAST=1 Q
|
||||
. S:XMRG'="" CT=CT+1,@RCGBL@(2,"D",CT)=XMRG
|
||||
;
|
||||
I 'RCLAST,'$G(RCERR) K @RCGBL S RCERR=2 ;No $ as last character of msg
|
||||
;
|
||||
I $G(RCERR)>0 D G EFTQ
|
||||
. D ERRUPD^RCDPESR1(RCGBL,.RCD,RCTYP1,.RCERR)
|
||||
. S RCEFLG=1
|
||||
;
|
||||
; Add top-level entry to file 344.3
|
||||
S RCEFT=$$ADDEFT(RCTXN,XMZ,RCGBL,.RCERR)
|
||||
;
|
||||
I $G(RCERR) D G EFTQ ; 'BAD' EFT's
|
||||
. D ERRUPD^RCDPESR1(RCGBL,.RCD,RCTYP1,.RCERR)
|
||||
. S RCEFLG=1
|
||||
;
|
||||
G:'RCEFT EFTQ
|
||||
;
|
||||
; Add the detail data to file 344.31 for this EFT record
|
||||
S Z=0 F S Z=$O(^RCY(344.31,"B",RCEFT,Z)) Q:'Z S DA=Z,DIK="^RCY(344.31," D ^DIK ; Delete any detail data already there
|
||||
;
|
||||
S (RC,RC1,RCZ)=0
|
||||
F S RCZ=$O(@RCGBL@(2,"D",RCZ)) Q:'RCZ S Z0=$G(^(RCZ)) I Z0'="" D Q:$G(RCERR)
|
||||
. I $P(Z0,U)="01" D ; Each payer's data
|
||||
.. N DA,DIE,DR,X,Y,DO,DD,DIC
|
||||
.. S X=RCEFT
|
||||
.. S DIC("DR")=".11////0;.04////"_$P(Z0,U,2)_";.08////0"_$S($P(Z0,U,5)'="":";.02////"_$P(Z0,U,5),1:"")_$S($P(Z0,U,6)'="":";.03////"_$P(Z0,U,6),1:"")_";.07////"_$J(+$P(Z0,U,4)/100,"",2)_";.06////"_$S($P(Z0,U,8)'="":1,1:0)
|
||||
.. S DIC("DR")=DIC("DR")_";.12///"_$$FDT^RCDPESR9($P(Z0,U,3))_";.13////"_DT_$S($P(Z0,U,7)'="":";.05////"_$P(Z0,U,7),1:"")_$S($P(Z0,U,9)'="":";.15////"_$P(Z0,U,9),1:"")
|
||||
.. ;
|
||||
.. I $P(Z0,U,8)'="" D ; tax id error
|
||||
... D TAXERR^RCDPESR1("EFT",$P(Z0,U,5)_" Payer ID: "_$P(RCTXN,U,6),$P(RCTXN,U,7),$P(RCTXN,U,8)) ; Send bad tax id bulletin
|
||||
.. ;
|
||||
.. S DIC(0)="L",DIC="^RCY(344.31,",DLAYGO=344.31 D FILE^DICN K DIC,DLAYGO,DO,DD
|
||||
.. I Y'>0 D ; Error filing data
|
||||
... S DIK="^RCY(344.3,",DA=RCEFT D ^DIK
|
||||
... S Z=0 F S Z=$O(^RCY(344.31,"B",RCEFT,Z)) Q:'Z S DIK="^RCY(344.31,",DA=Z D ^DIK
|
||||
... S RCEFLG=1,RCERR=3
|
||||
... D ERRUPD^RCDPESR1(RCGBL,.RCD,RCTYP1,RCERR)
|
||||
;
|
||||
I '$G(RCEFLG) D
|
||||
. S DIE="^RCY(344.3,",DA=RCEFT,DR=".09////"_$$CHKSUM(RCEFT) D ^DIE
|
||||
;
|
||||
EFTQ ;
|
||||
D CLEAN^DILF
|
||||
Q
|
||||
;
|
||||
ADDEFT(RCTXN,RCXMZ,RCGBL,RCERR) ; File EFT TOTAL record in file 344.3
|
||||
; RCTXN = the data on the header record of the message text
|
||||
; RCXMZ = the mail message number
|
||||
; RCGBL = the name of the array or global where the message is stored
|
||||
; Function returns the ien of the total record found/added
|
||||
; and also returns RCERR if passed by reference
|
||||
;
|
||||
N RCTDA,RCRCPT,RCDUP,RCHAC,Z,Z0
|
||||
S (RCERR,RCTDA)=""
|
||||
;
|
||||
I $E($P(RCTXN,U,6),1,3)'="469",$E($P(RCTXN,U,6),1,3)'="HAC" D G ADDQ ; Invalid EFT deposit number
|
||||
. N RCDXM,RCCT
|
||||
. S RCCT=0
|
||||
. S RCCT=RCCT+1,RCDXM(RCCT)="This EFT has an invalid deposit number for EDI Lockbox and has been rejected.",RCCT=RCCT+1,RCDXM(RCCT)=" "
|
||||
. S RCCT=RCCT+1,RCDXM(RCCT)=" ",RCCT=RCCT+1,RCDXM(RCCT)="Here are the contents of this message:"
|
||||
. D DISP("EDI LBOX INVALID EFT DEPOSIT #",RCCT,.RCDXM,RCXMZ)
|
||||
;
|
||||
; Make sure it's not already there or if so, it has no ptr to a deposit
|
||||
; or if a deposit exists, that the deposit does not yet have a receipt
|
||||
S RCDUP=0,RCHAC=$E($P(RCTXN,U,6),1,3)="HAC" ; This is a HAC deposit
|
||||
I $P(RCTXN,U,6)'="" D
|
||||
. S Z=0 ; Lookup deposit by deposit #
|
||||
. F S Z=$O(^RCY(344.3,"C",$P(RCTXN,U,6),Z)) Q:'Z S Z0=$G(^RCY(344.3,Z,0)) S:'$P(Z0,U,3) RCTDA=Z Q:RCTDA D Q
|
||||
.. ; Deposit found - find receipt
|
||||
.. I $O(^RCY(344,"AD",$P(Z0,U,3),0)) S RCDUP=Z Q
|
||||
.. S RCTDA=Z
|
||||
;
|
||||
I RCDUP D ; Send bulletin that duplicate EFT received
|
||||
. N RCDXM,RCCT
|
||||
. S RCCT=0
|
||||
. S RCCT=RCCT+1,RCDXM(RCCT)="This EFT appears to be a duplicate transaction and has been rejected.",RCCT=RCCT+1,RCDXM(RCCT)=" "
|
||||
. S RCCT=RCCT+1,RCDXM(RCCT)=" ",RCCT=RCCT+1,RCDXM(RCCT)="Here are the contents of this message:"
|
||||
. D DISP("EDI LBOX DUP EFT DEPOSIT RECEIVED",RCCT,.RCDXM,RCXMZ)
|
||||
;
|
||||
I 'RCDUP D ; Add or update the record
|
||||
. N RCX,RCDTTM,DIE,DIC,DLAYGO,DD,DA,DO,DR,X,Y,%DT,DINUM
|
||||
. ;
|
||||
. S X=$$FDT^RCDPESR9($P(RCTXN,U,3))_"@"_$P(RCTXN,U,4)
|
||||
. S %DT="XTS" D ^%DT S:Y>0 RCDTTM=Y
|
||||
. ;
|
||||
. S DIC("DR")=""
|
||||
. S DIC("DR")=$S(RCDTTM'="":".02////"_RCDTTM,1:"")
|
||||
. S DIC("DR")=DIC("DR")_$S(DIC("DR")'="":";",1:"")_".06////"_$P(RCTXN,U,6)_";.07///"_$$FDT^RCDPESR9($P(RCTXN,U,7))
|
||||
. S DIC("DR")=DIC("DR")_";.08////"_$$ZERO^RCDPESR9($P(RCTXN,U,8),1)_";.13////"_$$NOW^XLFDT()_";.05////"_RCXMZ_";.14////0;.12////0"
|
||||
. ;
|
||||
. I RCTDA D ; Overwrite the data already there
|
||||
.. L +^RCY(344.3,RCTDA):1 I '$T S RCTDA=-1 Q
|
||||
.. S DIE="^RCY(344.3,",DA=RCTDA,DR=DIC("DR") K DIC D ^DIE
|
||||
.. L -^RCY(344.3,RCTDA)
|
||||
. ;
|
||||
. I 'RCTDA D
|
||||
.. S RCX=+$O(^RCY(344.3," "),-1)
|
||||
.. F RCX=RCX+1:1 I '$D(^RCY(344.3,RCX,0)) L +^RCY(344.3,RCX,0):1 I $T S X=RCX Q
|
||||
.. S DIC(0)="L",DIC="^RCY(344.3,",DLAYGO=344.3,DINUM=RCX
|
||||
.. D FILE^DICN K DO,DD,DLAYGO,DIC,DINUM
|
||||
.. L -^RCY(344.3,RCX,0)
|
||||
.. S RCTDA=$S(Y<0:"",1:+Y)
|
||||
. ;
|
||||
. I 'RCTDA S RCERR=3 ; Error in add of EFT record to file 344.3
|
||||
;
|
||||
ADDQ Q $S(RCTDA>0:RCTDA,1:"")
|
||||
;
|
||||
CHKSUM(RCTDA) ; Calc the checksum for EFT record stored in RCTDA in 344.3
|
||||
;
|
||||
N RCDPCSUM,RCDPDATA,X,Y,Z,Z0
|
||||
;
|
||||
S (RCDPCSUM,X)=0,Z0=$G(^RCY(344.3,RCTDA,0))
|
||||
; Use pcs 1-8, leaving out piece 3
|
||||
S RCDPDATA=$P(Z0,U,1,8),$P(RCDPDATA,U,3)=""
|
||||
S X=RCDPCSUM_RCDPDATA X $S($G(^%ZOSF("LPC"))'="":^("LPC"),1:"S Y=""""") S RCDPCSUM=Y
|
||||
; Use detail iens and pieces 3,4,7 to complete the checksum
|
||||
S Z=0 F S Z=$O(^RCY(344.31,"B",RCTDA,Z)) Q:'Z S Z0=$G(^RCY(344.31,Z,0)),RCDPDATA=Z_U_$P(Z0,U,3,4)_U_$P(Z0,U,7),X=RCDPCSUM_RCDPDATA X $S($G(^%ZOSF("LPC"))'="":^("LPC"),1:"S Y=""""") S RCDPCSUM=Y
|
||||
Q RCDPCSUM
|
||||
;
|
||||
DISP(RCTIT,RCCT,RCDXM,RCXMZ) ; Sends bulletin with formatted data from message
|
||||
; RCTIT = title of bulletin
|
||||
; RCCT = # of lines previously populated
|
||||
; RCXDM = array containing the text of the bulletin
|
||||
N RC,Z
|
||||
K ^TMP("RC1",$J),^TMP("RC",$J),^TMP("RCTEMP",$J)
|
||||
S RC=1,^TMP("RCTEMP",$J,RC)=$G(^TMP("RCMSGH",$J,0))
|
||||
S Z=0 F S Z=$O(^TMP("RCMSG",$J,2,"D",Z)) Q:'Z S RC=RC+1,^TMP("RCTEMP",$J,RC)=$G(^TMP("RCMSG",$J,2,"D",Z))
|
||||
D DISP^RCDPESR8("^TMP(""RCTEMP"",$J)","^TMP(""RC1"",$J)",1,"^TMP(""RC"",$J)",75)
|
||||
S Z=0 F S Z=$O(^TMP("RC",$J,Z)) Q:'Z S RCCT=RCCT+1,RCDXM(RCCT)=$G(^TMP("RC",$J,Z))
|
||||
D BULLEFT^RCDPESR0("",RCXMZ,RCTIT,.RCDXM)
|
||||
K ^TMP("RC1",$J),^TMP("RC",$J),^TMP("RCTEMP",$J)
|
||||
Q
|
||||
;
|
||||
DUP(RCM,RCIFN,RCAMT,RCAMT1) ; EOB in mail message already stored in 361.1?
|
||||
; RCM = msg # EOB was received in
|
||||
; RCIFN = bill ien
|
||||
; RCAMT = amt pd
|
||||
; RCAMT1 = amt reported billed
|
||||
; Returns 0 if none found, entry #^message checksum on file if found
|
||||
N Z,DUP,DUP1
|
||||
S (DUP,DUP1,Z)=0
|
||||
F S Z=$O(^IBM(361.1,"AC",RCM,Z)) Q:'Z I +$G(^IBM(361.1,Z,0))=RCIFN D Q:DUP
|
||||
. I '$P($G(^IBM(361.1,Z,100)),U,5) S DUP1=Z Q ; Partially filed before
|
||||
. I +$G(^IBM(361.1,Z,1))=+RCAMT,+$P($G(^IBM(361.1,1,Z,2)),U,4)=+RCAMT1 S DUP=Z_U_+$P($G(^IBM(361.1,Z,100)),U,5) Q
|
||||
I 'DUP,DUP1 S DUP=DUP1_"^0"
|
||||
Q DUP
|
||||
;
|
||||
DUPERA(DUP,RCNOUPD) ; Msg for duplicate ERA
|
||||
; RCNOUPD = # of message with duplicate data
|
||||
; DUP = flag = -1 if duplicate message received in same mail msg #
|
||||
K ^TMP("RCERR1",$J)
|
||||
S ^TMP("RCERR1",$J,1)=$S(DUP>0:"This an exact duplicate of an ERA received previously in mail msg "_RCNOUPD,1:"This ERA message was already fully processed - message was ignored")
|
||||
Q
|
||||
;
|
||||
BULLS(RCFILE,RCTDA,DUP,RCXMSG) ; Error bulletins for ERA
|
||||
I RCFILE=5 D BULL1^RCDPESR5(RCTDA,"^TMP(""RCERR1"",$J)",$S($G(DUP)>0:$G(DUP),1:""))
|
||||
I RCFILE=4 D BULL2^RCDPESR5(RCTDA,"^TMP(""RCERR1"",$J)",RCXMSG)
|
||||
Q
|
||||
;
|
||||
ADJERR(RCERR) ; Set up adj error text in RCERR(n) - pass by ref
|
||||
; Function returns # of lines for error text
|
||||
S RCERR(1)="At least 1 adjustment transaction has been found on this ERA. Before the",RCERR(2)=" receipt for this ERA can be processed, the appropriate adjustments",RCERR(3)=" must be made using the EEOB Worklist",RCERR(4)=" "
|
||||
Q 4
|
||||
;
|
||||
|
|
|
|||
|
|
@ -1,110 +1,100 @@
|
|||
RCDPESR6 ;ALB/TMK - Server auto-update file 344.4 - EDI Lockbox ;10/29/02
|
||||
;;4.5;Accounts Receivable;**173,214,208,230,252**;Mar 20, 1995;Build 63
|
||||
;;Per VHA Directive 2004-038, this routine should not be modified.
|
||||
;
|
||||
UPD3444(RCRTOT) ; Add EOB detail to list in 344.41 for file 344.4 entry RCRTOT
|
||||
; If passed by reference, RCRTOT is returned = "" if errors
|
||||
;
|
||||
N RC,RCCOM1,RCCOM2,RCCT,RC1,RC2,RCDPNM,RCEOB,RCNPI1,RCNPI2,DA,DR,DO,DD,DLAYGO,DIC,DIK,X,Y,Z
|
||||
S RC=0 F S RC=$O(^TMP($J,"RCDPEOB",RC)) Q:'RC S RC1=$G(^(RC)),RC2=$G(^(RC,"EOB")),RCEOB=+RC2 D Q:'RCRTOT
|
||||
. ; Upd 344.41 with reference to this record if it doesn't already exist
|
||||
. I RCEOB>0 Q:$D(^RCY(344.4,RCRTOT,1,"AC",RCEOB,RC))
|
||||
. I RCEOB'>0,$S($P(RC1,U,2)'="":$D(^RCY(344.4,RCRTOT,1,"AD",$P(RC1,U,2),RC)),1:0) Q
|
||||
. ; Disregard ECME reject related EEOBs
|
||||
. I RCEOB'>0,'$P(RC2,U,2),$P(RC1,U,2)?1.7N,$$REJECT^IBNCPDPU($P(RC1,U,2),$P(RC1,U,3)) Q
|
||||
. S DA(1)=RCRTOT,X=RC,DIC="^RCY(344.4,"_DA(1)_",1,",DIC(0)="L",DLAYGO=344.41
|
||||
. S DIC("DR")=$S($G(RCEOB)>0:".02////"_RCEOB,1:".05////"_$P(RC1,U,2)_";.07////1")
|
||||
. I $P(RC2,U,2)'="" S DIC("DR")=DIC("DR")_$S($L(DIC("DR")):";",1:"")_".03///"_$P(RC2,U,2) ; amt
|
||||
. I $P(RC2,U,3)'="" S DIC("DR")=DIC("DR")_$S($L(DIC("DR")):";",1:"")_".04////"_$P(RC2,U,3) ; ins co
|
||||
. I $P(RC2,U,4) S DIC("DR")=DIC("DR")_$S($L(DIC("DR")):";",1:"")_".14////1" ; reversal
|
||||
. I $P(RC2,U,5)'="" S DIC("DR")=DIC("DR")_$S($L(DIC("DR")):";",1:"")_".15////^S X=$E($P(RC2,U,5),1,30)" ; Patient name
|
||||
. ; Process Billing Prov NPI, Rendering/Servicing NPI & name
|
||||
. S (RCCOM1,RCCOM2)=""
|
||||
. S RCNPI1=$P(RC2,U,10),RCNPI2=$P(RC2,U,11)
|
||||
. I RCNPI1'="",'$$CHKDGT^XUSNPI(RCNPI1) S RCCOM1="The Billing Provider NPI received on the 835 ("_$E(RCNPI1,1,10)_") is not a valid format."
|
||||
. I RCNPI2'="",'$$CHKDGT^XUSNPI(RCNPI2) S RCCOM2="The "_$S($P(RC2,U,12)=1:"Rendering",1:"Servicing")_" NPI received on the 835 ("_$E(RCNPI2,1,10)_") is not a valid format."
|
||||
. I RCCOM1="" S DIC("DR")=DIC("DR")_";.18////^S X=$P(RC2,U,10)" ;Billing Provider NPI
|
||||
. I RCCOM2="" S DIC("DR")=DIC("DR")_";.19////^S X=$P(RC2,U,11)" ;Rendering Provider NPI
|
||||
. S RCDPNM=$P(RC2,U,13) I $P(RC2,U,14)]"" S RCDPNM=RCDPNM_$S(RCDPNM]"":",",1:"")_$P(RC2,U,14)
|
||||
. S DIC("DR")=DIC("DR")_";.2////^S X=$P(RC2,U,12);.21////^S X=RCDPNM" ; Entity Type Qualifier ^ Last name,First Name
|
||||
. S DIC("DR")=DIC("DR")_";.22////^S X=RCCOM1;.23////^S X=RCCOM2" ;Comment on Billing provider^comment on rendering/servicing provider NPI
|
||||
. D FILE^DICN K DO,DD,DLAYGO,DIC,DIK
|
||||
. S RCCT=+Y
|
||||
. I RCCT<0 D Q
|
||||
.. S DA=RCRTOT,DIK="^RCY(344.4," D ^DIK
|
||||
.. S RCRTOT=0
|
||||
. ; If there is no IB EOB record, store the raw data in 344.411
|
||||
. I RC1'>0!(RCEOB'>0) D
|
||||
.. N RCDATA,RCC,RCDA
|
||||
.. S RCC=2,RCDATA(1)=$G(^TMP($J,"RCDPEOB","HDR"))
|
||||
.. S Z=0 F S Z=$O(^TMP($J,"RCDPEOB",RCCT,Z)) Q:'Z S RCC=RCC+1,RCDATA(RCC)=$G(^TMP($J,"RCDPEOB",RCCT,Z))
|
||||
.. S RCDA(1)=RCRTOT,RCDA=RCCT
|
||||
.. D WP^DIE(344.41,$$IENS^DILF(.RCDA),1,"A","RCDATA")
|
||||
Q
|
||||
;
|
||||
;
|
||||
ERATOT(RCTDA,RCERR) ; File ERA TOTAL rec in 344.4 from entry RCTDA in 344.5
|
||||
; RCTDA = ien file 344.5
|
||||
; Returns: the ien file 344.4
|
||||
; RCERR if passed by reference, with error text
|
||||
; RCERR(1)=duplicated message
|
||||
N RCTYPE,RCDA,RCMETH,RCTRACE,RCID,RCDT,RCAMT,RCDUP,RCZ,RCX,RCPAYER,DIE,DIK,DIC,DLAYGO,DD,DO,DR,DA,X,Y,Z0,Z1
|
||||
S (RCERR,RCDA)=""
|
||||
S RCZ=$G(^RCY(344.5,RCTDA,2,1,0))
|
||||
S RCTYPE=$P(RCZ,U),RCTRACE=$P(RCZ,U,8),RCID=$P(RCZ,U,7),RCPAYER=$P(RCZ,U,6),RCMETH=$P(RCZ,U,17)
|
||||
; Need header record as first entry in field
|
||||
I RCTYPE'["835ERA" S RCERR="No header record found in message. An EEOB exception record was created" G ERATOTQ
|
||||
;
|
||||
S RCDT=$$FMDT^RCDPESR1($P(RCZ,U,9)),RCAMT=$J(($P(RCZ,U,10)/100),0,2)
|
||||
;Elec ERA's must have a trace # and an ins co id
|
||||
I RCTRACE=""!(RCID="") S RCERR="Trace # or ins ID missing on ERA transaction. An EEOB exception record was created." G ERATOTQ
|
||||
; Make sure it's not already there
|
||||
S (RCDUP,Z1)=0
|
||||
F S Z1=$O(^RCY(344.4,"ATRID",RCTRACE,RCID,Z1)) Q:'Z1 S Z0=$G(^RCY(344.4,Z1,0)) I $P(Z0,U,4)=RCDT,+$P(Z0,U,5)=+RCAMT S RCDUP=1 Q
|
||||
;
|
||||
I RCDUP,$P(Z0,U,8) D G ERATOTQ ; Receipt already exists - no update
|
||||
. S RCERR="This is a duplicate ERA and has already been posted",RCERR(1)=-2
|
||||
I RCDUP S RCERR="DUP",RCERR(1)=$S($P(Z0,U,12)'=$P($G(^RCY(344.5,RCTDA,0)),U,11):$P(Z0,U,12),1:-1) G ERATOTQ
|
||||
;
|
||||
S RCX=+$O(^RCY(344.4," "),-1)
|
||||
S DIC(0)="L",DIC="^RCY(344.4,",DLAYGO=344.4
|
||||
S DIC("DR")=".02////"_RCTRACE_";.03////"_RCID_";.04////"_RCDT_";.05////"_RCAMT_";.06////"_$P(RCZ,U,6)_";.09////0;.12////"_$P($G(^RCY(344.5,RCTDA,0)),U,11)_";.07////"_$$NOW^XLFDT()_";.1////1"
|
||||
I RCMETH'="" S DIC("DR")=DIC("DR")_";.15////"_RCMETH
|
||||
F RCX=RCX+1:1 L +^RCY(344.4,RCX,0):1 I $T,'$D(^RCY(344.4,RCX,0)) S X=RCX Q
|
||||
D FILE^DICN K DO,DLAYGO,DD,DIC
|
||||
L -^RCY(344.4,RCX,0)
|
||||
S RCDA=$S(Y<0:"",1:+Y)
|
||||
I 'RCDA D
|
||||
. S RCERR="An error was encountered that prevented the adding of an ERA totals record. An EEOB exception record was created."
|
||||
;
|
||||
ERATOTQ Q RCDA
|
||||
;
|
||||
UPDCON(RCRTOT) ; Add contact information to file 344.4 for an ERA
|
||||
N DIE,DA,DR,Z,Q,X,Y
|
||||
S Z=$G(^TMP($J,"RCDPEOB","CONTACT"))
|
||||
Q:$TR($P(Z,U,3,9),U)=""
|
||||
S DA=RCRTOT,DIE="^RCY(344.4,",DR=""
|
||||
F Q=3:1:9 S DR=DR_$S(DR'="":";3.0",1:"3.0")_(Q-2)_"///"_$S($P(Z,U,Q)="":"@",1:"/"_$P(Z,U,Q))
|
||||
D ^DIE
|
||||
Q
|
||||
;
|
||||
UPDADJ(RCRTOT) ; Add ERA level adj data to file 344.4
|
||||
N Z,Z0,DA,DIC,DLAYGO,DR,X,Y,DO,DD
|
||||
; Remove any already there
|
||||
S Z=0 F S Z=$O(^RCY(344.4,RCRTOT,2,Z)) Q:'Z S DA(1)=RCRTOT,DA=Z D ^DIK
|
||||
;
|
||||
S Z=0 F S Z=$O(^TMP($J,"RCDPEOB","ADJ",Z)) Q:'Z S Z0=$G(^(Z)) D
|
||||
. S DIC(0)="L",X=$P(Z0,U,3)_" ",DA(1)=RCRTOT,DIC="^RCY(344.4,"_DA(1)_",2,",DIC("DR")=$S($P(Z0,U,2)'="":".02////"_$P(Z0,U,2),1:"")
|
||||
. S DIC("DR")=DIC("DR")_$S(DIC("DR")'="":";",1:"")_$S($P(Z0,U,4)'="":".03////"_$J(-$P(Z0,U,4)/100,"",2),1:"")
|
||||
. S DIC("DR")=DIC("DR")_$S(DIC("DR")'="":";",1:"")_$S($P(Z0,U,5)'="":".04////"_$P(Z0,U,5),1:""),DLAYGO=344.42
|
||||
. S:$O(^RCY(344.4,RCRTOT,2,"B",X,0)) X=""""_X_""""
|
||||
. D FILE^DICN K DIC,DO,DD
|
||||
Q
|
||||
;
|
||||
DUPREC(RCET,RCCT,RCSTAR,RCFILE,RCALLDUP,RCEOB,RCBILL,RCDUPEOB) ; Overflow from RCDPESR2
|
||||
S ^TMP("RCERR1",$J,RCCT)=" ",^TMP("RCERR1",$J,RCCT,1)=RCET_RCCT_RCSTAR
|
||||
S ^TMP("RCERR1",$J,RCCT,2)="(Warning): EEOB detail already filed for "_RCBILL_" - "_$S(RCALLDUP:"Duplicate not stored",1:"EEOB updated"),^TMP("RCERR1",$J,RCCT,3)=" " S:RCFILE=5 ^TMP("RCERR1",$J,RCCT,"*")=^TMP("RCERR1",$J,RCCT,2)
|
||||
I RCALLDUP S RCEOB="",RCDUPEOB=-1 Q
|
||||
S $P(^TMP($J,"RCDPEOB",RCCT,"EOB"),U)=RCEOB
|
||||
Q
|
||||
;
|
||||
RCDPESR6 ;ALB/TMK - Server auto-update file 344.4 - EDI Lockbox ;10/29/02
|
||||
;;4.5;Accounts Receivable;**173,214,208,230**;Mar 20, 1995
|
||||
;;Per VHA Directive 10-93-142, this routine should not be modified.
|
||||
;
|
||||
UPD3444(RCRTOT) ; Add EOB detail to list in 344.41 for file 344.4 entry RCRTOT
|
||||
; If passed by reference, RCRTOT is returned = "" if errors
|
||||
;
|
||||
N RC,RCCT,RC1,RC2,RCEOB,DA,DR,DO,DD,DLAYGO,DIC,DIK,X,Y,Z
|
||||
S RC=0 F S RC=$O(^TMP($J,"RCDPEOB",RC)) Q:'RC S RC1=$G(^(RC)),RC2=$G(^(RC,"EOB")),RCEOB=+RC2 D Q:'RCRTOT
|
||||
. ; Upd 344.41 with reference to this record if it doesn't already exist
|
||||
. I RCEOB>0 Q:$D(^RCY(344.4,RCRTOT,1,"AC",RCEOB,RC))
|
||||
. I RCEOB'>0,$S($P(RC1,U,2)'="":$D(^RCY(344.4,RCRTOT,1,"AD",$P(RC1,U,2),RC)),1:0) Q
|
||||
. ; Disregard ECME reject related EEOBs
|
||||
. I RCEOB'>0,'$P(RC2,U,2),$P(RC1,U,2)?1.7N,$$REJECT^IBNCPDPU($P(RC1,U,2),$P(RC1,U,3)) Q
|
||||
. S DA(1)=RCRTOT,X=RC,DIC="^RCY(344.4,"_DA(1)_",1,",DIC(0)="L",DLAYGO=344.41
|
||||
. S DIC("DR")=$S($G(RCEOB)>0:".02////"_RCEOB,1:".05////"_$P(RC1,U,2)_";.07////1")
|
||||
. I $P(RC2,U,2)'="" S DIC("DR")=DIC("DR")_$S($L(DIC("DR")):";",1:"")_".03///"_$P(RC2,U,2) ; amt
|
||||
. I $P(RC2,U,3)'="" S DIC("DR")=DIC("DR")_$S($L(DIC("DR")):";",1:"")_".04////"_$P(RC2,U,3) ; ins co
|
||||
. I $P(RC2,U,4) S DIC("DR")=DIC("DR")_$S($L(DIC("DR")):";",1:"")_".14////1" ; reversal
|
||||
. I $P(RC2,U,5)'="" S DIC("DR")=DIC("DR")_$S($L(DIC("DR")):";",1:"")_".15////^S X=$E($P(RC2,U,5),1,30)" ; Patient name
|
||||
. D FILE^DICN K DO,DD,DLAYGO,DIC,DIK
|
||||
. S RCCT=+Y
|
||||
. I RCCT<0 D Q
|
||||
.. S DA=RCRTOT,DIK="^RCY(344.4," D ^DIK
|
||||
.. S RCRTOT=0
|
||||
. ; If there is no IB EOB record, store the raw data in 344.411
|
||||
. I RC1'>0!(RCEOB'>0) D
|
||||
.. N RCDATA,RCC,RCDA
|
||||
.. S RCC=2,RCDATA(1)=$G(^TMP($J,"RCDPEOB","HDR"))
|
||||
.. S Z=0 F S Z=$O(^TMP($J,"RCDPEOB",RCCT,Z)) Q:'Z S RCC=RCC+1,RCDATA(RCC)=$G(^TMP($J,"RCDPEOB",RCCT,Z))
|
||||
.. S RCDA(1)=RCRTOT,RCDA=RCCT
|
||||
.. D WP^DIE(344.41,$$IENS^DILF(.RCDA),1,"A","RCDATA")
|
||||
Q
|
||||
;
|
||||
;
|
||||
ERATOT(RCTDA,RCERR) ; File ERA TOTAL rec in 344.4 from entry RCTDA in 344.5
|
||||
; RCTDA = ien file 344.5
|
||||
; Returns: the ien file 344.4
|
||||
; RCERR if passed by reference, with error text
|
||||
; RCERR(1)=duplicated message
|
||||
N RCTYPE,RCDA,RCMETH,RCTRACE,RCID,RCDT,RCAMT,RCDUP,RCZ,RCX,RCPAYER,DIE,DIK,DIC,DLAYGO,DD,DO,DR,DA,X,Y,Z0,Z1
|
||||
S (RCERR,RCDA)=""
|
||||
S RCZ=$G(^RCY(344.5,RCTDA,2,1,0))
|
||||
S RCTYPE=$P(RCZ,U),RCTRACE=$P(RCZ,U,8),RCID=$P(RCZ,U,7),RCPAYER=$P(RCZ,U,6),RCMETH=$P(RCZ,U,17)
|
||||
; Need header record as first entry in field
|
||||
I RCTYPE'["835ERA" S RCERR="No header record found in message. An EEOB exception record was created" G ERATOTQ
|
||||
;
|
||||
S RCDT=$$FMDT^RCDPESR1($P(RCZ,U,9)),RCAMT=$J(($P(RCZ,U,10)/100),0,2)
|
||||
;Elec ERA's must have a trace # and an ins co id
|
||||
I RCTRACE=""!(RCID="") S RCERR="Trace # or ins ID missing on ERA transaction. An EEOB exception record was created." G ERATOTQ
|
||||
; Make sure it's not already there
|
||||
S (RCDUP,Z1)=0
|
||||
F S Z1=$O(^RCY(344.4,"ATRID",RCTRACE,RCID,Z1)) Q:'Z1 S Z0=$G(^RCY(344.4,Z1,0)) I $P(Z0,U,4)=RCDT,+$P(Z0,U,5)=+RCAMT S RCDUP=1 Q
|
||||
;
|
||||
I RCDUP,$P(Z0,U,8) D G ERATOTQ ; Receipt already exists - no update
|
||||
. S RCERR="This is a duplicate ERA and has already been posted",RCERR(1)=-2
|
||||
I RCDUP S RCERR="DUP",RCERR(1)=$S($P(Z0,U,12)'=$P($G(^RCY(344.5,RCTDA,0)),U,11):$P(Z0,U,12),1:-1) G ERATOTQ
|
||||
;
|
||||
S RCX=+$O(^RCY(344.4," "),-1)
|
||||
S DIC(0)="L",DIC="^RCY(344.4,",DLAYGO=344.4
|
||||
S DIC("DR")=".02////"_RCTRACE_";.03////"_RCID_";.04////"_RCDT_";.05////"_RCAMT_";.06////"_$P(RCZ,U,6)_";.09////0;.12////"_$P($G(^RCY(344.5,RCTDA,0)),U,11)_";.07////"_$$NOW^XLFDT()_";.1////1"
|
||||
I RCMETH'="" S DIC("DR")=DIC("DR")_";.15////"_RCMETH
|
||||
F RCX=RCX+1:1 L +^RCY(344.4,RCX,0):1 I $T,'$D(^RCY(344.4,RCX,0)) S X=RCX Q
|
||||
D FILE^DICN K DO,DLAYGO,DD,DIC
|
||||
L -^RCY(344.4,RCX,0)
|
||||
S RCDA=$S(Y<0:"",1:+Y)
|
||||
I 'RCDA D
|
||||
. S RCERR="An error was encountered that prevented the adding of an ERA totals record. An EEOB exception record was created."
|
||||
;
|
||||
ERATOTQ Q RCDA
|
||||
;
|
||||
UPDCON(RCRTOT) ; Add contact information to file 344.4 for an ERA
|
||||
N DIE,DA,DR,Z,Q,X,Y
|
||||
S Z=$G(^TMP($J,"RCDPEOB","CONTACT"))
|
||||
Q:$TR($P(Z,U,3,9),U)=""
|
||||
S DA=RCRTOT,DIE="^RCY(344.4,",DR=""
|
||||
F Q=3:1:9 S DR=DR_$S(DR'="":";3.0",1:"3.0")_(Q-2)_"///"_$S($P(Z,U,Q)="":"@",1:"/"_$P(Z,U,Q))
|
||||
D ^DIE
|
||||
Q
|
||||
;
|
||||
UPDADJ(RCRTOT) ; Add ERA level adj data to file 344.4
|
||||
N Z,Z0,DA,DIC,DLAYGO,DR,X,Y,DO,DD
|
||||
; Remove any already there
|
||||
S Z=0 F S Z=$O(^RCY(344.4,RCRTOT,2,Z)) Q:'Z S DA(1)=RCRTOT,DA=Z D ^DIK
|
||||
;
|
||||
S Z=0 F S Z=$O(^TMP($J,"RCDPEOB","ADJ",Z)) Q:'Z S Z0=$G(^(Z)) D
|
||||
. S DIC(0)="L",X=$P(Z0,U,3)_" ",DA(1)=RCRTOT,DIC="^RCY(344.4,"_DA(1)_",2,",DIC("DR")=$S($P(Z0,U,2)'="":".02////"_$P(Z0,U,2),1:"")
|
||||
. S DIC("DR")=DIC("DR")_$S(DIC("DR")'="":";",1:"")_$S($P(Z0,U,4)'="":".03////"_$J(-$P(Z0,U,4)/100,"",2),1:"")
|
||||
. S DIC("DR")=DIC("DR")_$S(DIC("DR")'="":";",1:"")_$S($P(Z0,U,5)'="":".04////"_$P(Z0,U,5),1:""),DLAYGO=344.42
|
||||
. S:$O(^RCY(344.4,RCRTOT,2,"B",X,0)) X=""""_X_""""
|
||||
. D FILE^DICN K DIC,DO,DD
|
||||
Q
|
||||
;
|
||||
DUPREC(RCET,RCCT,RCSTAR,RCFILE,RCALLDUP,RCEOB,RCBILL,RCDUPEOB) ; Overflow from RCDPESR2
|
||||
S ^TMP("RCERR1",$J,RCCT)=" ",^TMP("RCERR1",$J,RCCT,1)=RCET_RCCT_RCSTAR
|
||||
S ^TMP("RCERR1",$J,RCCT,2)="(Warning): EEOB detail already filed for "_RCBILL_" - "_$S(RCALLDUP:"Duplicate not stored",1:"EEOB updated"),^TMP("RCERR1",$J,RCCT,3)=" " S:RCFILE=5 ^TMP("RCERR1",$J,RCCT,"*")=^TMP("RCERR1",$J,RCCT,2)
|
||||
I RCALLDUP S RCEOB="",RCDUPEOB=-1 Q
|
||||
S $P(^TMP($J,"RCDPEOB",RCCT,"EOB"),U)=RCEOB
|
||||
Q
|
||||
;
|
||||
|
|
|
|||
|
|
@ -1,210 +1,205 @@
|
|||
RCDPESR9 ;ALB/TMK - ERA return file field captions ;09-SEP-2003
|
||||
;;4.5;Accounts Receivable;**173,252**;Mar 20, 1995;Build 63
|
||||
;;Per VHA Directive 2004-038, this routine should not be modified.
|
||||
;
|
||||
; Note: if the 835 flat file changes, make the corresponding changes
|
||||
; in this routine.
|
||||
835 ;;HEADER DATA
|
||||
;;835^^Return Message ID^S Y=X_" (ERA HEADER DATA)"
|
||||
;;835^^X12/Proprietary flag^S Y=$S(X="X":"X12",1:X)
|
||||
;;835^^File Date^S Y=$$FDT^RCDPESR9(X)
|
||||
;;835^^File Time^S Y=$E(X,1,2)-$S($E(X,1,2)>12:12,1:0)_":"_$E(X,3,4)_$S($E(X,1,2)=24:" AM",$E(X,1,2)>11:" PM",1:" AM")
|
||||
;;835^1^MRA^S Y=""
|
||||
;;835^^Payer Name
|
||||
;;835^^Payer ID
|
||||
;;835^^Trace Number
|
||||
;;835^^Date Claims Paid^S Y=$$FDT^RCDPESR9(X)
|
||||
;;835^^Total ERA Amount^S Y=$$ZERO^RCDPESR9(X,1)
|
||||
;;835^^Erroneous Provider Tax ID
|
||||
;;835^^Tax ID correction Flag^S Y=$S(X="E":"CHANGED BY EPHRA",X="C":"DETERMINED FROM CLAIM DATA",X="":"NO CHANGE MADE",1:X)
|
||||
;;835^^Sequence Control #
|
||||
;;835^^Sequence #
|
||||
;;835^^Last Sequence #
|
||||
;;835^^Contact Information
|
||||
;;835^^Payment Method Code
|
||||
;;835^^Billing Provider NPI
|
||||
;
|
||||
01 ;;PAYER CONTACT INFORMATION
|
||||
;;01^^ERA Contact Name
|
||||
;;01^^ERA Contact #1
|
||||
;;01^^ERA Contact #1 Type^S Y=$$EXTERNAL^DILFD(344.4,3.03,,X)
|
||||
;;01^^ERA Contact #2
|
||||
;;01^^ERA Contact #2 Type^S Y=$$EXTERNAL^DILFD(344.4,3.05,,X)
|
||||
;;01^^ERA Contact #3
|
||||
;;01^^ERA Contact #3 Type^S Y=$$EXTERNAL^DILFD(344.4,3.07,,X)
|
||||
;
|
||||
02 ;;PAYER ADJUSTMENT RECORD
|
||||
;;02^^Line Type^S Y=X_" (ERA LEVEL PAYER ADJUSTMENT RECORD)"
|
||||
;;02^^X12 Adjustment Reason Code
|
||||
;;02^^Provider Adjustment Identifier
|
||||
;;02^^Adjustment Amount^S Y=$$ZERO^RCDPESR9(X,1)
|
||||
;;02^^X12 Reason Text
|
||||
;
|
||||
05 ;;CLAIM PATIENT ID
|
||||
;;05^^Line Type^S Y=X_" (CLAIM LEVEL PATIENT ID DATA)"
|
||||
;;05^^Bill #
|
||||
;;05^^Patient Last Name
|
||||
;;05^^Patient First Name
|
||||
;;05^^Patient Middle Name
|
||||
;;05^^Patient ID #
|
||||
;;05^1^Record Contains Patient Name Change^S Y=""
|
||||
;;05^1^Record Contains Patient ID Change^S Y=""
|
||||
;;05^^Statement Start Date^S Y=$$FDT^RCDPESR9(X)
|
||||
;;05^^Statement End Date^S Y=$$FDT^RCDPESR9(X)
|
||||
;
|
||||
10 ;;CLAIM STATUS DATA
|
||||
;;10^^Line Type^S Y=X_" (CLAIM LEVEL CLAIM STATUS DATA)"
|
||||
;;10^^Bill #
|
||||
;;10^^Claim Processed^S Y=$$YN^RCDPESR9(X)
|
||||
;;10^^Claim Denied^S Y=$$YN^RCDPESR9(X)
|
||||
;;10^^Claim Pended^S Y=$$YN^RCDPESR9(X)
|
||||
;;10^^Claim Reversal^S Y=$$YN^RCDPESR9(X)
|
||||
;;10^^Claim Status Code
|
||||
;;10^1^Crossed Over Name^S Y=""
|
||||
;;10^1^Crossed Over ID^S Y=""
|
||||
;;10^^Submitted Charge^S Y=$$ZERO^RCDPESR9(X,1)
|
||||
;;10^^Amount Paid^S Y=$$ZERO^RCDPESR9(X,1)
|
||||
;;10^^ICN
|
||||
;;10^^DRG Code Used
|
||||
;;10^^DRG Weight Used^S Y=$J($$ZERO^RCDPESR9(X,1)/100,4)
|
||||
;;10^^Discharge Fraction^S Y=$$ZERO^RCDPESR9(X,1)
|
||||
;;10^^Rendering NPI
|
||||
;;10^^Entity Type Qualifier
|
||||
;;10^^Last Name
|
||||
;;10^^First Name
|
||||
;
|
||||
15 ;;CLAIM STATUS DATA
|
||||
;;15^^Line Type^S Y=X_" (CLAIM LEVEL CLAIM STATUS DATA (CONTINUED))"
|
||||
;;15^^Bill #
|
||||
;;15^^Covered Amount^S Y=$$ZERO^RCDPESR9(X,1)
|
||||
;;15^1^Discount Amount^S Y=$$ZERO^RCDPESR9(X,1,1)
|
||||
;;15^1^Day Limit Amt^S Y=$$ZERO^RCDPESR9(X,1,1)
|
||||
;;15^1^Interest Amount^S Y=$$ZERO^RCDPESR9(X,1,1)
|
||||
;;15^1^Tax Amount^S Y=$$ZERO^RCDPESR9(X,1,1)
|
||||
;;15^1^Total Before Taxes Amt^S Y=$$ZERO^RCDPESR9(X,1,1)
|
||||
;;15^^Patient Responsibility Amount^S Y=$$ZERO^RCDPESR9(X,1)
|
||||
;;15^1^Negative Reimbursement^S Y=$$ZERO^RCDPESR9(X,1,1)
|
||||
;
|
||||
17 ;;CLAIM LEVEL PAYER CONTACT INFORMATION
|
||||
;;17^^Line Type^S Y=X_" (CLAIM LEVEL PAYER CONTACT INFO)"
|
||||
;;17^^Bill #
|
||||
;;17^^Contact Name
|
||||
;;17^^Contact #1
|
||||
;;17^^Contact #1 Type^S Y=$$EXTERNAL^DILFD(361.1,25.03,,X)
|
||||
;;17^^Contact #2
|
||||
;;17^^Contact #2 Type^S Y=$$EXTERNAL^DILFD(361.1,25.05,,X)
|
||||
;;17^^Contact #3
|
||||
;;17^^Contact #3 Type^S Y=$$EXTERNAL^DILFD(361.1,25.07,,X)
|
||||
;
|
||||
20 ;;CLAIM LEVEL ADJUSTMENT DATA
|
||||
;;20^^Line Type^S Y=X_" (CLAIM LEVEL CLAIM ADJUSTMENT DATA)"
|
||||
;;20^^Bill #
|
||||
;;20^^Adjustment Group Code
|
||||
;;20^^Adjustment Reason Code
|
||||
;;20^^Adjustment Amount^S Y=$$ZERO^RCDPESR9(X,1)
|
||||
;;20^^Quantity^S Y=$$ZERO^RCDPESR9(X)
|
||||
;;20^^Reason Code Text
|
||||
;
|
||||
30 ;;CLAIM LEVEL MEDICARE INPT ADJUDICATION DATA
|
||||
;;30^^Line Type^S Y=X_" (CLAIM LEVEL MEDICARE INPATIENT ADJUDICATION DATA)"
|
||||
;;30^^Bill #
|
||||
;;30^^Covered Days/Visits^S Y=$$ZERO^RCDPESR9(X)
|
||||
;;30^1^Lifetime Reserve Days Count^S Y=$$ZERO^RCDPESR9(X,,1)
|
||||
;;30^1^Lifetime Psych Days Count^S Y=$$ZERO^RCDPESR9(X,,1)
|
||||
;;30^^Claim DRG Amt^S Y=$$ZERO^RCDPESR9(X,1)
|
||||
;;30^1^Claim Disproportionate Share Amt^S Y=$$ZERO^RCDPESR9(X,1,1)
|
||||
;;30^1^Claim MSP Pass thru Amt^S Y=$$ZERO^RCDPESR9(X,1,1)
|
||||
;;30^1^Claim PPS Capital Amt^S Y=$$ZERO^RCDPESR9(X,1,1)
|
||||
;;30^1^PPS-Capital FSP DRG Amt^S Y=$$ZERO^RCDPESR9(X,1,1)
|
||||
;;30^1^PPS-Capital HSP DRG Amt^S Y=$$ZERO^RCDPESR9(X,1,1)
|
||||
;;30^1^PPS-Capital DSH DRG Amt^S Y=$$ZERO^RCDPESR9(X,1,1)
|
||||
;;30^1^Old Capital Amt^S Y=$$ZERO^RCDPESR9(X,1,1)
|
||||
;;30^^Non-Covered Days^S Y=$$ZERO^RCDPESR9(X)
|
||||
;
|
||||
35 ;;CLAIM LEVEL MEDICARE ADJUDICATION DATA
|
||||
;;35^^Line Type^S Y=X_" (CLAIM LEVEL MEDICARE ADJUDICATION DATA)"
|
||||
;;35^^Bill #
|
||||
;;35^1^PPS-Capital IME Amt^S Y=$$ZERO^RCDPESR9(X,1,1)
|
||||
;;35^1^PPS-Operating Hosp Specific DRG Amt^S Y=$$ZERO^RCDPESR9(X,1,1)
|
||||
;;35^1^Cost Report Day Count^S Y=$$ZERO^RCDPESR9(X)
|
||||
;;35^1^PPS-Operating Fed Specific DRG Amt^S Y=$$ZERO^RCDPESR9(X,1,1)
|
||||
;;35^1^Claim PPS Capital Outlier Amt^S Y=$$ZERO^RCDPESR9(X,1,1)
|
||||
;;35^1^Claim Indirect Teaching Amt^S Y=$$ZERO^RCDPESR9(X,1,1)
|
||||
;;35^1^Non-payable Professional Component Amt^S Y=$$ZERO^RCDPESR9(X,1,1)
|
||||
;;35^1^PPS-Capital Exception Amt^S Y=$$ZERO^RCDPESR9(X,1,1)
|
||||
;;35^1^Outpatient Reimbursement %^S Y=$$ZERO^RCDPESR9(X)
|
||||
;;35^1^HCPCS Payable Amount^S Y=$$ZERO^RCDPESR9(X,1,1)
|
||||
;;35^1^ESRD Paid Amount^S Y=$$ZERO^RCDPESR9(X,1,1)
|
||||
;;35^1^Non-payable Professional Component^S Y=$$ZERO^RCDPESR9(X,1,1)
|
||||
;
|
||||
37 ;;CLAIM LEVEL MEDICARE ADJUDICATION DATA REMARKS
|
||||
;;37^^Line Type^S Y=X_" (CLAIM LEVEL MEDICARE ADJUDICATION DATA REMARKS)"
|
||||
;;37^^Bill #
|
||||
;;37^^Type^S Y=$S(X="O":"MOA",X="I":"MIA",1:X)
|
||||
;;37^^Claim Payment Remark Code
|
||||
;;37^^Claim Payment Remark Code Message Text
|
||||
;
|
||||
40 ;;SERVICE LINE DATA
|
||||
;;40^^Line Type^S Y=X_" (CLAIM LEVEL SERVICE LINE DATA)"
|
||||
;;40^^Bill #
|
||||
;;40^^Procedure
|
||||
;;40^^Revenue Code
|
||||
;;40^^Modifier 1
|
||||
;;40^^Modifier 2
|
||||
;;40^^Modifier 3
|
||||
;;40^^Modifier 4
|
||||
;;40^^Description
|
||||
;;40^^Original Procedure
|
||||
;;40^^Original Modifier 1
|
||||
;;40^^Original Modifier 2
|
||||
;;40^^Original Modifier 3
|
||||
;;40^^Original Modifier 4
|
||||
;;40^^Original Charge^S Y=$$ZERO^RCDPESR9(X,1)
|
||||
;;40^^Original Units^S Y=$$ZERO^RCDPESR9(X,1)
|
||||
;;40^^Amount Paid^S Y=$$ZERO^RCDPESR9(X,1)
|
||||
;;40^^Covered Units^S Y=$$ZERO^RCDPESR9(X,1)
|
||||
;;40^^Service From Date^S Y=$$FDT^RCDPESR9(X)
|
||||
;;40^^Service To Date^S Y=$$FDT^RCDPESR9(X)
|
||||
;;40^^Procedure Type
|
||||
;;40^^Applies to Billing Line
|
||||
;
|
||||
41 ;;SERVICE LINE DATA
|
||||
;;41^^Line Type^S Y=X_" (CLAIM LEVEL SERVICE LINE DATA (CONTINUED))"
|
||||
;;41^^Bill #
|
||||
;;41^^Allowed Amount^S Y=$$ZERO^RCDPESR9(X,1)
|
||||
;;41^1^Per Diem Amount^S Y=$$ZERO^RCDPESR9(X,1,1)
|
||||
;
|
||||
42 ; SERVICE LINE DATA
|
||||
;;42^^Line Type^S Y=X_" (CLAIM LEVEL SERVICE LINE DATA (CONTINUED))"
|
||||
;;42^^Bill #
|
||||
;;42^^Line Item Remark Code
|
||||
;;42^^Line Item Remark Code Text
|
||||
;
|
||||
45 ;;SERVICE LINE ADJUSTMENT DATA
|
||||
;;45^^Line Type^S Y=X_" (CLAIM LEVEL SERVICE LINE ADJUSTMENT DATA)"
|
||||
;;45^^Bill #
|
||||
;;45^^Adjustment Group Code
|
||||
;;45^^Adjustment Reason Code
|
||||
;;45^^Adjustment Amount^S Y=$$ZERO^RCDPESR9(X,1)
|
||||
;;45^^Quantity^S Y=$$ZERO^RCDPESR9(X)
|
||||
;;45^^Reason Code Text
|
||||
;
|
||||
FDT(X) ; returns MM/DD/YYYY or MM/DD/YY from YYYYMMDD or YYMMDD in X
|
||||
I $L(X)=8,X?8N S X=$E(X,5,6)_"/"_$E(X,7,8)_"/"_$E(X,1,4)
|
||||
I $L(X)=6,X?6N S X=$E(X,3,4)_"/"_$E(X,5,6)_"/"_$E(X,1,2)
|
||||
Q X
|
||||
;
|
||||
ZERO(X,D,NULL) ; Returns numeric value of X without leading 0's
|
||||
; or null if no value wanted for 0 amount
|
||||
; D = 1 if dollar amt
|
||||
N Z
|
||||
I X["." S Z=$P(X,"."),X=+Z_"."_$P(X,".",2)
|
||||
I X'["." D
|
||||
. I $G(D) S X=+$E(X,1,$L(X)-2)_"."_$E(X,$L(X)-1,$L(X))
|
||||
. S X=$S('$G(D):+X,1:$J(X,"",2))
|
||||
Q $S(X:X,$G(NULL):"",1:X)
|
||||
;
|
||||
YN(X) ; Returns YES for X="Y" and NO for X="N"
|
||||
S X=$S(X="Y":"YES",X="N":"NO",1:X)
|
||||
Q X
|
||||
;
|
||||
RCDPESR9 ;ALB/TMK - ERA return file field captions ;09-SEP-2003
|
||||
;;4.5;Accounts Receivable;**173**;Mar 20, 1995
|
||||
;;Per VHA Directive 10-93-142, this routine should not be modified.
|
||||
;
|
||||
; Note: if the 835 flat file changes, make the corresponding changes
|
||||
; in this routine.
|
||||
835 ;;HEADER DATA
|
||||
;;835^^Return Message ID^S Y=X_" (ERA HEADER DATA)"
|
||||
;;835^^X12/Proprietary flag^S Y=$S(X="X":"X12",1:X)
|
||||
;;835^^File Date^S Y=$$FDT^RCDPESR9(X)
|
||||
;;835^^File Time^S Y=$E(X,1,2)-$S($E(X,1,2)>12:12,1:0)_":"_$E(X,3,4)_$S($E(X,1,2)=24:" AM",$E(X,1,2)>11:" PM",1:" AM")
|
||||
;;835^1^MRA^S Y=""
|
||||
;;835^^Payer Name
|
||||
;;835^^Payer ID
|
||||
;;835^^Trace Number
|
||||
;;835^^Date Claims Paid^S Y=$$FDT^RCDPESR9(X)
|
||||
;;835^^Total ERA Amount^S Y=$$ZERO^RCDPESR9(X,1)
|
||||
;;835^^Erroneous Provider Tax ID
|
||||
;;835^^Tax ID correction Flag^S Y=$S(X="E":"CHANGED BY EPHRA",X="C":"DETERMINED FROM CLAIM DATA",X="":"NO CHANGE MADE",1:X)
|
||||
;;835^^Sequence Control #
|
||||
;;835^^Sequence #
|
||||
;;835^^Last Sequence #
|
||||
;;835^^Contact Information
|
||||
;;835^^Payment Method Code
|
||||
;
|
||||
01 ;;PAYER CONTACT INFORMATION
|
||||
;;01^^ERA Contact Name
|
||||
;;01^^ERA Contact #1
|
||||
;;01^^ERA Contact #1 Type^S Y=$$EXTERNAL^DILFD(344.4,3.03,,X)
|
||||
;;01^^ERA Contact #2
|
||||
;;01^^ERA Contact #2 Type^S Y=$$EXTERNAL^DILFD(344.4,3.05,,X)
|
||||
;;01^^ERA Contact #3
|
||||
;;01^^ERA Contact #3 Type^S Y=$$EXTERNAL^DILFD(344.4,3.07,,X)
|
||||
;
|
||||
02 ;;PAYER ADJUSTMENT RECORD
|
||||
;;02^^Line Type^S Y=X_" (ERA LEVEL PAYER ADJUSTMENT RECORD)"
|
||||
;;02^^X12 Adjustment Reason Code
|
||||
;;02^^Provider Adjustment Identifier
|
||||
;;02^^Adjustment Amount^S Y=$$ZERO^RCDPESR9(X,1)
|
||||
;;02^^X12 Reason Text
|
||||
;
|
||||
05 ;;CLAIM PATIENT ID
|
||||
;;05^^Line Type^S Y=X_" (CLAIM LEVEL PATIENT ID DATA)"
|
||||
;;05^^Bill #
|
||||
;;05^^Patient Last Name
|
||||
;;05^^Patient First Name
|
||||
;;05^^Patient Middle Name
|
||||
;;05^^Patient ID #
|
||||
;;05^1^Record Contains Patient Name Change^S Y=""
|
||||
;;05^1^Record Contains Patient ID Change^S Y=""
|
||||
;;05^^Statement Start Date^S Y=$$FDT^RCDPESR9(X)
|
||||
;;05^^Statement End Date^S Y=$$FDT^RCDPESR9(X)
|
||||
;
|
||||
10 ;;CLAIM STATUS DATA
|
||||
;;10^^Line Type^S Y=X_" (CLAIM LEVEL CLAIM STATUS DATA)"
|
||||
;;10^^Bill #
|
||||
;;10^^Claim Processed^S Y=$$YN^RCDPESR9(X)
|
||||
;;10^^Claim Denied^S Y=$$YN^RCDPESR9(X)
|
||||
;;10^^Claim Pended^S Y=$$YN^RCDPESR9(X)
|
||||
;;10^^Claim Reversal^S Y=$$YN^RCDPESR9(X)
|
||||
;;10^^Claim Status Code
|
||||
;;10^1^Crossed Over Name^S Y=""
|
||||
;;10^1^Crossed Over ID^S Y=""
|
||||
;;10^^Submitted Charge^S Y=$$ZERO^RCDPESR9(X,1)
|
||||
;;10^^Amount Paid^S Y=$$ZERO^RCDPESR9(X,1)
|
||||
;;10^^ICN
|
||||
;;10^^DRG Code Used
|
||||
;;10^^DRG Weight Used^S Y=$J($$ZERO^RCDPESR9(X,1)/100,4)
|
||||
;;10^^Discharge Fraction^S Y=$$ZERO^RCDPESR9(X,1)
|
||||
;
|
||||
15 ;;CLAIM STATUS DATA
|
||||
;;15^^Line Type^S Y=X_" (CLAIM LEVEL CLAIM STATUS DATA (CONTINUED))"
|
||||
;;15^^Bill #
|
||||
;;15^^Covered Amount^S Y=$$ZERO^RCDPESR9(X,1)
|
||||
;;15^1^Discount Amount^S Y=$$ZERO^RCDPESR9(X,1,1)
|
||||
;;15^1^Day Limit Amt^S Y=$$ZERO^RCDPESR9(X,1,1)
|
||||
;;15^1^Interest Amount^S Y=$$ZERO^RCDPESR9(X,1,1)
|
||||
;;15^1^Tax Amount^S Y=$$ZERO^RCDPESR9(X,1,1)
|
||||
;;15^1^Total Before Taxes Amt^S Y=$$ZERO^RCDPESR9(X,1,1)
|
||||
;;15^^Patient Responsibility Amount^S Y=$$ZERO^RCDPESR9(X,1)
|
||||
;;15^1^Negative Reimbursement^S Y=$$ZERO^RCDPESR9(X,1,1)
|
||||
;
|
||||
17 ;;CLAIM LEVEL PAYER CONTACT INFORMATION
|
||||
;;17^^Line Type^S Y=X_" (CLAIM LEVEL PAYER CONTACT INFO)"
|
||||
;;17^^Bill #
|
||||
;;17^^Contact Name
|
||||
;;17^^Contact #1
|
||||
;;17^^Contact #1 Type^S Y=$$EXTERNAL^DILFD(361.1,25.03,,X)
|
||||
;;17^^Contact #2
|
||||
;;17^^Contact #2 Type^S Y=$$EXTERNAL^DILFD(361.1,25.05,,X)
|
||||
;;17^^Contact #3
|
||||
;;17^^Contact #3 Type^S Y=$$EXTERNAL^DILFD(361.1,25.07,,X)
|
||||
;
|
||||
20 ;;CLAIM LEVEL ADJUSTMENT DATA
|
||||
;;20^^Line Type^S Y=X_" (CLAIM LEVEL CLAIM ADJUSTMENT DATA)"
|
||||
;;20^^Bill #
|
||||
;;20^^Adjustment Group Code
|
||||
;;20^^Adjustment Reason Code
|
||||
;;20^^Adjustment Amount^S Y=$$ZERO^RCDPESR9(X,1)
|
||||
;;20^^Quantity^S Y=$$ZERO^RCDPESR9(X)
|
||||
;;20^^Reason Code Text
|
||||
;
|
||||
30 ;;CLAIM LEVEL MEDICARE INPT ADJUDICATION DATA
|
||||
;;30^^Line Type^S Y=X_" (CLAIM LEVEL MEDICARE INPATIENT ADJUDICATION DATA)"
|
||||
;;30^^Bill #
|
||||
;;30^^Covered Days/Visits^S Y=$$ZERO^RCDPESR9(X)
|
||||
;;30^1^Lifetime Reserve Days Count^S Y=$$ZERO^RCDPESR9(X,,1)
|
||||
;;30^1^Lifetime Psych Days Count^S Y=$$ZERO^RCDPESR9(X,,1)
|
||||
;;30^^Claim DRG Amt^S Y=$$ZERO^RCDPESR9(X,1)
|
||||
;;30^1^Claim Disproportionate Share Amt^S Y=$$ZERO^RCDPESR9(X,1,1)
|
||||
;;30^1^Claim MSP Pass thru Amt^S Y=$$ZERO^RCDPESR9(X,1,1)
|
||||
;;30^1^Claim PPS Capital Amt^S Y=$$ZERO^RCDPESR9(X,1,1)
|
||||
;;30^1^PPS-Capital FSP DRG Amt^S Y=$$ZERO^RCDPESR9(X,1,1)
|
||||
;;30^1^PPS-Capital HSP DRG Amt^S Y=$$ZERO^RCDPESR9(X,1,1)
|
||||
;;30^1^PPS-Capital DSH DRG Amt^S Y=$$ZERO^RCDPESR9(X,1,1)
|
||||
;;30^1^Old Capital Amt^S Y=$$ZERO^RCDPESR9(X,1,1)
|
||||
;;30^^Non-Covered Days^S Y=$$ZERO^RCDPESR9(X)
|
||||
;
|
||||
35 ;;CLAIM LEVEL MEDICARE ADJUDICATION DATA
|
||||
;;35^^Line Type^S Y=X_" (CLAIM LEVEL MEDICARE ADJUDICATION DATA)"
|
||||
;;35^^Bill #
|
||||
;;35^1^PPS-Capital IME Amt^S Y=$$ZERO^RCDPESR9(X,1,1)
|
||||
;;35^1^PPS-Operating Hosp Specific DRG Amt^S Y=$$ZERO^RCDPESR9(X,1,1)
|
||||
;;35^1^Cost Report Day Count^S Y=$$ZERO^RCDPESR9(X)
|
||||
;;35^1^PPS-Operating Fed Specific DRG Amt^S Y=$$ZERO^RCDPESR9(X,1,1)
|
||||
;;35^1^Claim PPS Capital Outlier Amt^S Y=$$ZERO^RCDPESR9(X,1,1)
|
||||
;;35^1^Claim Indirect Teaching Amt^S Y=$$ZERO^RCDPESR9(X,1,1)
|
||||
;;35^1^Non-payable Professional Component Amt^S Y=$$ZERO^RCDPESR9(X,1,1)
|
||||
;;35^1^PPS-Capital Exception Amt^S Y=$$ZERO^RCDPESR9(X,1,1)
|
||||
;;35^1^Outpatient Reimbursement %^S Y=$$ZERO^RCDPESR9(X)
|
||||
;;35^1^HCPCS Payable Amount^S Y=$$ZERO^RCDPESR9(X,1,1)
|
||||
;;35^1^ESRD Paid Amount^S Y=$$ZERO^RCDPESR9(X,1,1)
|
||||
;;35^1^Non-payable Professional Component^S Y=$$ZERO^RCDPESR9(X,1,1)
|
||||
;
|
||||
37 ;;CLAIM LEVEL MEDICARE ADJUDICATION DATA REMARKS
|
||||
;;37^^Line Type^S Y=X_" (CLAIM LEVEL MEDICARE ADJUDICATION DATA REMARKS)"
|
||||
;;37^^Bill #
|
||||
;;37^^Type^S Y=$S(X="O":"MOA",X="I":"MIA",1:X)
|
||||
;;37^^Claim Payment Remark Code
|
||||
;;37^^Claim Payment Remark Code Message Text
|
||||
;
|
||||
40 ;;SERVICE LINE DATA
|
||||
;;40^^Line Type^S Y=X_" (CLAIM LEVEL SERVICE LINE DATA)"
|
||||
;;40^^Bill #
|
||||
;;40^^Procedure
|
||||
;;40^^Revenue Code
|
||||
;;40^^Modifier 1
|
||||
;;40^^Modifier 2
|
||||
;;40^^Modifier 3
|
||||
;;40^^Modifier 4
|
||||
;;40^^Description
|
||||
;;40^^Original Procedure
|
||||
;;40^^Original Modifier 1
|
||||
;;40^^Original Modifier 2
|
||||
;;40^^Original Modifier 3
|
||||
;;40^^Original Modifier 4
|
||||
;;40^^Original Charge^S Y=$$ZERO^RCDPESR9(X,1)
|
||||
;;40^^Original Units^S Y=$$ZERO^RCDPESR9(X,1)
|
||||
;;40^^Amount Paid^S Y=$$ZERO^RCDPESR9(X,1)
|
||||
;;40^^Covered Units^S Y=$$ZERO^RCDPESR9(X,1)
|
||||
;;40^^Service From Date^S Y=$$FDT^RCDPESR9(X)
|
||||
;;40^^Service To Date^S Y=$$FDT^RCDPESR9(X)
|
||||
;;40^^Procedure Type
|
||||
;;40^^Applies to Billing Line
|
||||
;
|
||||
41 ;;SERVICE LINE DATA
|
||||
;;41^^Line Type^S Y=X_" (CLAIM LEVEL SERVICE LINE DATA (CONTINUED))"
|
||||
;;41^^Bill #
|
||||
;;41^^Allowed Amount^S Y=$$ZERO^RCDPESR9(X,1)
|
||||
;;41^1^Per Diem Amount^S Y=$$ZERO^RCDPESR9(X,1,1)
|
||||
;
|
||||
42 ; SERVICE LINE DATA
|
||||
;;42^^Line Type^S Y=X_" (CLAIM LEVEL SERVICE LINE DATA (CONTINUED))"
|
||||
;;42^^Bill #
|
||||
;;42^^Line Item Remark Code
|
||||
;;42^^Line Item Remark Code Text
|
||||
;
|
||||
45 ;;SERVICE LINE ADJUSTMENT DATA
|
||||
;;45^^Line Type^S Y=X_" (CLAIM LEVEL SERVICE LINE ADJUSTMENT DATA)"
|
||||
;;45^^Bill #
|
||||
;;45^^Adjustment Group Code
|
||||
;;45^^Adjustment Reason Code
|
||||
;;45^^Adjustment Amount^S Y=$$ZERO^RCDPESR9(X,1)
|
||||
;;45^^Quantity^S Y=$$ZERO^RCDPESR9(X)
|
||||
;;45^^Reason Code Text
|
||||
;
|
||||
FDT(X) ; returns MM/DD/YYYY or MM/DD/YY from YYYYMMDD or YYMMDD in X
|
||||
I $L(X)=8,X?8N S X=$E(X,5,6)_"/"_$E(X,7,8)_"/"_$E(X,1,4)
|
||||
I $L(X)=6,X?6N S X=$E(X,3,4)_"/"_$E(X,5,6)_"/"_$E(X,1,2)
|
||||
Q X
|
||||
;
|
||||
ZERO(X,D,NULL) ; Returns numeric value of X without leading 0's
|
||||
; or null if no value wanted for 0 amount
|
||||
; D = 1 if dollar amt
|
||||
N Z
|
||||
I X["." S Z=$P(X,"."),X=+Z_"."_$P(X,".",2)
|
||||
I X'["." D
|
||||
. I $G(D) S X=+$E(X,1,$L(X)-2)_"."_$E(X,$L(X)-1,$L(X))
|
||||
. S X=$S('$G(D):+X,1:$J(X,"",2))
|
||||
Q $S(X:X,$G(NULL):"",1:X)
|
||||
;
|
||||
YN(X) ; Returns YES for X="Y" and NO for X="N"
|
||||
S X=$S(X="Y":"YES",X="N":"NO",1:X)
|
||||
Q X
|
||||
;
|
||||
|
|
|
|||
|
|
@ -1,214 +1,212 @@
|
|||
RCDPEWL0 ;ALB/TMK - ELECTRONIC EOB WORKLIST ACTIONS ;06 Jun 2007 11:50 AM
|
||||
;;4.5;Accounts Receivable;**173,208,252**;Mar 20, 1995;Build 63
|
||||
;;Per VHA Directive 2004-038, this routine should not be modified.
|
||||
Q
|
||||
;
|
||||
PARAMS ; Select params for ERA list
|
||||
; Return ^TMP("RCERA_PARAMS",$J) array
|
||||
N DIR,X,Y,RCDFR,RCDTO,RCPAYR,RCQUIT,DUOUT,DTOUT
|
||||
K ^TMP("RCERA_PARAMS",$J)
|
||||
S RCQUIT=0
|
||||
W !!,"SELECT PARAMETERS FOR DISPLAYING THE LIST OF ERAs"
|
||||
S DIR(0)="SA^U:UNPOSTED;P:POSTED;B:BOTH",DIR("B")="UNPOSTED",DIR("A")="ERA POSTING STATUS: " W ! D ^DIR K DIR
|
||||
I $D(DTOUT)!$D(DUOUT) S RCQUIT=1 G PARAMSQ
|
||||
S ^TMP("RCERA_PARAMS",$J,"RCPOST")=Y
|
||||
S DIR(0)="SA^N:NOT MATCHED;M:MATCHED;B:BOTH",DIR("B")="BOTH",DIR("A")="ERA-EFT MATCH STATUS: " W ! D ^DIR K DIR
|
||||
I $D(DTOUT)!$D(DUOUT) S RCQUIT=1 G PARAMSQ
|
||||
S ^TMP("RCERA_PARAMS",$J,"RCMATCH")=Y
|
||||
;
|
||||
DT1 S RCDTO=DT,RCDFR=0
|
||||
S RCQUIT=0,DIR(0)="YA",DIR("A")="LIMIT THE SELECTION TO A DATE RANGE WHEN THE ERA WAS RECEIVED?: ",DIR("B")="NO" W ! D ^DIR K DIR
|
||||
I $D(DTOUT)!$D(DUOUT) S RCQUIT=1 G PARAMSQ
|
||||
I Y=1 S RCQUIT=0 D I RCQUIT K ^TMP("RCERA_PARAMS",$J,"RCDT") G DT1
|
||||
. S DIR(0)="DA",DIR("A")="EARLIEST DATE: " D ^DIR K DIR
|
||||
. I $D(DTOUT)!$D(DUOUT) S RCQUIT=1 Q
|
||||
. S RCDFR=Y
|
||||
. S DIR(0)="DA^"_RCDFR_";"_DT,DIR("A")="LATEST DATE: " D ^DIR K DIR
|
||||
. I $D(DTOUT)!$D(DUOUT) S RCQUIT=1 Q
|
||||
. S RCDTO=Y
|
||||
S ^TMP("RCERA_PARAMS",$J,"RCDT")=(RCDFR_U_RCDTO)
|
||||
;
|
||||
PAYR S RCQUIT=0,DIR(0)="SA^A:ALL;R:RANGE",DIR("A")="(A)LL PAYERS, (R)ANGE OF PAYER NAMES: ",DIR("B")="ALL" W ! D ^DIR K DIR
|
||||
I $D(DTOUT)!$D(DUOUT) S RCQUIT=1 G PARAMSQ
|
||||
S RCPAYR=Y,^TMP("RCERA_PARAMS",$J,"RCPAYR")=Y
|
||||
I RCPAYR="A" G PARAMSQ
|
||||
I RCPAYR="R" D I RCQUIT K ^TMP("RCERA_PARAMS",$J,"RCPAYR") G PAYR
|
||||
. W !,"NAMES YOU SELECT HERE WILL BE THE PAYER NAMES FROM THE ERA, NOT THE INS FILE"
|
||||
. S DIR("?")="ENTER A NAME BETWEEN 1 AND 30 CHARACTERS IN UPPERCASE"
|
||||
. S DIR(0)="FA^1:30^K:X'?.U X",DIR("A")="START WITH PAYER NAME: " W ! D ^DIR K DIR
|
||||
. I $D(DTOUT)!$D(DUOUT) S RCQUIT=1 Q
|
||||
. S RCPAYR("FROM")=Y,$P(^TMP("RCERA_PARAMS",$J,"RCPAYR"),U,2)=Y
|
||||
. S DIR("?")="ENTER A NAME BETWEEN 1 AND 30 CHARACTERS IN UPPERCASE"
|
||||
. S DIR(0)="FA^1:30^K:X'?.U X",DIR("A")="GO TO PAYER NAME: ",DIR("B")=$E(RCPAYR("FROM"),1,27)_"ZZZ" W ! D ^DIR K DIR
|
||||
. I $D(DTOUT)!$D(DUOUT) S RCQUIT=1 Q
|
||||
. S $P(^TMP("RCERA_PARAMS",$J,"RCPAYR"),U,3)=Y
|
||||
W !
|
||||
;
|
||||
PARAMSQ ;
|
||||
D PARAMS^RCDPEWLD(.RCQUIT)
|
||||
Q
|
||||
;
|
||||
FILTER(Y) ; Returns 1 if record in entry Y in 344.4 passes
|
||||
; the edits for the worklist selection of ERAs
|
||||
; Parameters found in ^TMP("RCERA_PARAMS",$J)
|
||||
N OK,RCPOST,RCMATCH,RCDFR,RCDTO,RCPAYFR,RCPAYTO,RCPAYR,RC0
|
||||
S OK=1,RC0=$G(^RCY(344.4,Y,0))
|
||||
;
|
||||
S RCMATCH=$G(^TMP("RCERA_PARAMS",$J,"RCMATCH")),RCPOST=$G(^TMP("RCERA_PARAMS",$J,"RCPOST"))
|
||||
S RCDFR=+$P($G(^TMP("RCERA_PARAMS",$J,"RCDT")),U),RCDTO=+$P($G(^TMP("RCERA_PARAMS",$J,"RCDT")),U,2)
|
||||
S RCPAYR=$P($G(^TMP("RCERA_PARAMS",$J,"RCPAYR")),U),RCPAYFR=$P($G(^TMP("RCERA_PARAMS",$J,"RCPAYR")),U,2),RCPAYTO=$P($G(^TMP("RCERA_PARAMS",$J,"RCPAYR")),U,3)
|
||||
;
|
||||
; If receipt exists, scratchpad must exist
|
||||
;I $P(RC0,U,8),'$D(^RCY(344.49,+Y,0)) S OK=0 G FQ
|
||||
; Post status
|
||||
I $S(RCPOST="B":0,RCPOST="U":$P(RC0,U,14),1:'$P(RC0,U,14)) S OK=0 G FQ
|
||||
; Match status
|
||||
I $S(RCMATCH="B":0,RCMATCH="N":$P(RC0,U,9),1:'$P(RC0,U,9)) S OK=0 G FQ
|
||||
; dt rec'd range
|
||||
I $S(RCDFR=0:0,1:$P(RC0,U,7)\1<RCDFR) S OK=0 G FQ
|
||||
I $S(RCDTO=DT:0,1:$P(RC0,U,7)\1>RCDTO) S OK=0 G FQ
|
||||
; Payer name
|
||||
I RCPAYR'="A" D G:'OK FQ
|
||||
. N Q
|
||||
. S Q=$$UPPER^RCDPEWL7($P(RC0,U,6))
|
||||
. I $S(Q=RCPAYFR:1,Q=RCPAYTO:1,Q]RCPAYFR:RCPAYTO]Q,1:0) Q
|
||||
. S OK=0
|
||||
FQ Q OK
|
||||
;
|
||||
SPLIT ; Split line in ERA list
|
||||
N RCLINE,RCZ,RCDA,Q,Q0,Z,Z0,DIR,X,Y,CT,L,L1,RCONE,RCQUIT
|
||||
D FULL^VALM1
|
||||
I $G(RCSCR("NOEDIT")) D NOEDIT^RCDPEWL G SPLITQ
|
||||
W !!,"SELECT THE ENTRY THAT HAS A LINE YOU NEED TO SPLIT/EDIT",!
|
||||
D SEL^RCDPEWL(.RCDA)
|
||||
S Z=+$O(RCDA(0)) G:'$G(RCDA(Z)) SPLITQ
|
||||
S RCLINE=+RCDA(Z),Z0=+$O(^TMP("RCDPE-EOB_WLDX",$J,Z_".999"),-1)
|
||||
S RCZ=Z F S RCZ=$O(^TMP("RCDPE-EOB_WLDX",$J,RCZ)) Q:'RCZ!(RCZ\1'=Z) D
|
||||
. S Q=$P($G(^TMP("RCDPE-EOB_WLDX",$J,RCZ)),U,2)
|
||||
. Q:'Q
|
||||
. S RCZ(RCZ)=Q
|
||||
. S Q0=0 F S Q0=$O(^RCY(344.49,RCSCR,1,Q,1,Q0)) Q:'Q0 I "01"[$P($G(^(Q0,0)),U,2) K RCZ(RCZ) Q
|
||||
I '$O(RCZ(0)) D G SPLITQ
|
||||
. S DIR(0)="EA",DIR("A",1)="THIS ENTRY HAS NO LINES AVAILABLE TO EDIT/SPLIT",DIR("A")="PRESS RETURN TO CONTINUE " W ! D ^DIR K DIR
|
||||
S RCQUIT=0
|
||||
I $P($G(^RCY(344.49,RCSCR,1,RCLINE,0)),U,13) D G:RCQUIT SPLITQ
|
||||
. S DIR("A",1)="WARNING! THIS LINE HAS ALREADY BEEN VERIFIED",DIR("A")="ARE YOU SURE YOU WANT TO CONTINUE?: ",DIR(0)="YA",DIR("B")="NO" W ! D ^DIR K DIR
|
||||
. I Y'=1 S RCQUIT=1
|
||||
S CT=0,CT=CT+1,DIR("?",CT)="Enter the line # that you want to split or edit:",RCONE=1
|
||||
S L=Z F S L=$O(RCZ(L)) Q:'L D
|
||||
. S L1=+$G(^TMP("RCDPE-EOB_WLDX",$J,L))
|
||||
. S CT=CT+1
|
||||
. S DIR("?",CT)=$G(^TMP("RCDPE-EOB_WL",$J,L1,0)),CT=CT+1,DIR("?",CT)=$G(^TMP("RCDPE-EOB_WL",$J,L1+1,0)) S RCONE(1)=$S(RCONE:L,1:"") S RCONE=0
|
||||
S DIR("?")=" ",Y=-1
|
||||
I $G(RCONE(1)) S Y=+RCONE(1) K DIR G:'Y SPLITQ
|
||||
I '$G(RCONE(1)) D K DIR I $D(DTOUT)!$D(DUOUT)!(Y\1'=Z) G SPLITQ
|
||||
. F S DIR(0)="NAO^"_(Z+.001)_":"_Z0_":3",DIR("A")="WHICH LINE OF ENTRY "_Z_" DO YOU WANT TO SPLIT/EDIT?: " S:$G(RCONE(1))'="" DIR("B")=RCONE(1) D ^DIR Q:'Y!$D(DUOUT)!$D(DTOUT) D Q:Y>0
|
||||
.. I '$D(^TMP("RCDPE-EOB_WLDX",$J,Y)) W !!,"LINE "_Y_" DOES NOT EXIST - TRY AGAIN",! S Y=-1 Q
|
||||
.. I '$D(RCZ(Y)) W !!,"LINE "_Y_" HAS BEEN USED IN A DISTRIBUTE ADJ ACTION AND CAN'T BE EDITED",! S Y=-1 Q
|
||||
.. S Q=+$O(^RCY(344.49,RCSCR,1,"B",Y,0))
|
||||
;
|
||||
K ^TMP("RCDPE_SPLIT_REBLD",$J)
|
||||
D SPLIT^RCDPEWL3(RCSCR,+Y)
|
||||
I $G(^TMP("RCDPE_SPLIT_REBLD",$J)) K ^TMP("RCDPE_SPLIT_REBLD",$J) D BLD^RCDPEWL1($G(^TMP($J,"RC_SORTPARM")))
|
||||
;
|
||||
SPLITQ S VALMBCK="R"
|
||||
Q
|
||||
;
|
||||
PRTERA ; View/prt
|
||||
N DIC,X,Y,RCSCR
|
||||
S DIC="^RCY(344.4,",DIC(0)="AEMQ" D ^DIC
|
||||
Q:Y'>0
|
||||
S RCSCR=+Y
|
||||
D PRERA1
|
||||
Q
|
||||
;
|
||||
PRERA ; RCSCR is assumed to be defined
|
||||
D FULL^VALM1 ; Protocol entry
|
||||
PRERA1 ; Option entry
|
||||
N %ZIS,ZTRTN,ZTSAVE,ZTDESC,POP,DIR,X,Y,RCERADET
|
||||
S DIR("?",1)="INCLUDING EXPANDED DETAIL WILL SIGNIFICANTLY INCREASE THE SIZE OF THIS REPORT",DIR("?",2)="IF YOU CHOOSE TO INCLUDE IT, ALL PAYMENT DETAILS FOR EACH EEOB WILL BE"
|
||||
S DIR("?")="LISTED. IF YOU WANT JUST SUMMARY DATA FOR EACH EEOB, DO NOT INCLUDE IT."
|
||||
S DIR(0)="YA",DIR("A")="DO YOU WANT TO INCLUDE EXPANDED EEOB DETAIL?: ",DIR("B")="NO" W ! D ^DIR K DIR
|
||||
I $D(DUOUT)!$D(DTOUT) G PRERAQ
|
||||
S RCERADET=+Y
|
||||
S %ZIS="QM" D ^%ZIS G:POP PRERAQ
|
||||
I $D(IO("Q")) D G PRERAQ
|
||||
. S ZTRTN="VPERA^RCDPEWL0("_RCSCR_","_RCERADET_")",ZTDESC="AR - Print ERA From Worklist"
|
||||
. D ^%ZTLOAD
|
||||
. W !!,$S($D(ZTSK):"Your task # "_ZTSK_" has been queued.",1:"Unable to queue this job.")
|
||||
. K ZTSK,IO("Q") D HOME^%ZIS
|
||||
U IO
|
||||
D VPERA(RCSCR,RCERADET)
|
||||
Q
|
||||
;
|
||||
VPERA(RCSCR,RCERADET) ; Queued entry
|
||||
; RCSCR = ien of entry in file 344.4
|
||||
; RCERADET = 1 if inclusion of all EOB details from file 361.1 is
|
||||
; desired, 0 if not
|
||||
N Z,Z0,RCSTOP,RCZ,RCPG,RCDOT,RCDIQ,RCDIQ1,RCDIQ2,RCXM1,RC,RCSCR1,RC3611
|
||||
K ^TMP($J,"RC_SUMRAW"),^TMP($J,"RC_SUMOUT"),^TMP($J,"RC_SUMALL")
|
||||
S (RCSTOP,RCPG)=0,RCDOT="",$P(RCDOT,".",79)=""
|
||||
D GETS^DIQ(344.4,RCSCR_",","*","IEN","RCDIQ")
|
||||
D TXT0^RCDPEX31(RCSCR,.RCDIQ,.RCXM1,.RC) ; Get top level 0-node captioned flds
|
||||
I $O(^RCY(344.4,RCSCR,2,0)) S RC=RC+1,RCXM1(RC)=" **ERA LEVEL ADJUSTMENTS**"
|
||||
S RCSCR1=0 F S RCSCR1=$O(^RCY(344.4,RCSCR,2,RCSCR1)) Q:'RCSCR1 D
|
||||
. K RCDIQ2
|
||||
. D GETS^DIQ(344.42,RCSCR1_","_RCSCR_",","*","IEN","RCDIQ2")
|
||||
. D TXT2^RCDPEX31(RCSCR,RCSCR1,.RCDIQ2,.RCXM1,.RC) ; Get top level ERA adjs
|
||||
S RCSCR1=0 F S RCSCR1=$O(^RCY(344.4,RCSCR,1,RCSCR1)) Q:'RCSCR1 D
|
||||
. K RCDIQ1
|
||||
. D GETS^DIQ(344.41,RCSCR1_","_RCSCR_",","*","IEN","RCDIQ1")
|
||||
. D TXT00^RCDPEX31(RCSCR,RCSCR1,.RCDIQ1,.RCXM1,.RC)
|
||||
. S RC=RC+1,RCXM1(RC-1)=$E("PATIENT: "_$$PNM4^RCDPEWL1(RCSCR,RCSCR1)_$J("",41),1,41)_"CLAIM #: "_$$BILLREF^RCDPESR0(RCSCR,RCSCR1),RCXM1(RC)=" "
|
||||
. D PROV^RCDPEWLD(RCSCR,RCSCR1,.RCXM1,.RC)
|
||||
. S RC3611=$P($G(^RCY(344.4,RCSCR,1,RCSCR1,0)),U,2)
|
||||
. I RCERADET D
|
||||
.. I 'RC3611 D Q
|
||||
... D DISP^RCDPESR0("^RCY(344.4,"_RCSCR_",1,"_RCSCR1_",1)","^TMP($J,""RC_SUMRAW"")",1,"^TMP($J,""RC_SUMOUT"")",75,1)
|
||||
..;
|
||||
.. E D ; Detail record is in 361.1
|
||||
... K ^TMP("PRCA_EOB",$J)
|
||||
... D GETEOB^IBCECSA6(RC3611,2)
|
||||
... I $O(^IBM(361.1,RC3611,"ERR",0)) D GETERR^RCDPEDS(RC3611,+$O(^TMP("PRCA_EOB",$J,RC3611," "),-1)) ; get filing errors
|
||||
... S Z=0 F S Z=$O(^TMP("PRCA_EOB",$J,RC3611,Z)) Q:'Z S RC=RC+1,^TMP($J,"RC_SUMOUT",RC)=$G(^TMP("PRCA_EOB",$J,RC3611,Z))
|
||||
... S RC=RC+2,^TMP($J,"RC_SUMOUT",RC-1)=" ",^TMP($J,"RC_SUMOUT",RC)=" "
|
||||
... K ^TMP("PRCA_EOB",$J)
|
||||
. I $D(RCDIQ1(344.41,RCSCR1_","_RCSCR_",",2)) D
|
||||
.. S RC=RC+1,RCXM1(RC)=" **EXCEPTION RESOLUTION LOG DATA**"
|
||||
.. S Z=0 F S Z=$O(RCDIQ1(344.41,RCSCR1_","_RCSCR_",",2,Z)) Q:'Z S RC=RC+1,RCXM1(RC)=RCDIQ1(344.41,RCSCR1_","_RCSCR_",",2,Z)
|
||||
. S RC=RC+1,RCXM1(RC)=" "
|
||||
. S Z0=+$O(^TMP($J,"RC_SUMALL"," "),-1)
|
||||
. S Z=0 F S Z=$O(RCXM1(Z)) Q:'Z S Z0=Z0+1,^TMP($J,"RC_SUMALL",Z0)=RCXM1(Z)
|
||||
. K RCXM1 S RC=0
|
||||
. S Z=0 F S Z=$O(^TMP($J,"RC_SUMOUT",Z)) Q:'Z S Z0=Z0+1,^TMP($J,"RC_SUMALL",Z0)=$G(^TMP($J,"RC_SUMOUT",Z))
|
||||
S RCSTOP=0,Z=""
|
||||
F S Z=$O(^TMP($J,"RC_SUMALL",Z)) Q:'Z D Q:RCSTOP
|
||||
. I $D(ZTQUEUED),$$S^%ZTLOAD S (RCSTOP,ZTSTOP)=1 K ZTREQ I +$G(RCPG) W !!,"***TASK STOPPED BY USER***" Q
|
||||
. I 'RCPG!(($Y+5)>IOSL) D I RCSTOP Q
|
||||
.. D:RCPG ASK(.RCSTOP) I RCSTOP Q
|
||||
.. D HDR(.RCPG)
|
||||
. W !,$G(^TMP($J,"RC_SUMALL",Z))
|
||||
;
|
||||
I 'RCSTOP,RCPG D ASK(.RCSTOP)
|
||||
;
|
||||
I $D(ZTQUEUED) S ZTREQ="@"
|
||||
I '$D(ZTQUEUED) D ^%ZISC
|
||||
;
|
||||
PRERAQ K ^TMP($J,"RC_SUMRAW"),^TMP($J,"RC_SUMOUT"),^TMP($J,"SUMALL")
|
||||
S VALMBCK="R"
|
||||
Q
|
||||
;
|
||||
HDR(RCPG) ;Report hdr
|
||||
; RCPG = last page #
|
||||
I RCPG!($E(IOST,1,2)="C-") W @IOF,*13
|
||||
S RCPG=$G(RCPG)+1
|
||||
W !,?5,"EDI LOCKBOX WORKLIST - ERA DETAIL",?55,$$FMTE^XLFDT(DT,2),?70,"Page: ",RCPG,!,$TR($J("",IOM)," ","=")
|
||||
Q
|
||||
;
|
||||
ASK(RCSTOP) ;
|
||||
I $E(IOST,1,2)'["C-" Q
|
||||
N DIR,DIROUT,DIRUT,DTOUT,DUOUT
|
||||
S DIR(0)="E" W ! D ^DIR
|
||||
I ($D(DIRUT))!($D(DUOUT)) S RCSTOP=1 Q
|
||||
Q
|
||||
;
|
||||
RCDPEWL0 ;ALB/TMK - ELECTRONIC EOB WORKLIST ACTIONS ;26-NOV-02
|
||||
;;4.5;Accounts Receivable;**173,208**;Mar 20, 1995
|
||||
;;Per VHA Directive 10-93-142, this routine should not be modified.
|
||||
Q
|
||||
;
|
||||
PARAMS ; Select params for ERA list
|
||||
; Return ^TMP("RCERA_PARAMS",$J) array
|
||||
N DIR,X,Y,RCDFR,RCDTO,RCPAYR,RCQUIT
|
||||
K ^TMP("RCERA_PARAMS",$J)
|
||||
S RCQUIT=0
|
||||
W !!,"SELECT PARAMETERS FOR DISPLAYING THE LIST OF ERAs"
|
||||
S DIR(0)="SA^U:UNPOSTED;P:POSTED;B:BOTH",DIR("B")="UNPOSTED",DIR("A")="ERA POSTING STATUS: " W ! D ^DIR K DIR
|
||||
I $D(DTOUT)!$D(DUOUT) S RCQUIT=1 G PARAMSQ
|
||||
S ^TMP("RCERA_PARAMS",$J,"RCPOST")=Y
|
||||
S DIR(0)="SA^N:NOT MATCHED;M:MATCHED;B:BOTH",DIR("B")="BOTH",DIR("A")="ERA-EFT MATCH STATUS: " W ! D ^DIR K DIR
|
||||
I $D(DTOUT)!$D(DUOUT) S RCQUIT=1 G PARAMSQ
|
||||
S ^TMP("RCERA_PARAMS",$J,"RCMATCH")=Y
|
||||
;
|
||||
DT1 S RCDTO=DT,RCDFR=0
|
||||
S RCQUIT=0,DIR(0)="YA",DIR("A")="LIMIT THE SELECTION TO A DATE RANGE WHEN THE ERA WAS RECEIVED?: ",DIR("B")="NO" W ! D ^DIR K DIR
|
||||
I $D(DTOUT)!$D(DUOUT) S RCQUIT=1 G PARAMSQ
|
||||
I Y=1 S RCQUIT=0 D I RCQUIT K ^TMP("RCERA_PARAMS",$J,"RCDT") G DT1
|
||||
. S DIR(0)="DA",DIR("A")="EARLIEST DATE: " D ^DIR K DIR
|
||||
. I $D(DTOUT)!$D(DUOUT) S RCQUIT=1 Q
|
||||
. S RCDFR=Y
|
||||
. S DIR(0)="DA^"_RCDFR_";"_DT,DIR("A")="LATEST DATE: " D ^DIR K DIR
|
||||
. I $D(DTOUT)!$D(DUOUT) S RCQUIT=1 Q
|
||||
. S RCDTO=Y
|
||||
S ^TMP("RCERA_PARAMS",$J,"RCDT")=(RCDFR_U_RCDTO)
|
||||
;
|
||||
PAYR S RCQUIT=0,DIR(0)="SA^A:ALL;R:RANGE",DIR("A")="(A)LL PAYERS, (R)ANGE OF PAYER NAMES: ",DIR("B")="ALL" W ! D ^DIR K DIR
|
||||
I $D(DTOUT)!$D(DUOUT) S RCQUIT=1 G PARAMSQ
|
||||
S RCPAYR=Y,^TMP("RCERA_PARAMS",$J,"RCPAYR")=Y
|
||||
I RCPAYR="A" G PARAMSQ
|
||||
I RCPAYR="R" D I RCQUIT K ^TMP("RCERA_PARAMS",$J,"RCPAYR") G PAYR
|
||||
. W !,"NAMES YOU SELECT HERE WILL BE THE PAYER NAMES FROM THE ERA, NOT THE INS FILE"
|
||||
. S DIR("?")="ENTER A NAME BETWEEN 1 AND 30 CHARACTERS IN UPPERCASE"
|
||||
. S DIR(0)="FA^1:30^K:X'?.U X",DIR("A")="START WITH PAYER NAME: " W ! D ^DIR K DIR
|
||||
. I $D(DTOUT)!$D(DUOUT) S RCQUIT=1 Q
|
||||
. S RCPAYR("FROM")=Y,$P(^TMP("RCERA_PARAMS",$J,"RCPAYR"),U,2)=Y
|
||||
. S DIR("?")="ENTER A NAME BETWEEN 1 AND 30 CHARACTERS IN UPPERCASE"
|
||||
. S DIR(0)="FA^1:30^K:X'?.U X",DIR("A")="GO TO PAYER NAME: ",DIR("B")=$E(RCPAYR("FROM"),1,27)_"ZZZ" W ! D ^DIR K DIR
|
||||
. I $D(DTOUT)!$D(DUOUT) S RCQUIT=1 Q
|
||||
. S $P(^TMP("RCERA_PARAMS",$J,"RCPAYR"),U,3)=Y
|
||||
W !
|
||||
;
|
||||
PARAMSQ I $G(RCQUIT) K ^TMP("RCERA_PARAMS",$J)
|
||||
Q
|
||||
;
|
||||
FILTER(Y) ; Returns 1 if record in entry Y in 344.4 passes
|
||||
; the edits for the worklist selection of ERAs
|
||||
; Parameters found in ^TMP("RCERA_PARAMS",$J)
|
||||
N OK,RCPOST,RCMATCH,RCDFR,RCDTO,RCPAYFR,RCPAYTO,RCPAYR,RC0
|
||||
S OK=1,RC0=$G(^RCY(344.4,Y,0))
|
||||
;
|
||||
S RCMATCH=$G(^TMP("RCERA_PARAMS",$J,"RCMATCH")),RCPOST=$G(^TMP("RCERA_PARAMS",$J,"RCPOST"))
|
||||
S RCDFR=+$P($G(^TMP("RCERA_PARAMS",$J,"RCDT")),U),RCDTO=+$P($G(^TMP("RCERA_PARAMS",$J,"RCDT")),U,2)
|
||||
S RCPAYR=$P($G(^TMP("RCERA_PARAMS",$J,"RCPAYR")),U),RCPAYFR=$P($G(^TMP("RCERA_PARAMS",$J,"RCPAYR")),U,2),RCPAYTO=$P($G(^TMP("RCERA_PARAMS",$J,"RCPAYR")),U,3)
|
||||
;
|
||||
; If receipt exists, scratchpad must exist
|
||||
;I $P(RC0,U,8),'$D(^RCY(344.49,+Y,0)) S OK=0 G FQ
|
||||
; Post status
|
||||
I $S(RCPOST="B":0,RCPOST="U":$P(RC0,U,14),1:'$P(RC0,U,14)) S OK=0 G FQ
|
||||
; Match status
|
||||
I $S(RCMATCH="B":0,RCMATCH="N":$P(RC0,U,9),1:'$P(RC0,U,9)) S OK=0 G FQ
|
||||
; dt rec'd range
|
||||
I $S(RCDFR=0:0,1:$P(RC0,U,7)\1<RCDFR) S OK=0 G FQ
|
||||
I $S(RCDTO=DT:0,1:$P(RC0,U,7)\1>RCDTO) S OK=0 G FQ
|
||||
; Payer name
|
||||
I RCPAYR'="A" D G:'OK FQ
|
||||
. N Q
|
||||
. S Q=$$UPPER^RCDPEWL7($P(RC0,U,6))
|
||||
. I $S(Q=RCPAYFR:1,Q=RCPAYTO:1,Q]RCPAYFR:RCPAYTO]Q,1:0) Q
|
||||
. S OK=0
|
||||
FQ Q OK
|
||||
;
|
||||
SPLIT ; Split line in ERA list
|
||||
N RCLINE,RCZ,RCDA,Q,Q0,Z,Z0,DIR,X,Y,CT,L,L1,RCONE,RCQUIT
|
||||
D FULL^VALM1
|
||||
I $G(RCSCR("NOEDIT")) D NOEDIT^RCDPEWL G SPLITQ
|
||||
W !!,"SELECT THE ENTRY THAT HAS A LINE YOU NEED TO SPLIT/EDIT",!
|
||||
D SEL^RCDPEWL(.RCDA)
|
||||
S Z=+$O(RCDA(0)) G:'$G(RCDA(Z)) SPLITQ
|
||||
S RCLINE=+RCDA(Z),Z0=+$O(^TMP("RCDPE-EOB_WLDX",$J,Z_".999"),-1)
|
||||
S RCZ=Z F S RCZ=$O(^TMP("RCDPE-EOB_WLDX",$J,RCZ)) Q:'RCZ!(RCZ\1'=Z) D
|
||||
. S Q=$P($G(^TMP("RCDPE-EOB_WLDX",$J,RCZ)),U,2)
|
||||
. Q:'Q
|
||||
. S RCZ(RCZ)=Q
|
||||
. S Q0=0 F S Q0=$O(^RCY(344.49,RCSCR,1,Q,1,Q0)) Q:'Q0 I "01"[$P($G(^(Q0,0)),U,2) K RCZ(RCZ) Q
|
||||
I '$O(RCZ(0)) D G SPLITQ
|
||||
. S DIR(0)="EA",DIR("A",1)="THIS ENTRY HAS NO LINES AVAILABLE TO EDIT/SPLIT",DIR("A")="PRESS RETURN TO CONTINUE " W ! D ^DIR K DIR
|
||||
S RCQUIT=0
|
||||
I $P($G(^RCY(344.49,RCSCR,1,RCLINE,0)),U,13) D G:RCQUIT SPLITQ
|
||||
. S DIR("A",1)="WARNING! THIS LINE HAS ALREADY BEEN VERIFIED",DIR("A")="ARE YOU SURE YOU WANT TO CONTINUE?: ",DIR(0)="YA",DIR("B")="NO" W ! D ^DIR K DIR
|
||||
. I Y'=1 S RCQUIT=1
|
||||
S CT=0,CT=CT+1,DIR("?",CT)="Enter the line # that you want to split or edit:",RCONE=1
|
||||
S L=Z F S L=$O(RCZ(L)) Q:'L D
|
||||
. S L1=+$G(^TMP("RCDPE-EOB_WLDX",$J,L))
|
||||
. S CT=CT+1
|
||||
. S DIR("?",CT)=$G(^TMP("RCDPE-EOB_WL",$J,L1,0)),CT=CT+1,DIR("?",CT)=$G(^TMP("RCDPE-EOB_WL",$J,L1+1,0)) S RCONE(1)=$S(RCONE:L,1:"") S RCONE=0
|
||||
S DIR("?")=" ",Y=-1
|
||||
I $G(RCONE(1)) S Y=+RCONE(1) K DIR G:'Y SPLITQ
|
||||
I '$G(RCONE(1)) D K DIR I $D(DTOUT)!$D(DUOUT)!(Y\1'=Z) G SPLITQ
|
||||
. F S DIR(0)="NAO^"_(Z+.001)_":"_Z0_":3",DIR("A")="WHICH LINE OF ENTRY "_Z_" DO YOU WANT TO SPLIT/EDIT?: " S:$G(RCONE(1))'="" DIR("B")=RCONE(1) D ^DIR Q:'Y!$D(DUOUT)!$D(DTOUT) D Q:Y>0
|
||||
.. I '$D(^TMP("RCDPE-EOB_WLDX",$J,Y)) W !!,"LINE "_Y_" DOES NOT EXIST - TRY AGAIN",! S Y=-1 Q
|
||||
.. I '$D(RCZ(Y)) W !!,"LINE "_Y_" HAS BEEN USED IN A DISTRIBUTE ADJ ACTION AND CAN'T BE EDITED",! S Y=-1 Q
|
||||
.. S Q=+$O(^RCY(344.49,RCSCR,1,"B",Y,0))
|
||||
;
|
||||
K ^TMP("RCDPE_SPLIT_REBLD",$J)
|
||||
D SPLIT^RCDPEWL3(RCSCR,+Y)
|
||||
I $G(^TMP("RCDPE_SPLIT_REBLD",$J)) K ^TMP("RCDPE_SPLIT_REBLD",$J) D BLD^RCDPEWL1($G(^TMP($J,"RC_SORTPARM")))
|
||||
;
|
||||
SPLITQ S VALMBCK="R"
|
||||
Q
|
||||
;
|
||||
PRTERA ; View/prt
|
||||
N DIC,X,Y,RCSCR
|
||||
S DIC="^RCY(344.4,",DIC(0)="AEMQ" D ^DIC
|
||||
Q:Y'>0
|
||||
S RCSCR=+Y
|
||||
D PRERA1
|
||||
Q
|
||||
;
|
||||
PRERA ; RCSCR is assumed to be defined
|
||||
D FULL^VALM1 ; Protocol entry
|
||||
PRERA1 ; Option entry
|
||||
N %ZIS,ZTRTN,ZTSAVE,ZTDESC,POP,DIR,X,Y,RCERADET
|
||||
S DIR("?",1)="INCLUDING EXPANDED DETAIL WILL SIGNIFICANTLY INCREASE THE SIZE OF THIS REPORT",DIR("?",2)="IF YOU CHOOSE TO INCLUDE IT, ALL PAYMENT DETAILS FOR EACH EEOB WILL BE"
|
||||
S DIR("?")="LISTED. IF YOU WANT JUST SUMMARY DATA FOR EACH EEOB, DO NOT INCLUDE IT."
|
||||
S DIR(0)="YA",DIR("A")="DO YOU WANT TO INCLUDE EXPANDED EEOB DETAIL?: ",DIR("B")="NO" W ! D ^DIR K DIR
|
||||
I $D(DUOUT)!$D(DTOUT) G PRERAQ
|
||||
S RCERADET=+Y
|
||||
S %ZIS="QM" D ^%ZIS G:POP PRERAQ
|
||||
I $D(IO("Q")) D G PRERAQ
|
||||
. S ZTRTN="VPERA^RCDPEWL0("_RCSCR_","_RCERADET_")",ZTDESC="AR - Print ERA From Worklist"
|
||||
. D ^%ZTLOAD
|
||||
. W !!,$S($D(ZTSK):"Your task # "_ZTSK_" has been queued.",1:"Unable to queue this job.")
|
||||
. K ZTSK,IO("Q") D HOME^%ZIS
|
||||
U IO
|
||||
D VPERA(RCSCR,RCERADET)
|
||||
Q
|
||||
;
|
||||
VPERA(RCSCR,RCERADET) ; Queued entry
|
||||
; RCSCR = ien of entry in file 344.4
|
||||
; RCERADET = 1 if inclusion of all EOB details from file 361.1 is
|
||||
; desired, 0 if not
|
||||
N Z,Z0,RCSTOP,RCZ,RCPG,RCDOT,RCDIQ,RCDIQ1,RCDIQ2,RCXM1,RC,RCSCR1,RC3611
|
||||
K ^TMP($J,"RC_SUMRAW"),^TMP($J,"RC_SUMOUT"),^TMP($J,"RC_SUMALL")
|
||||
S (RCSTOP,RCPG)=0,RCDOT="",$P(RCDOT,".",79)=""
|
||||
D GETS^DIQ(344.4,RCSCR_",","*","IEN","RCDIQ")
|
||||
D TXT0^RCDPEX31(RCSCR,.RCDIQ,.RCXM1,.RC) ; Get top level 0-node captioned flds
|
||||
I $O(^RCY(344.4,RCSCR,2,0)) S RC=RC+1,RCXM1(RC)=" **ERA LEVEL ADJUSTMENTS**"
|
||||
S RCSCR1=0 F S RCSCR1=$O(^RCY(344.4,RCSCR,2,RCSCR1)) Q:'RCSCR1 D
|
||||
. K RCDIQ2
|
||||
. D GETS^DIQ(344.42,RCSCR1_","_RCSCR_",","*","IEN","RCDIQ2")
|
||||
. D TXT2^RCDPEX31(RCSCR,RCSCR1,.RCDIQ2,.RCXM1,.RC) ; Get top level ERA adjs
|
||||
S RCSCR1=0 F S RCSCR1=$O(^RCY(344.4,RCSCR,1,RCSCR1)) Q:'RCSCR1 D
|
||||
. K RCDIQ1
|
||||
. D GETS^DIQ(344.41,RCSCR1_","_RCSCR_",","*","IEN","RCDIQ1")
|
||||
. D TXT00^RCDPEX31(RCSCR,RCSCR1,.RCDIQ1,.RCXM1,.RC)
|
||||
. S RC=RC+1,RCXM1(RC-1)=$E("PATIENT: "_$$PNM4^RCDPEWL1(RCSCR,RCSCR1)_$J("",41),1,41)_"CLAIM #: "_$$BILLREF^RCDPESR0(RCSCR,RCSCR1),RCXM1(RC)=" "
|
||||
. S RC3611=$P($G(^RCY(344.4,RCSCR,1,RCSCR1,0)),U,2)
|
||||
. I RCERADET D ; Include formatted txt from 361.1 or 344.411
|
||||
.. I 'RC3611 D Q ; Formatted raw data
|
||||
... D DISP^RCDPESR0("^RCY(344.4,"_RCSCR_",1,"_RCSCR1_",1)","^TMP($J,""RC_SUMRAW"")",1,"^TMP($J,""RC_SUMOUT"")",75,1)
|
||||
..;
|
||||
.. E D ; Detail record is in 361.1
|
||||
... K ^TMP("PRCA_EOB",$J)
|
||||
... D GETEOB^IBCECSA6(RC3611,2)
|
||||
... I $O(^IBM(361.1,RC3611,"ERR",0)) D GETERR^RCDPEDS(RC3611,+$O(^TMP("PRCA_EOB",$J,RC3611," "),-1)) ; get filing errors
|
||||
... S Z=0 F S Z=$O(^TMP("PRCA_EOB",$J,RC3611,Z)) Q:'Z S RC=RC+1,^TMP($J,"RC_SUMOUT",RC)=$G(^TMP("PRCA_EOB",$J,RC3611,Z))
|
||||
... S RC=RC+2,^TMP($J,"RC_SUMOUT",RC-1)=" ",^TMP($J,"RC_SUMOUT",RC)=" "
|
||||
... K ^TMP("PRCA_EOB",$J)
|
||||
. I $D(RCDIQ1(344.41,RCSCR1_","_RCSCR_",",2)) D
|
||||
.. S RC=RC+1,RCXM1(RC)=" **EXCEPTION RESOLUTION LOG DATA**"
|
||||
.. S Z=0 F S Z=$O(RCDIQ1(344.41,RCSCR1_","_RCSCR_",",2,Z)) Q:'Z S RC=RC+1,RCXM1(RC)=RCDIQ1(344.41,RCSCR1_","_RCSCR_",",2,Z)
|
||||
. S RC=RC+1,RCXM1(RC)=" "
|
||||
. S Z0=+$O(^TMP($J,"RC_SUMALL"," "),-1)
|
||||
. S Z=0 F S Z=$O(RCXM1(Z)) Q:'Z S Z0=Z0+1,^TMP($J,"RC_SUMALL",Z0)=RCXM1(Z)
|
||||
. K RCXM1 S RC=0
|
||||
. S Z=0 F S Z=$O(^TMP($J,"RC_SUMOUT",Z)) Q:'Z S Z0=Z0+1,^TMP($J,"RC_SUMALL",Z0)=$G(^TMP($J,"RC_SUMOUT",Z))
|
||||
S RCSTOP=0,Z=""
|
||||
F S Z=$O(^TMP($J,"RC_SUMALL",Z)) Q:'Z D Q:RCSTOP
|
||||
. I $D(ZTQUEUED),$$S^%ZTLOAD S (RCSTOP,ZTSTOP)=1 K ZTREQ I +$G(RCPG) W !!,"***TASK STOPPED BY USER***" Q
|
||||
. I 'RCPG!(($Y+5)>IOSL) D I RCSTOP Q
|
||||
.. D:RCPG ASK(.RCSTOP) I RCSTOP Q
|
||||
.. D HDR(.RCPG)
|
||||
. W !,$G(^TMP($J,"RC_SUMALL",Z))
|
||||
;
|
||||
I 'RCSTOP,RCPG D ASK(.RCSTOP)
|
||||
;
|
||||
I $D(ZTQUEUED) S ZTREQ="@"
|
||||
I '$D(ZTQUEUED) D ^%ZISC
|
||||
;
|
||||
PRERAQ K ^TMP($J,"RC_SUMRAW"),^TMP($J,"RC_SUMOUT"),^TMP($J,"SUMALL")
|
||||
S VALMBCK="R"
|
||||
Q
|
||||
;
|
||||
HDR(RCPG) ;Report hdr
|
||||
; RCPG = last page #
|
||||
I RCPG!($E(IOST,1,2)="C-") W @IOF,*13
|
||||
S RCPG=$G(RCPG)+1
|
||||
W !,?5,"EDI LOCKBOX WORKLIST - ERA DETAIL",?55,$$FMTE^XLFDT(DT,2),?70,"Page: ",RCPG,!,$TR($J("",IOM)," ","=")
|
||||
Q
|
||||
;
|
||||
ASK(RCSTOP) ;
|
||||
I $E(IOST,1,2)'["C-" Q
|
||||
N DIR,DIROUT,DIRUT,DTOUT,DUOUT
|
||||
S DIR(0)="E" W ! D ^DIR
|
||||
I ($D(DIRUT))!($D(DUOUT)) S RCSTOP=1 Q
|
||||
Q
|
||||
;
|
||||
|
|
|
|||
|
|
@ -1,95 +1,95 @@
|
|||
RCDPEX32 ;ALB/TMK - ELECTRONIC EOB EXCEPTION PROCESSING - FILE 344.4 ;10-OCT-02
|
||||
;;4.5;Accounts Receivable;**173,249**;Mar 20, 1995;Build 2
|
||||
;;Per VHA Directive 10-93-142, this routine should not be modified.
|
||||
;
|
||||
EDITNUM ; Edit invalid claim # to valid, refile EOB
|
||||
N RC,RC0,RCDA,RCXDA,RCXDA1,RCSAVE,RCEOB,RCWARN,Q,Q0,DA,DR,DIE,DIC,DIR,X,Y,RCBILL,RCCHG
|
||||
D FULL^VALM1
|
||||
D SEL^RCDPEX3(.RCDA)
|
||||
G:'$O(RCDA(0)) EDITNQ
|
||||
;
|
||||
S RC=0 F S RC=$O(RCDA(RC)) Q:'RC D L -^RCY(344.4,RCXDA1,1,RCXDA,0)
|
||||
. S RCXDA1=+RCDA(RC),RCXDA=+$P(RCDA(RC),U,2),RCSAVE=""
|
||||
. I '$$LOCK^RCDPEX31(RCXDA1,RCXDA,1) D Q
|
||||
.. S DIR(0)="EA",DIR("A",1)="**Selection #"_RC_" is being edited by another user - ... please try again later",DIR("A")="PRESS RETURN TO CONTINUE" D ^DIR K DIR
|
||||
. S RC0=$G(^RCY(344.4,RCXDA1,1,RCXDA,0))
|
||||
. I $P(RC0,U,5)="" D Q
|
||||
.. S DIR(0)="EA",DIR("A",1)="The claim for selection #"_RC_" can't be edited as the bill # is not invalid",DIR("A")="PRESS RETURN TO CONTINUE" D ^DIR K DIR
|
||||
. I $P(RC0,U,9) D Q
|
||||
.. S DIR(0)="EA",DIR("A",1)="The claim for selection #"_RC_" can't be edited as the claim has already",DIR("A")="been transferred to another site - PRESS RETURN TO CONTINUE" W ! D ^DIR K DIR
|
||||
. ;
|
||||
. I $D(^RCY(344.49,RCXDA1)) D
|
||||
.. N X
|
||||
.. S X=$G(^RCY(344,+$P($G(^RCY(344.49,RCXDA1,0)),U,2),0))
|
||||
.. W !!,*7,"Warning: EEOB Worklist entry #"_RCXDA1_$S($P(X,U)'="":" and receipt "_$P(X,U),1:"")_" exist for this EEOB"
|
||||
.. I X="" W !,"You should refresh the worklist entry to include the new claim #",!," before creating the receipt",!
|
||||
. I $P($G(^RCY(344.4,RCXDA1,0)),U,8) D
|
||||
.. W !,"Since the receipt for this EEOB ("_$P($G(^RCY(344,+$P($G(^RCY(344.4,RCXDA1,0)),U,8),0)),U)_") already exists"
|
||||
.. I '$P($G(^RCY(344,+$P($G(^RCY(344.4,RCXDA1,0)),U,8),0)),U,14) W !," and is closed, you will need to use link payment to apply the payment",!," to the correct account",! Q
|
||||
.. W !," you should edit the receipt and change the claim # so it posts to the",!," correct account",!
|
||||
. ;
|
||||
. I $P(RC0,U,17)="" S RCSAVE=$P(RC0,U,5)
|
||||
. W !,"Selection #: "_RC_$J("",5)_$P(RC0,U,5)
|
||||
. S DIC("A")="Select A/R Bill this EEOB is actually paying on: ",DIC="^PRCA(430,",DIC(0)="AEMQ",DIC("S")="I $D(^DGCR(399,+Y,0))" W ! D ^DIC K DIC
|
||||
. Q:Y'>0
|
||||
. S RCBILL=+Y,RCBILL(1)=$P($G(^PRCA(430,RCBILL,0)),U),RCWARN=0
|
||||
. I $P($G(^RCY(344.4,RCXDA1,0)),U,14) S RCWARN=RCWARN+1,DIR("A",RCWARN+1)=$J("",4)_"THE RECEIPT FOR THIS EEOB HAS ALREADY BEEN POSTED."
|
||||
. I $P($G(^PRCA(430.3,+$P($G(^PRCA(430,RCBILL,0)),U,8),0)),U,3)'=102 S RCWARN=RCWARN+1,DIR("A",RCWARN+1)=$J("",4)_"THIS IS NOT AN ACTIVE ACCOUNTS RECEIVABLE."
|
||||
. I RCWARN D I Y'=1 Q
|
||||
.. S DIR("A",1)="** WARNING"_$S(RCWARN>1:"S",1:"")_":"
|
||||
.. S DIR("A",RCWARN+1)=" "
|
||||
.. S DIR(0)="YA",DIR("A")="ARE YOU SURE YOU WANT TO FILE THIS EEOB FOR CLAIM #: "_RCBILL(1)_"?: ",DIR("B")="NO" W ! D ^DIR K DIR
|
||||
.. ;
|
||||
. ; File EOB for new claim #
|
||||
. K ^TMP($J,"RCDP-EOB"),^TMP($J,"RCDPEOB","HDR")
|
||||
. S Q=0 F S Q=$O(^RCY(344.4,RCXDA1,1,RCXDA,1,Q)) Q:'Q S Q0=$G(^(Q,0)) D
|
||||
.. I $P(Q0,U)["835ERA" S ^TMP($J,"RCDPEOB","HDR")=Q0
|
||||
.. I $P(Q0,U,2)=$P(RC0,U,5) S $P(Q0,U,2)=RCBILL(1)
|
||||
.. S ^TMP($J,"RCDP-EOB",1,Q,0)=Q0
|
||||
. S ^TMP($J,"RCDP-EOB",1,.5,0)="835ERA"
|
||||
. S RCEOB=$$DUP^IBCEOB("^TMP("_$J_",""RCDP-EOB"",1)",RCBILL) ; IA 4042
|
||||
. K ^TMP($J,"RCDP-EOB",1,.5,0)
|
||||
. I RCEOB D Q
|
||||
.. N RCWHY S RCWHY(1)="EEOB already found on file while trying to change claim # and filing into IB"
|
||||
.. D STORACT^RCDPEX31(RCXDA1,RCXDA,.RCWHY)
|
||||
.. S RCCHG=1,DA(1)=RCXDA1,DA=RCXDA D CHGED(.DA,RCEOB,RCSAVE)
|
||||
.. S DIR(0)="YA",DIR("A",1)="EEOB detail is already on file for "_RCBILL(1)_" - Exception removed",DIR("A")="PRESS RETURN TO CONTINUE" D ^DIR K DIR
|
||||
. ;
|
||||
. ; Add stub rec to 361.1 if not there
|
||||
. S RCEOB=+$$ADD3611^IBCEOB(+$P($G(^RCY(344.4,RCXDA1,0)),U,12),"","",RCBILL,1,"^TMP("_$J_",""RCDP-EOB"",1)") ; IA 4042
|
||||
. ;
|
||||
. I RCEOB<0 D Q
|
||||
.. N RCWHY S RCWHY(1)="Error encountered trying to change claim # and file into IB"
|
||||
.. D STORACT^RCDPEX31(RCXDA1,RCXDA,.RCWHY)
|
||||
.. S DIR("A")="EA",DIR("A",1)="Error - EEOB detail not added to IB for bill "_RCBILL(1),DIR("A")="PRESS RETURN TO CONTINUE" D ^DIR K DIR
|
||||
. ;
|
||||
. ; Update EOB in file 361.1
|
||||
. ; Call needs ^TMP arrays: $J,"RCDPEOB","HDR" and $J,"RCDP-EOB"
|
||||
. D UPD3611^IBCEOB(RCEOB,1,1) ; IA 4042
|
||||
. ; errors in ^TMP("RCDPERR-EOB",$J
|
||||
. I $O(^TMP("RCDPERR-EOB",$J,0)) D
|
||||
.. D ERRUPD^IBCEOB(RCEOB,"RCDPERR-EOB") ; Adds error msgs to IB file 361.1 ; IA 4042
|
||||
. ;
|
||||
. S RCCHG=1
|
||||
. N RCWHY S RCWHY(1)="EEOB claim # changed and filed into IB under new claim #"
|
||||
. D STORACT^RCDPEX31(RCXDA1,RCXDA,.RCWHY)
|
||||
. S DA(1)=RCXDA1,DA=RCXDA
|
||||
. D CHGED(.DA,RCEOB,RCSAVE)
|
||||
. S DIE="^RCY(344.4,"_DA(1)_",1,",DR="1///@" D ^DIE
|
||||
. S DIR("A",1)="EEOB Filed. Its detail may be viewed using Third Party Joint Inquiry",DIR("A")="PRESS RETURN TO CONTINUE ",DIR(0)="EA"
|
||||
. W ! D ^DIR K DIR
|
||||
. S VALMBG=1
|
||||
;
|
||||
EDITNQ I $G(RCCHG) D BLD^RCDPEX2
|
||||
K ^TMP($J,"RCDP-EOB"),^TMP($J,"RCDPEOB","HDR"),^TMP("RCDPERR-EOB",$J)
|
||||
S VALMBCK="R"
|
||||
Q
|
||||
;
|
||||
CHGED(DA,RCEOB,RCSAVE) ; Change bad bill # to good one for EOB
|
||||
; DA = DA and DA(1) to use for DIE call
|
||||
; RCEOB = the ien of the entry in file 361.1
|
||||
; RCSAVE = the free text of the original bill #
|
||||
N DIE,DR,X,Y
|
||||
S DIE="^RCY(344.4,"_DA(1)_",1,",DR=".05///@;.02////"_RCEOB_";.13////1"_$S(RCSAVE'="":";.17////"_RCSAVE,1:"")_";.07///@" D ^DIE
|
||||
Q
|
||||
;
|
||||
RCDPEX32 ;ALB/TMK - ELECTRONIC EOB EXCEPTION PROCESSING - FILE 344.4 ;10-OCT-02
|
||||
;;4.5;Accounts Receivable;**173**;Mar 20, 1995
|
||||
;;Per VHA Directive 10-93-142, this routine should not be modified.
|
||||
;
|
||||
EDITNUM ; Edit invalid claim # to valid, refile EOB
|
||||
N RC,RC0,RCDA,RCXDA,RCXDA1,RCSAVE,RCEOB,RCWARN,Q,Q0,DA,DR,DIE,DIC,DIR,X,Y,RCBILL,RCCHG
|
||||
D FULL^VALM1
|
||||
D SEL^RCDPEX3(.RCDA)
|
||||
G:'$O(RCDA(0)) EDITNQ
|
||||
;
|
||||
S RC=0 F S RC=$O(RCDA(RC)) Q:'RC D L -^RCY(344.4,RCXDA1,1,RCXDA,0)
|
||||
. S RCXDA1=+RCDA(RC),RCXDA=+$P(RCDA(RC),U,2),RCSAVE=""
|
||||
. I '$$LOCK^RCDPEX31(RCXDA1,RCXDA,1) D Q
|
||||
.. S DIR(0)="EA",DIR("A",1)="**Selection #"_RC_" is being edited by another user - ... please try again later",DIR("A")="PRESS RETURN TO CONTINUE" D ^DIR K DIR
|
||||
. S RC0=$G(^RCY(344.4,RCXDA1,1,RCXDA,0))
|
||||
. I $P(RC0,U,5)="" D Q
|
||||
.. S DIR(0)="EA",DIR("A",1)="The claim for selection #"_RC_" can't be edited as the bill # is not invalid",DIR("A")="PRESS RETURN TO CONTINUE" D ^DIR K DIR
|
||||
. I $P(RC0,U,9) D Q
|
||||
.. S DIR(0)="EA",DIR("A",1)="The claim for selection #"_RC_" can't be edited as the claim has already",DIR("A")="been transferred to another site - PRESS RETURN TO CONTINUE" W ! D ^DIR K DIR
|
||||
. ;
|
||||
. I $D(^RCY(344.49,RCXDA1)) D
|
||||
.. N X
|
||||
.. S X=$G(^RCY(344,+$P($G(^RCY(344.49,RCXDA1,0)),U,2),0))
|
||||
.. W !!,*7,"Warning: EEOB Worklist entry #"_RCXDA1_$S($P(X,U)'="":" and receipt "_$P(X,U),1:"")_" exist for this EEOB"
|
||||
.. I X="" W !,"You should refresh the worklist entry to include the new claim #",!," before creating the receipt",!
|
||||
. I $P($G(^RCY(344.4,RCXDA1,0)),U,8) D
|
||||
.. W !,"Since the receipt for this EEOB ("_$P($G(^RCY(344,+$P($G(^RCY(344.4,RCXDA1,0)),U,8),0)),U)_") already exists"
|
||||
.. I '$P($G(^RCY(344,+$P($G(^RCY(344.4,RCXDA1,0)),U,8),0)),U,14) W !," and is closed, you will need to use link payment to apply the payment",!," to the correct account",! Q
|
||||
.. W !," you should edit the receipt and change the claim # so it posts to the",!," correct account",!
|
||||
. ;
|
||||
. I $P(RC0,U,17)="" S RCSAVE=$P(RC0,U,5)
|
||||
. W !,"Selection #: "_RC_$J("",5)_$P(RC0,U,5)
|
||||
. S DIC("A")="Select A/R Bill this EEOB is actually paying on: ",DIC="^PRCA(430,",DIC(0)="AEMQ",DIC("S")="I $D(^DGCR(399,+Y,0))" W ! D ^DIC K DIC
|
||||
. Q:Y'>0
|
||||
. S RCBILL=+Y,RCBILL(1)=$P($G(^PRCA(430,RCBILL,0)),U),RCWARN=0
|
||||
. I $P($G(^RCY(344.4,RCXDA1,0)),U,14) S RCWARN=RCWARN+1,DIR("A",RCWARN+1)=$J("",4)_"THE RECEIPT FOR THIS EEOB HAS ALREADY BEEN POSTED."
|
||||
. I $P($G(^PRCA(430.3,+$P($G(^PRCA(430,RCBILL,0)),U,8),0)),U,3)'=102 S RCWARN=RCWARN+1,DIR("A",RCWARN+1)=$J("",4)_"THIS IS NOT AN ACTIVE ACCOUNTS RECEIVABLE."
|
||||
. I RCWARN D I Y'=1 Q
|
||||
.. S DIR("A",1)="** WARNING"_$S(RCWARN>1:"S",1:"")_":"
|
||||
.. S DIR("A",RCWARN+1)=" "
|
||||
.. S DIR(0)="YA",DIR("A")="ARE YOU SURE YOU WANT TO FILE THIS EEOB FOR CLAIM #: "_RCBILL(1)_"?: ",DIR("B")="NO" W ! D ^DIR K DIR
|
||||
.. ;
|
||||
. ; File EOB for new claim #
|
||||
. K ^TMP($J,"RCDP-EOB"),^TMP($J,"RCDPEOB","HDR")
|
||||
. S Q=0 F S Q=$O(^RCY(344.4,RCXDA1,1,RCXDA,1,Q)) Q:'Q S Q0=$G(^(Q,0)) D
|
||||
.. I $P(Q0,U)["835ERA" S ^TMP($J,"RCDPEOB","HDR")=Q0
|
||||
.. I $P(Q0,U,2)=$P(RC0,U,5) S $P(Q0,U,2)=RCBILL(1)
|
||||
.. S ^TMP($J,"RCDP-EOB",1,Q,0)=Q0
|
||||
. S ^TMP($J,"RCDP-EOB",1,.5,0)="835ERA"
|
||||
. S RCEOB=$$DUP^IBCEOB(RCBILL,"^TMP("_$J_",""RCDP-EOB"",1)") ; IA 4042
|
||||
. K ^TMP($J,"RCDP-EOB",1,.5,0)
|
||||
. I RCEOB D Q
|
||||
.. N RCWHY S RCWHY(1)="EEOB already found on file while trying to change claim # and filing into IB"
|
||||
.. D STORACT^RCDPEX31(RCXDA1,RCXDA,.RCWHY)
|
||||
.. S RCCHG=1,DA(1)=RCXDA1,DA=RCXDA D CHGED(.DA,RCEOB,RCSAVE)
|
||||
.. S DIR(0)="YA",DIR("A",1)="EEOB detail is already on file for "_RCBILL(1)_" - Exception removed",DIR("A")="PRESS RETURN TO CONTINUE" D ^DIR K DIR
|
||||
. ;
|
||||
. ; Add stub rec to 361.1 if not there
|
||||
. S RCEOB=+$$ADD3611^IBCEOB(+$P($G(^RCY(344.4,RCXDA1,0)),U,12),"","",RCBILL,1,"^TMP("_$J_",""RCDP-EOB"",1)") ; IA 4042
|
||||
. ;
|
||||
. I RCEOB<0 D Q
|
||||
.. N RCWHY S RCWHY(1)="Error encountered trying to change claim # and file into IB"
|
||||
.. D STORACT^RCDPEX31(RCXDA1,RCXDA,.RCWHY)
|
||||
.. S DIR("A")="EA",DIR("A",1)="Error - EEOB detail not added to IB for bill "_RCBILL(1),DIR("A")="PRESS RETURN TO CONTINUE" D ^DIR K DIR
|
||||
. ;
|
||||
. ; Update EOB in file 361.1
|
||||
. ; Call needs ^TMP arrays: $J,"RCDPEOB","HDR" and $J,"RCDP-EOB"
|
||||
. D UPD3611^IBCEOB(RCEOB,1,1) ; IA 4042
|
||||
. ; errors in ^TMP("RCDPERR-EOB",$J
|
||||
. I $O(^TMP("RCDPERR-EOB",$J,0)) D
|
||||
.. D ERRUPD^IBCEOB(RCEOB,"RCDPERR-EOB") ; Adds error msgs to IB file 361.1 ; IA 4042
|
||||
. ;
|
||||
. S RCCHG=1
|
||||
. N RCWHY S RCWHY(1)="EEOB claim # changed and filed into IB under new claim #"
|
||||
. D STORACT^RCDPEX31(RCXDA1,RCXDA,.RCWHY)
|
||||
. S DA(1)=RCXDA1,DA=RCXDA
|
||||
. D CHGED(.DA,RCEOB,RCSAVE)
|
||||
. S DIE="^RCY(344.4,"_DA(1)_",1,",DR="1///@" D ^DIE
|
||||
. S DIR("A",1)="EEOB Filed. Its detail may be viewed using Third Party Joint Inquiry",DIR("A")="PRESS RETURN TO CONTINUE ",DIR(0)="EA"
|
||||
. W ! D ^DIR K DIR
|
||||
. S VALMBG=1
|
||||
;
|
||||
EDITNQ I $G(RCCHG) D BLD^RCDPEX2
|
||||
K ^TMP($J,"RCDP-EOB"),^TMP($J,"RCDPEOB","HDR"),^TMP("RCDPERR-EOB",$J)
|
||||
S VALMBCK="R"
|
||||
Q
|
||||
;
|
||||
CHGED(DA,RCEOB,RCSAVE) ; Change bad bill # to good one for EOB
|
||||
; DA = DA and DA(1) to use for DIE call
|
||||
; RCEOB = the ien of the entry in file 361.1
|
||||
; RCSAVE = the free text of the original bill #
|
||||
N DIE,DR,X,Y
|
||||
S DIE="^RCY(344.4,"_DA(1)_",1,",DR=".05///@;.02////"_RCEOB_";.13////1"_$S(RCSAVE'="":";.17////"_RCSAVE,1:"")_";.07///@" D ^DIE
|
||||
Q
|
||||
;
|
||||
|
|
|
|||
|
|
@ -1,120 +1,116 @@
|
|||
RCDPUDEP ;WISC/RFJ-deposit utilities ;29/MAY/2008
|
||||
;;4.5;Accounts Receivable;**114,173,257**;Mar 20, 1995;Build 3
|
||||
;;Per VHA Directive 2004-038, this routine should not be modified.
|
||||
Q
|
||||
;
|
||||
;
|
||||
ADDDEPT(DEPOSIT,DEPDATE) ; if the deposit is not entered, add it
|
||||
;
|
||||
; if deposit date is missing, do not add the deposit
|
||||
I 'DEPDATE Q 0
|
||||
;
|
||||
; already in file, deposit number and deposit date match
|
||||
N DA,RCDPFLAG
|
||||
S DA=0 F S DA=$O(^RCY(344.1,"B",DEPOSIT,DA)) Q:'DA I $P($G(^RCY(344.1,DA,0)),"^",3)=DEPDATE S RCDPFLAG=1 Q
|
||||
I $G(RCDPFLAG) Q DA
|
||||
;
|
||||
; add it
|
||||
N %,%DT,D0,DA,DD,DI,DIC,DIE,DLAYGO,DO,DQ,DR,X,Y
|
||||
S DIC="^RCY(344.1,",DIC(0)="L",DLAYGO=344.1
|
||||
; .03 = deposit date .06 = opened by
|
||||
; .07 = date/time opened .12 = status (set to 1:open)
|
||||
S DIC("DR")=".03////"_DEPDATE_";.06////"_DUZ_";.07///NOW;.12////1;"
|
||||
S X=DEPOSIT
|
||||
D FILE^DICN
|
||||
I Y>0 Q +Y
|
||||
Q 0
|
||||
;
|
||||
;
|
||||
SELDEPT(ADDNEW) ; select a deposit
|
||||
; if $g(addnew) allow adding a new deposit
|
||||
; returns -1 for timeout or ^, 0 for no selection, or ien of deposit
|
||||
N %,%T,%Y,C,D0,DA,DIC,DIE,DLAYGO,DQ,DR,DTOUT,DUOUT,RCDEFLUP,X,Y
|
||||
S DIC="^RCY(344.1,",DIC(0)="QEAM",DIC("A")="Select DEPOSIT: "
|
||||
S DIC("W")="D DICW^RCDPUDEP"
|
||||
; use special lookup on input
|
||||
S RCDEFLUP=1
|
||||
I $G(ADDNEW) S DIC(0)="QEALM",DLAYGO=344.1,DIC("DR")=".03///TODAY;.06////"_DUZ_";.07///NOW;.12////1;"
|
||||
D ^DIC
|
||||
I Y<0,'$G(DUOUT),'$G(DTOUT) S Y=0
|
||||
Q +Y
|
||||
;
|
||||
;
|
||||
DICW ; write identifier code for receipt lookup
|
||||
N DATA
|
||||
S DATA=$G(^RCY(344.1,Y,0)) I DATA="" Q
|
||||
; opened by
|
||||
W ?13,"by: ",$E($P($G(^VA(200,+$P(DATA,"^",6),0)),"^"),1,15)
|
||||
; date opened
|
||||
I '$P(DATA,"^",7) S $P(DATA,"^",7)="???????"
|
||||
W ?35," on: ",$E($P(DATA,"^",7),4,5),"/",$E($P(DATA,"^",7),6,7),"/",$E($P(DATA,"^",7),2,3)
|
||||
; total dollars
|
||||
W ?50," amt: $",$J($P(DATA,"^",4),9,2)
|
||||
; status
|
||||
W ?69," ",$P("N/A^OPEN^DEPOSITED^CONFIRMED^PROCESSED^VOID","^",+$P(DATA,"^",12)+1)
|
||||
Q
|
||||
;
|
||||
;
|
||||
LOOKUP ; special lookup on deposits, called from ^dd(344.1,.01,7.5)
|
||||
; if rcdeflup flag not set, do not use special lookup
|
||||
I '$D(RCDEFLUP) Q
|
||||
; 1:OPEN;3:CONFIRMED
|
||||
; user entered O.? for lookup on open deposits
|
||||
I X["O."!(X["o.") S DIC("S")="I $P(^(0),U,12)=1" S X="?" Q
|
||||
; user entered C.? for lookup on confirmed deposits
|
||||
I X["C."!(X["c.") S DIC("S")="I $P(^(0),U,12)=3" S X="?" Q
|
||||
; deposit ticket # manually added is for electronic ticket only
|
||||
I $G(DIC(0))["L",$$AUTODEP(X) D EN^DDIOL(" ** Deposit #'s starting with "_$E(X,1,3)_" can only be used by automatic deposits",,"!") S X="" Q
|
||||
; Do not allow for 7-, 8-, or 9-digit electronic ticket to be added.
|
||||
I $G(DIC(0))["L",'$D(^RCY(344.1,"B",X)),$L(X)>6,$L(X)<10 D EN^DDIOL(" ** Deposit # of "_$L(X)_" digits not allowed. "_$S($L(X)=9:"9 digits limited to automatic deposits.",1:""),,"!") S X="" Q
|
||||
K DIC("S")
|
||||
Q
|
||||
;
|
||||
;
|
||||
EDITDEP(DA,ASKDATE) ; edit the deposit
|
||||
; if $g(askdate) ask only the deposit date
|
||||
N %,D,D0,DI,DIC,DIE,DQ,DR,J,X,Y
|
||||
S (DIC,DIE)="^RCY(344.1,",DR=""
|
||||
; deposit date(.03), do not allow edit if closed or either lockbox
|
||||
I $$CHECKDEP^RCDPDPLU(DA) S DR=".03BANK DEPOSIT DATE//TODAY;"
|
||||
; bank(.13)
|
||||
S DR=DR_".13//"_$P($G(^RC(342.1,+$O(^RC(342.1,"AC",9,0)),0)),"^")_";"
|
||||
; bank trace(.05)
|
||||
S DR=DR_".05;"
|
||||
; agency title(.17)
|
||||
S DR=DR_".17//"_$P($G(^RC(342.1,+$O(^RC(342.1,"AC",10,0)),0)),"^")_";"
|
||||
; agency location code(.14), comments(1)
|
||||
S DR=DR_".14//"_$P(^RC(342,1,0),"^",7)_";1;"
|
||||
;
|
||||
; only ask deposit date
|
||||
I $G(ASKDATE) S DR=".03BANK DEPOSIT DATE//TODAY;"
|
||||
D ^DIE
|
||||
Q
|
||||
;
|
||||
;
|
||||
CONFIRM(DA) ; confirm the deposit
|
||||
N %DT,D,D0,DI,DIC,DIE,DQ,DR,X,Y
|
||||
S (DIC,DIE)="^RCY(344.1,"
|
||||
S DR=".04///"_$$TOTAL(DA)_";.12////3;.1////"_DUZ_";.11///NOW;"
|
||||
D ^DIE
|
||||
Q
|
||||
;
|
||||
;
|
||||
TOTAL(RCDEPTDA) ; compute total dollars for all receipts on the deposit
|
||||
N RCRECTDA,RCTRANDA,TOTAL
|
||||
S RCRECTDA=0
|
||||
F S RCRECTDA=$O(^RCY(344,"AD",RCDEPTDA,RCRECTDA)) Q:'RCRECTDA D
|
||||
. S RCTRANDA=0
|
||||
. F S RCTRANDA=$O(^RCY(344,RCRECTDA,1,RCTRANDA)) Q:'RCTRANDA D
|
||||
. . S TOTAL=$G(TOTAL)+$P($G(^RCY(344,RCRECTDA,1,RCTRANDA,0)),"^",4)
|
||||
Q +$G(TOTAL)
|
||||
;
|
||||
AUTODEP(X) ; Function returns 1 if the deposit ticket # in X is in the auto
|
||||
; deposit number space 269xxx, 369xxx, 469xxx, 569xxx, or 669xxx
|
||||
; and hasn't been previously entered via lockbox interface.
|
||||
;
|
||||
N Y
|
||||
S Y=0
|
||||
I $L(X)=6,$E(X,2,3)="69","23456"[$E(X),'$D(^RCY(344.1,"B",X)) S Y=1
|
||||
Q Y
|
||||
;
|
||||
RCDPUDEP ;WISC/RFJ-deposit utilities ;1 Jun 99
|
||||
;;4.5;Accounts Receivable;**114,173**;Mar 20, 1995
|
||||
;;Per VHA Directive 10-93-142, this routine should not be modified.
|
||||
Q
|
||||
;
|
||||
;
|
||||
ADDDEPT(DEPOSIT,DEPDATE) ; if the deposit is not entered, add it
|
||||
;
|
||||
; if deposit date is missing, do not add the deposit
|
||||
I 'DEPDATE Q 0
|
||||
;
|
||||
; already in file, deposit number and deposit date match
|
||||
N DA,RCDPFLAG
|
||||
S DA=0 F S DA=$O(^RCY(344.1,"B",DEPOSIT,DA)) Q:'DA I $P($G(^RCY(344.1,DA,0)),"^",3)=DEPDATE S RCDPFLAG=1 Q
|
||||
I $G(RCDPFLAG) Q DA
|
||||
;
|
||||
; add it
|
||||
N %,%DT,D0,DA,DD,DI,DIC,DIE,DLAYGO,DO,DQ,DR,X,Y
|
||||
S DIC="^RCY(344.1,",DIC(0)="L",DLAYGO=344.1
|
||||
; .03 = deposit date .06 = opened by
|
||||
; .07 = date/time opened .12 = status (set to 1:open)
|
||||
S DIC("DR")=".03////"_DEPDATE_";.06////"_DUZ_";.07///NOW;.12////1;"
|
||||
S X=DEPOSIT
|
||||
D FILE^DICN
|
||||
I Y>0 Q +Y
|
||||
Q 0
|
||||
;
|
||||
;
|
||||
SELDEPT(ADDNEW) ; select a deposit
|
||||
; if $g(addnew) allow adding a new deposit
|
||||
; returns -1 for timeout or ^, 0 for no selection, or ien of deposit
|
||||
N %,%T,%Y,C,D0,DA,DIC,DIE,DLAYGO,DQ,DR,DTOUT,DUOUT,RCDEFLUP,X,Y
|
||||
S DIC="^RCY(344.1,",DIC(0)="QEAM",DIC("A")="Select DEPOSIT: "
|
||||
S DIC("W")="D DICW^RCDPUDEP"
|
||||
; use special lookup on input
|
||||
S RCDEFLUP=1
|
||||
I $G(ADDNEW) S DIC(0)="QEALM",DLAYGO=344.1,DIC("DR")=".03///TODAY;.06////"_DUZ_";.07///NOW;.12////1;"
|
||||
D ^DIC
|
||||
I Y<0,'$G(DUOUT),'$G(DTOUT) S Y=0
|
||||
Q +Y
|
||||
;
|
||||
;
|
||||
DICW ; write identifier code for receipt lookup
|
||||
N DATA
|
||||
S DATA=$G(^RCY(344.1,Y,0)) I DATA="" Q
|
||||
; opened by
|
||||
W ?13,"by: ",$E($P($G(^VA(200,+$P(DATA,"^",6),0)),"^"),1,15)
|
||||
; date opened
|
||||
I '$P(DATA,"^",7) S $P(DATA,"^",7)="???????"
|
||||
W ?35," on: ",$E($P(DATA,"^",7),4,5),"/",$E($P(DATA,"^",7),6,7),"/",$E($P(DATA,"^",7),2,3)
|
||||
; total dollars
|
||||
W ?50," amt: $",$J($P(DATA,"^",4),9,2)
|
||||
; status
|
||||
W ?69," ",$P("N/A^OPEN^DEPOSITED^CONFIRMED^PROCESSED^VOID","^",+$P(DATA,"^",12)+1)
|
||||
Q
|
||||
;
|
||||
;
|
||||
LOOKUP ; special lookup on deposits, called from ^dd(344.1,.01,7.5)
|
||||
; if rcdeflup flag not set, do not use special lookup
|
||||
I '$D(RCDEFLUP) Q
|
||||
; 1:OPEN;3:CONFIRMED
|
||||
; user entered O.? for lookup on open deposits
|
||||
I X["O."!(X["o.") S DIC("S")="I $P(^(0),U,12)=1" S X="?" Q
|
||||
; user entered C.? for lookup on confirmed deposits
|
||||
I X["C."!(X["c.") S DIC("S")="I $P(^(0),U,12)=3" S X="?" Q
|
||||
; deposit ticket # manually entered is for electronic ticket only
|
||||
I $G(DIC(0))["L",$$AUTODEP(X) D EN^DDIOL(" ** Deposit #'s starting with "_$E(X,1,3)_" can only be used by automatic deposits",,"!") S X=""
|
||||
K DIC("S")
|
||||
Q
|
||||
;
|
||||
;
|
||||
EDITDEP(DA,ASKDATE) ; edit the deposit
|
||||
; if $g(askdate) ask only the deposit date
|
||||
N %,D,D0,DI,DIC,DIE,DQ,DR,J,X,Y
|
||||
S (DIC,DIE)="^RCY(344.1,",DR=""
|
||||
; deposit date(.03), do not allow edit if closed or either lockbox
|
||||
I $$CHECKDEP^RCDPDPLU(DA) S DR=".03BANK DEPOSIT DATE//TODAY;"
|
||||
; bank(.13)
|
||||
S DR=DR_".13//"_$P($G(^RC(342.1,+$O(^RC(342.1,"AC",9,0)),0)),"^")_";"
|
||||
; bank trace(.05)
|
||||
S DR=DR_".05;"
|
||||
; agency title(.17)
|
||||
S DR=DR_".17//"_$P($G(^RC(342.1,+$O(^RC(342.1,"AC",10,0)),0)),"^")_";"
|
||||
; agency location code(.14), comments(1)
|
||||
S DR=DR_".14//"_$P(^RC(342,1,0),"^",7)_";1;"
|
||||
;
|
||||
; only ask deposit date
|
||||
I $G(ASKDATE) S DR=".03BANK DEPOSIT DATE//TODAY;"
|
||||
D ^DIE
|
||||
Q
|
||||
;
|
||||
;
|
||||
CONFIRM(DA) ; confirm the deposit
|
||||
N %DT,D,D0,DI,DIC,DIE,DQ,DR,X,Y
|
||||
S (DIC,DIE)="^RCY(344.1,"
|
||||
S DR=".04///"_$$TOTAL(DA)_";.12////3;.1////"_DUZ_";.11///NOW;"
|
||||
D ^DIE
|
||||
Q
|
||||
;
|
||||
;
|
||||
TOTAL(RCDEPTDA) ; compute total dollars for all receipts on the deposit
|
||||
N RCRECTDA,RCTRANDA,TOTAL
|
||||
S RCRECTDA=0
|
||||
F S RCRECTDA=$O(^RCY(344,"AD",RCDEPTDA,RCRECTDA)) Q:'RCRECTDA D
|
||||
. S RCTRANDA=0
|
||||
. F S RCTRANDA=$O(^RCY(344,RCRECTDA,1,RCTRANDA)) Q:'RCTRANDA D
|
||||
. . S TOTAL=$G(TOTAL)+$P($G(^RCY(344,RCRECTDA,1,RCTRANDA,0)),"^",4)
|
||||
Q +$G(TOTAL)
|
||||
;
|
||||
AUTODEP(X) ; Function returns 1 if the deposit ticket # in X is in the auto
|
||||
; deposit number space 269xxx, 369xxx, 469xxx, 569xxx
|
||||
N Y
|
||||
S Y=0
|
||||
I $L(X)=6,$E(X,2,3)="69","2345"[$E(X),'$D(^RCY(344.1,"B",X)) S Y=1
|
||||
Q Y
|
||||
;
|
||||
|
|
|
|||
|
|
@ -1,100 +1,95 @@
|
|||
RCFMOBR ;WASH-ISC@ALTOONA,PA/RWT-BILL RECONCILIATIONS LIST ;11/20/96 2:30 PM
|
||||
V ;;4.5;Accounts Receivable;**2,20,40,53,249**;Mar 20, 1995;Build 2
|
||||
;;Per VHA Directive 10-93-142, this routine should not be modified.
|
||||
EN ;Creates report from OBR data in file 423.6
|
||||
;
|
||||
; OBR Data Structure used by this routine
|
||||
; ^TMP("OBR",$J,SITE,"NOT IN AR")=NextRec^TotalItems^TotalFMSAmt
|
||||
; ^TMP("OBR",$J,SITE,"NOT IN FMS")=NextRec^TotalItems^TotalARAmt
|
||||
; ^TMP("OBR",$J,SITE,"DISCREPANCY")=NextRec^TotalItems^TotalFMSAmt^TotalARAmt
|
||||
; ^TMP("OBR",$J,"BN",BILLNUMBER)=[423.6 rec] <-- x-ref of FMS Bills
|
||||
; ^TMP("OBR",$J,"REPORT","1")="LINE 1"
|
||||
; ^TMP("OBR",$J","REPORT,"2")="LINE 2"
|
||||
;
|
||||
; Descriptions of modules:
|
||||
; PROCFMS - loop through FMS bills (^PRCF(423.6)) updating
|
||||
; global ^TMP("OBR",$J,"BN") while also checking
|
||||
; for invalid AR bills
|
||||
; PROCAR - loop through all Active AR Bills comparing amounts
|
||||
; and looking for Detail bills not found in FMS
|
||||
; BUILDRPT - Prepares report in global ^TMP("OBR",$J,"REPORT")
|
||||
;
|
||||
N X,Y,OBR,A0,ERR
|
||||
K ^TMP("OBR",$J)
|
||||
;
|
||||
I $G(PRCADA) D PROCESS(PRCADA) G Q1
|
||||
S OBR="OBR-",ERR=-1
|
||||
F S OBR=$O(^PRCF(423.6,"B",OBR)) Q:OBR=""!(OBR'["OBR-") D
|
||||
.I $O(^PRCF(423.6,"B",OBR))'["OBR-" D Q
|
||||
..S A0=$O(^PRCF(423.6,"B",OBR,0))
|
||||
..S ERR=0 D PROCESS(A0)
|
||||
I ERR D PROCESS(ERR)
|
||||
Q1 K ^TMP("OBR",$J)
|
||||
Q
|
||||
PROCESS(A0) N X,X1,X2,Y,SN,PARENT,XMTEXT,XMSUB,XMSENDER,XMDUZ,ERR,DATE,FMSDATE
|
||||
S ERR=0 D
|
||||
.I '$D(^PRCF(423.6,A0,0)) S ERR=-1 Q
|
||||
.I $E(^PRCF(423.6,A0,0),1,3)'["OBR" S ERR=-1 Q
|
||||
.S X=$P(^PRCF(423.6,A0,0),"-",2)
|
||||
.S X=$E(X,5,6)_"-"_$E(X,7,8)_"-"_$E(X,1,4) D ^%DT ;Y is defined
|
||||
.S PARENT=$P($P(^PRCF(423.6,A0,0),"-",5),U)
|
||||
.;
|
||||
.D PROCFMS^RCFMOBR1(A0)
|
||||
.D PROCAR^RCFMOBR1(A0)
|
||||
.D BUILDRPT^RCFMOBR2(PARENT)
|
||||
;
|
||||
I '$D(PARENT) S PARENT=$$SITE^RCMSITE
|
||||
S PARENT=$P(^DIC(4,+$O(^DIC(4,"D",PARENT,0)),0),U)
|
||||
;
|
||||
I '$D(Y) S Y=DT ;Y may be defined from %DT call above
|
||||
S X1=Y,X2=($E(Y,6,7)+1)*-1 D C^%DTC,YX^%DTC
|
||||
S FMSDATE=$P(Y,"@"),FMSDATE=$E(FMSDATE,1,4)_$E(FMSDATE,9,12)
|
||||
D NOW^%DTC S DATE=$E(X,4,5)_"-"_$E(X,6,7)_"-"_$E(X,2,3)
|
||||
; - Transmits report via e-mail to FMS mail group
|
||||
S XMSUB="FMS "_FMSDATE_" RECONCILIATION ("_DATE_") "
|
||||
S XMSUB=XMSUB_PARENT
|
||||
I ERR D
|
||||
.S ^TMP("OBR",$J,"REPORT",1)="Date of Report: "_DATE
|
||||
.S ^TMP("OBR",$J,"REPORT",2)="NOTE: This report compares your current A/R records with data received from"
|
||||
.S ^TMP("OBR",$J,"REPORT",3)=" FMS on the last day of the previous accounting period."
|
||||
.S ^TMP("OBR",$J,"REPORT",4)=""
|
||||
.S ^TMP("OBR",$J,"REPORT",5)="No FMS data exists to reconcile!"
|
||||
S XMTEXT="^TMP(""OBR"",$J,""REPORT"","
|
||||
S XMDUZ="Accounts Receivable Package",XMY("G.FMS")="",XMY(DUZ)="" D ^XMD
|
||||
Q
|
||||
EN2 ;Entry point from Regenerate Prior Month OBRs option
|
||||
N DIR,PRCADA,Y
|
||||
W !!,"This option will transmit the OBR report(s) to you and members"
|
||||
W !,"of the G.FMS mail group."
|
||||
W !!,"NOTE: Depending on the number of active AR bills in your system,"
|
||||
W !," this may take awhile to run.",!
|
||||
S DIR(0)="YO",DIR("A")="Are you sure you want to do this",DIR("B")="NO"
|
||||
D ^DIR Q:Y'=1 S ZTRTN="EN^RCFMOBR",ZTDESC="Prior Month OBRs"
|
||||
S ZTIO="" D ^%ZTLOAD Q
|
||||
;
|
||||
EN3 ;Deletes OBRs over 60 days old
|
||||
N A0,A1,A2,DA,DIK,X,X1,X2
|
||||
S A0="OBR-" F S A0=$O(^PRCF(423.6,"B",A0)) Q:A0=""!(A0'["OBR-") S A1=$E($P(A0,"-",2),1,8),A2=0 F S A2=$O(^PRCF(423.6,"B",A0,A2)) Q:+A2=0 D
|
||||
.S X1=DT,X2=$$RCDT(A1) D ^%DTC I X>60 S DIK="^PRCF(423.6,",DA=A2 D ^DIK
|
||||
Q
|
||||
RCDT(A1) ;Convert yyyymmdd to FM date
|
||||
N X,Y
|
||||
S X=A1,X=$E(X,5,6)_" "_$E(X,7,8)_", "_$E(X,1,4)
|
||||
D ^%DT
|
||||
Q Y
|
||||
PURGE ;purge unprocessed document file
|
||||
N DIR,Y,X,X1,X2,RCDT
|
||||
S DIR("A")="How many days worth of DATA do you want to retain"
|
||||
S DIR(0)="N",DIR("?")="This is the number of days entries will remain in the file."
|
||||
D ^DIR
|
||||
I +Y<0!(Y="")!($E(Y,1)="^") G POUT
|
||||
S X1=DT,X2=-(+Y) D C^%DTC S RCDT=X
|
||||
S ZTRTN="QPURGE^RCFMOBR",ZTSAVE("RCDT")="",ZTDESC="Purge unprocessed document list",ZTIO="" D ^%ZTLOAD
|
||||
POUT K DIRUT,DIROUT,DTOUT,DUOUT Q
|
||||
;
|
||||
QPURGE N DA,DIK
|
||||
S DIK="^RC(347,"
|
||||
Q:'$D(^RC(347))
|
||||
S DA=0 F S DA=$O(^RC(347,DA)) Q:'DA I $P(^(DA,0),U,5)<RCDT D ^DIK
|
||||
K RCDT
|
||||
Q
|
||||
RCFMOBR ;WASH-ISC@ALTOONA,PA/RWT-BILL RECONCILIATIONS LIST ;11/20/96 2:30 PM
|
||||
V ;;4.5;Accounts Receivable;**2,20,40,53**;Mar 20, 1995
|
||||
;;Per VHA Directive 10-93-142, this routine should not be modified.
|
||||
EN ;Creates report from OBR data in file 423.6
|
||||
;
|
||||
; OBR Data Structure used by this routine
|
||||
; ^TMP("OBR",$J,SITE,"NOT IN AR")=NextRec^TotalItems^TotalFMSAmt
|
||||
; ^TMP("OBR",$J,SITE,"NOT IN FMS")=NextRec^TotalItems^TotalARAmt
|
||||
; ^TMP("OBR",$J,SITE,"DISCREPANCY")=NextRec^TotalItems^TotalFMSAmt^TotalARAmt
|
||||
; ^TMP("OBR",$J,"BN",BILLNUMBER)=[423.6 rec] <-- x-ref of FMS Bills
|
||||
; ^TMP("OBR",$J,"REPORT","1")="LINE 1"
|
||||
; ^TMP("OBR",$J","REPORT,"2")="LINE 2"
|
||||
;
|
||||
; Descriptions of modules:
|
||||
; PROCFMS - loop through FMS bills (^PRCF(423.6)) updating
|
||||
; global ^TMP("OBR",$J,"BN") while also checking
|
||||
; for invalid AR bills
|
||||
; PROCAR - loop through all Active AR Bills comparing amounts
|
||||
; and looking for Detail bills not found in FMS
|
||||
; BUILDRPT - Prepares report in global ^TMP("OBR",$J,"REPORT")
|
||||
;
|
||||
N X,Y,OBR,A0,ERR
|
||||
K ^TMP("OBR",$J)
|
||||
;
|
||||
I $G(PRCADA) D PROCESS(PRCADA) G Q1
|
||||
S OBR="OBR-",ERR=-1
|
||||
F S OBR=$O(^PRCF(423.6,"B",OBR)) Q:OBR=""!(OBR'["OBR-") D
|
||||
.I $O(^PRCF(423.6,"B",OBR))'["OBR-" D Q
|
||||
..S A0=$O(^PRCF(423.6,"B",OBR,0))
|
||||
..S ERR=0 D PROCESS(A0)
|
||||
I ERR D PROCESS(ERR)
|
||||
Q1 K ^TMP("OBR",$J)
|
||||
Q
|
||||
PROCESS(A0) N X,X1,X2,Y,SN,PARENT,XMTEXT,XMSUB,XMSENDER,XMDUZ,ERR,DATE,FMSDATE
|
||||
S ERR=0 D
|
||||
.I '$D(^PRCF(423.6,A0,0)) S ERR=-1 Q
|
||||
.I $E(^PRCF(423.6,A0,0),1,3)'["OBR" S ERR=-1 Q
|
||||
.S X=$P(^PRCF(423.6,A0,0),"-",2)
|
||||
.S X=$E(X,5,6)_"-"_$E(X,7,8)_"-"_$E(X,1,4) D ^%DT ;Y is defined
|
||||
.S PARENT=$P($P(^PRCF(423.6,A0,0),"-",5),U)
|
||||
.;
|
||||
.D PROCFMS^RCFMOBR1(A0)
|
||||
.D PROCAR^RCFMOBR1(A0)
|
||||
.D BUILDRPT^RCFMOBR2(PARENT)
|
||||
;
|
||||
I '$D(PARENT) S PARENT=$$SITE^RCMSITE
|
||||
S PARENT=$P(^DIC(4,+$O(^DIC(4,"D",PARENT,0)),0),U)
|
||||
;
|
||||
I '$D(Y) S Y=DT ;Y may be defined from %DT call above
|
||||
S X1=Y,X2=($E(Y,6,7)+1)*-1 D C^%DTC,YX^%DTC
|
||||
S FMSDATE=$P(Y,"@"),FMSDATE=$E(FMSDATE,1,4)_$E(FMSDATE,9,12)
|
||||
D NOW^%DTC S DATE=$E(X,4,5)_"-"_$E(X,6,7)_"-"_$E(X,2,3)
|
||||
; - Transmits report via e-mail to FMS mail group
|
||||
S XMSUB="FMS "_FMSDATE_" RECONCILIATION ("_DATE_") "
|
||||
S XMSUB=XMSUB_PARENT
|
||||
I ERR D
|
||||
.S ^TMP("OBR",$J,"REPORT",1)="Date of Report: "_DATE
|
||||
.S ^TMP("OBR",$J,"REPORT",2)="NOTE: This report compares your current A/R records with data received from"
|
||||
.S ^TMP("OBR",$J,"REPORT",3)=" FMS on the last day of the previous accounting period."
|
||||
.S ^TMP("OBR",$J,"REPORT",4)=""
|
||||
.S ^TMP("OBR",$J,"REPORT",5)="No FMS data exists to reconcile!"
|
||||
S XMTEXT="^TMP(""OBR"",$J,""REPORT"","
|
||||
S XMDUZ="Accounts Receivable Package",XMY("G.FMS")="",XMY(DUZ)="" D ^XMD
|
||||
Q
|
||||
EN2 ;Entry point from Regenerate Prior Month OBRs option
|
||||
N DIR,PRCADA,Y
|
||||
W !!,"This option will transmit the OBR report(s) to you and members"
|
||||
W !,"of the G.FMS mail group."
|
||||
W !!,"NOTE: Depending on the number of active AR bills in your system,"
|
||||
W !," this may take awhile to run.",!
|
||||
S DIR(0)="YO",DIR("A")="Are you sure you want to do this",DIR("B")="NO"
|
||||
D ^DIR Q:Y'=1 S ZTRTN="EN^RCFMOBR",ZTDESC="Prior Month OBRs"
|
||||
S ZTIO="" D ^%ZTLOAD Q
|
||||
;
|
||||
EN3 ;Deletes OBRs over 60 days old
|
||||
N A0,A1,A2,DA,DIK,X,X1,X2
|
||||
S A0="OBR-" F S A0=$O(^PRCF(423.6,"B",A0)) Q:A0=""!(A0'["OBR-") S A1=2_$E($P(A0,"-",2),3,8),A2=0 F S A2=$O(^PRCF(423.6,"B",A0,A2)) Q:+A2=0 D
|
||||
.S X1=DT,X2=A1 D ^%DTC I X>60 S DIK="^PRCF(423.6,",DA=A2 D ^DIK
|
||||
Q
|
||||
PURGE ;purge unprocessed document file
|
||||
N DIR,Y,X,X1,X2,RCDT
|
||||
S DIR("A")="How many days worth of DATA do you want to retain"
|
||||
S DIR(0)="N",DIR("?")="This is the number of days entries will remain in the file."
|
||||
D ^DIR
|
||||
I +Y<0!(Y="")!($E(Y,1)="^") G POUT
|
||||
S X1=DT,X2=-(+Y) D C^%DTC S RCDT=X
|
||||
S ZTRTN="QPURGE^RCFMOBR",ZTSAVE("RCDT")="",ZTDESC="Purge unprocessed document list",ZTIO="" D ^%ZTLOAD
|
||||
POUT K DIRUT,DIROUT,DTOUT,DUOUT Q
|
||||
;
|
||||
QPURGE N DA,DIK
|
||||
S DIK="^RC(347,"
|
||||
Q:'$D(^RC(347))
|
||||
S DA=0 F S DA=$O(^RC(347,DA)) Q:'DA I $P(^(DA,0),U,5)<RCDT D ^DIK
|
||||
K RCDT
|
||||
Q
|
||||
|
|
|
|||
|
|
@ -1,81 +1,51 @@
|
|||
RCMSITE ;ALB/RRG - EDIT SITE PARAMETERS ;03/12/02
|
||||
V ;;4.5;Accounts Receivable;**173,236,253**;Mar 20, 1995;Build 9
|
||||
;;Per VHA Directive 2004-038, this routine should not be modified.
|
||||
BEG ;Start editing site paramters
|
||||
N DIC,DLAYGO,X,Y,DIE,DA,DR
|
||||
S DIC="^RC(342,",DIC(0)="QEAML",DLAYGO=342 D ^DIC I Y>0 S DA=+Y,DR=.01,DIE="^RC(342," D ^DIE
|
||||
Q
|
||||
ALC ;Edit ALC parameter
|
||||
NEW DIC,DR,DA,Y
|
||||
S DIE="^RC(342,",DA=1,DR=".07;31" D ^DIE
|
||||
Q
|
||||
IRS ;Edit IRS OFFSET site parameters
|
||||
NEW DIE,DR,DA,Y
|
||||
I '$D(^RC(342,1,0)) D BEG G:'$D(^RC(342,1,0)) Q
|
||||
S DA=1,DR="[RCMS IRS]",DIE="^RC(342," D ^DIE
|
||||
Q Q
|
||||
STAT ;Edit NOTIFICATION site parameters
|
||||
NEW DIE,DR,DA,Y
|
||||
I '$D(^RC(342,1,0)) D BEG G:'$D(^RC(342,1,0)) Q1
|
||||
S DA=1,DR="[RCMS NOTIFICATION]",DIE="^RC(342," D ^DIE
|
||||
Q1 Q
|
||||
GRP ;Edit AR Group Parameters
|
||||
NEW DIE,DR,DA,Y
|
||||
F W ! S DIC(0)="QEAML",DIC="^RC(342.1,",DLAYGO=342.1 D ^DIC K DIC G:Y<0 Q3 S DA=+Y,DIE="^RC(342.1,",DR=$P($G(^RC(342.2,+$P(^RC(342.1,+Y,0),"^",2),1)),"^") I DR]"" D ^DIE
|
||||
Q3 Q
|
||||
DEA ;Deactive an AR group
|
||||
NEW DIE,DIC,DA,DR,Y,GRP
|
||||
S DIC="^RC(342.1,",DIC(0)="QEAM",DIC("S")="I $P(^(0),""^"",2)'=7" D ^DIC Q:Y<0 S GRP=+Y
|
||||
W ! S DIR("A")="Are you sure you want to Deactive Group '"_$P(^RC(342.1,GRP,0),"^")_"'",DIR(0)="Y",DIR("B")="NO" D ^DIR K DIR
|
||||
I 'Y W !!,"*** NO ACTION TAKEN ***" Q
|
||||
I Y S DIE="^RC(342.1,",DA=GRP,DR=".02////^S X=7" D ^DIE W !!,"*** Group Deactivated ***"
|
||||
Q
|
||||
SITE() ;Return site number
|
||||
Q +$G(^DIC(4,+$P($G(^RC(342,1,0)),"^"),99))
|
||||
INT ;Print Inter/Admin/Pen effective report
|
||||
NEW DIC,BY,FR,TO,FLDS,L
|
||||
S DIC="^RC(342,",BY=.01,(FR,TO)="",FLDS="[RCMS INT/ADM/PEN]",L=0 D EN1^DIP
|
||||
Q
|
||||
UPINT ;Update Rate site parameters
|
||||
NEW DIE,DR,DA,Y,IOP
|
||||
S IOP=ION D INT
|
||||
I '$D(^RC(342,1,0)) D BEG G:'$D(^RC(342,1,0)) Q4
|
||||
F W ! S DA=1,DR="[RCMS RATES]",DIE="^RC(342," D ^DIE Q:$D(Y)
|
||||
Q4 Q
|
||||
;
|
||||
EDILOCK ;Update EDI Lockbox site parameters
|
||||
N DIE,DR,DA,Y
|
||||
I '$D(^RC(342,1,0)) D BEG G:'$D(^RC(342,1,0)) Q5
|
||||
S DA=1,DR="[RCMS EDI LOCKBOX]",DIE="^RC(342," D ^DIE
|
||||
Q5 Q
|
||||
;
|
||||
EDITRDDT ;Update # OF DAYS FOR RD ELIG CHG RPT site parameter
|
||||
;This is the number of days for the Rated Disability Eligibility
|
||||
;Change Report to be used when the report is scheduled to be run
|
||||
;on a recurring basis. (Added for Hold Debt to DMC Project)
|
||||
N DIE,DR,DA,Y
|
||||
I '$D(^RC(342,1,0)) D BEG G:'$D(^RC(342,1,0)) Q6
|
||||
S DA=1,DR="8.01",DIE="^RC(342," D ^DIE
|
||||
Q6 Q
|
||||
;
|
||||
GETRDDAY() ;Return # OF DAYS FOR RD ELIG CHG RPT site parameter
|
||||
Q $$GET1^DIQ(342,1_",",8.01)
|
||||
;
|
||||
EDITRDAY ;Update NUMBER OF DAYS FOR DMC REPORTS site parameter.
|
||||
;This is the number of days in the past bills for episodes
|
||||
;of care will be included for the following reports when scheduled by
|
||||
;IRM to be run on a recurring basis:
|
||||
; DMC Debt Validity Report
|
||||
; DMC Debt Validity Management Report
|
||||
; Rated Disability Eligibility Change Report
|
||||
;The minimum value for this field is 365 days (1 year) and the maximum
|
||||
;value is 3650 days (10 years). If no value is added in this field the
|
||||
;report will default to 365 days. (Added for Hold Debt to DMC Project)
|
||||
N DIE,DR,DA,Y
|
||||
I '$D(^RC(342,1,0)) D BEG G:'$D(^RC(342,1,0)) Q7
|
||||
S DA=1,DR="8.02",DIE="^RC(342," D ^DIE
|
||||
Q7 Q
|
||||
;
|
||||
GETRDAY() ;Return NUMBER OF DAYS FOR DMC REPORTS site parameter
|
||||
Q $$GET1^DIQ(342,1_",",8.02)
|
||||
;
|
||||
RCMSITE ;ALB/RRG - EDIT SITE PARAMETERS ;03/12/02
|
||||
V ;;4.5;Accounts Receivable;**173,236**;Mar 20, 1995
|
||||
;;Per VHA Directive 10-93-142, this routine should not be modified.
|
||||
BEG ;Start editing site paramters
|
||||
N DIC,DLAYGO,X,Y,DIE,DA,DR
|
||||
S DIC="^RC(342,",DIC(0)="QEAML",DLAYGO=342 D ^DIC I Y>0 S DA=+Y,DR=.01,DIE="^RC(342," D ^DIE
|
||||
Q
|
||||
ALC ;Edit ALC parameter
|
||||
NEW DIC,DR,DA,Y
|
||||
S DIE="^RC(342,",DA=1,DR=".07;31" D ^DIE
|
||||
Q
|
||||
IRS ;Edit IRS OFFSET site parameters
|
||||
NEW DIE,DR,DA,Y
|
||||
I '$D(^RC(342,1,0)) D BEG G:'$D(^RC(342,1,0)) Q
|
||||
S DA=1,DR="[RCMS IRS]",DIE="^RC(342," D ^DIE
|
||||
Q Q
|
||||
STAT ;Edit NOTIFICATION site parameters
|
||||
NEW DIE,DR,DA,Y
|
||||
I '$D(^RC(342,1,0)) D BEG G:'$D(^RC(342,1,0)) Q1
|
||||
S DA=1,DR="[RCMS NOTIFICATION]",DIE="^RC(342," D ^DIE
|
||||
Q1 Q
|
||||
GRP ;Edit AR Group Parameters
|
||||
NEW DIE,DR,DA,Y
|
||||
F W ! S DIC(0)="QEAML",DIC="^RC(342.1,",DLAYGO=342.1 D ^DIC K DIC G:Y<0 Q3 S DA=+Y,DIE="^RC(342.1,",DR=$P($G(^RC(342.2,+$P(^RC(342.1,+Y,0),"^",2),1)),"^") I DR]"" D ^DIE
|
||||
Q3 Q
|
||||
DEA ;Deactive an AR group
|
||||
NEW DIE,DIC,DA,DR,Y,GRP
|
||||
S DIC="^RC(342.1,",DIC(0)="QEAM",DIC("S")="I $P(^(0),""^"",2)'=7" D ^DIC Q:Y<0 S GRP=+Y
|
||||
W ! S DIR("A")="Are you sure you want to Deactive Group '"_$P(^RC(342.1,GRP,0),"^")_"'",DIR(0)="Y",DIR("B")="NO" D ^DIR K DIR
|
||||
I 'Y W !!,"*** NO ACTION TAKEN ***" Q
|
||||
I Y S DIE="^RC(342.1,",DA=GRP,DR=".02////^S X=7" D ^DIE W !!,"*** Group Deactivated ***"
|
||||
Q
|
||||
SITE() ;Return site number
|
||||
Q +$G(^DIC(4,+$P($G(^RC(342,1,0)),"^"),99))
|
||||
INT ;Print Inter/Admin/Pen effective report
|
||||
NEW DIC,BY,FR,TO,FLDS,L
|
||||
S DIC="^RC(342,",BY=.01,(FR,TO)="",FLDS="[RCMS INT/ADM/PEN]",L=0 D EN1^DIP
|
||||
Q
|
||||
UPINT ;Update Rate site parameters
|
||||
NEW DIE,DR,DA,Y,IOP
|
||||
S IOP=ION D INT
|
||||
I '$D(^RC(342,1,0)) D BEG G:'$D(^RC(342,1,0)) Q4
|
||||
F W ! S DA=1,DR="[RCMS RATES]",DIE="^RC(342," D ^DIE Q:$D(Y)
|
||||
Q4 Q
|
||||
;
|
||||
EDILOCK ;Update EDI Lockbox site parameters
|
||||
N DIE,DR,DA,Y
|
||||
I '$D(^RC(342,1,0)) D BEG G:'$D(^RC(342,1,0)) Q5
|
||||
S DA=1,DR="[RCMS EDI LOCKBOX]",DIE="^RC(342," D ^DIE
|
||||
Q5 Q
|
||||
;
|
||||
|
|
|
|||
|
|
@ -1,67 +1,67 @@
|
|||
RCRCXM1 ;ALB/CMS - AR/RC ORIGINAL TRANSMISSION SET ;09/08/97
|
||||
V ;;4.5;Accounts Receivable;**63,122,189,249**;Mar 20, 1995;Build 2
|
||||
;;Per VHA Directive 10-93-142, this routine should not be modified.
|
||||
;
|
||||
Q
|
||||
;
|
||||
IBS ;Set the IB Bill Information data line from RCRCVXM
|
||||
;Return: ^TMP("RCRCVL",$J,"XM")
|
||||
;S ^TMP("RCRCVL",$J,"XM",PRCABN,1,1)="BN1^BILL#^CAT.ABB^STATUS.ABB^CURRENT BALANCE^BILL TYPE^FORM TYPE^BILL DATE FROM^BILL DATE TO"
|
||||
;S ^TMP("RCRCVL",$J,"XM",PRCABN,1,2)="BN2^TOTAL BILL CHARGES^OFFSET AMT^OFFSET DESC.^DATE FIRST PRINTED^TAX ID^REFERRAL REASON CODE^REFERRAL COMMENT"
|
||||
;S ^TMP("RCRCVL",$J,"XM",PRCABN,2,1)="BINS^NAME OF INSURED^SUBSCRIBER ID#^RELATIONSHIP TO INSURED^CONDITION RELATED TO^"
|
||||
;S ^TMP("RCRCVL",$J,"XM",PRCABN,3,1)="PAT^PAT NAME^SSN^DOB^SEX^SENSITIVE RECORD Y/N^ADD1^ADD2^ADD3^CITY^STATE^ZIP"
|
||||
;S ^TMP("RCRCVL",$J,"XM",PRCABN,4,1)="INS^INSURER NAME^ADD1^ADD2^ADD3^CITY^STATE^ZIP^PHONE^PROVIDER ID#^GROUP NAME^GROUP #"
|
||||
;S ^TMP("RCRCVL",$J,"XM",PRCABN,5,1)="INSUP^DEBTNAME^DEBT ADD1^DEBT ADD2^DEBT ADD3^CITY^STATE^ZIP^PHONE
|
||||
;S ^TMP("RCRCVL",$J,"XM",PRCABN,6,1)="OPV^1^OPV DATE1"
|
||||
;S ^TMP("RCRCVL",$J,"XM",PRCABN,6,2)="OPV^2^OPV DATE2"
|
||||
;S ^TMP("RCRCVL",$J,"XM",PRCABN,7,1)="DXS^1^DIAGNOSIS CODE^DESCRIPTION"
|
||||
;S ^TMP("RCRCVL",$J,"XM",PRCABN,7,2)="DXS^2^DIAGNOSIS CODE^DESCRIPTION"
|
||||
;S ^TMP("RCRCVL",$J,"XM",PRCABN,8,1)="RVC^1^REVENUE CODE^DESCRIPTION^RATE^UNITS^TOTAL CHARGES"
|
||||
;S ^TMP("RCRCVL",$J,"XM",PRCABN,8,2)="RVC^2^REVENUE CODE^DESCRIPTION^RATE^UNITS^TOTAL CHARGES"
|
||||
;S ^TMP("RCRCVL",$J,"XM",PRCABN,9,1)="PRC^1^PROCEDURE CODE^PROCEDURE DATE^PLACE OF SERVICE CODE^PLACE OF SERVICE^TYPE OF SERVICE CODE^TYPE OF SERVICE"
|
||||
;S ^TMP("RCRCVL",$J,"XM",PRCABN,9,2)="PRC^2^PROCEDURE CODE^PROCEDURE DATE^PLACE OF SERVICE CODE^PLACE OF SERVICE^TYPE OF SERVICE CODE^TYPE OF SERVICE"
|
||||
;S ^TMP("RCRCVL",$J,"XM",PRCABN,10,1)="RXF^1^RX #^REFILL DATE^DRUG^NAME^DAYS SUPPLY^QUANTITY^NDC NUMBER"
|
||||
;S ^TMP("RCRCVL",$J,"XM",PRCABN,10,2)="RXF^2^RX #^REFILL DATE^DRUG^NAME^DAYS SUPPLY^QUANTITY^NDC NUMBER"
|
||||
;S ^TMP("RCRCVL",$J,"XM",PRCABN,11,1)="PRD^1^PROSTHETIC DEVICE NAME^DELIVERY DATE"
|
||||
;S ^TMP("RCRCVL",$J,"XM",PRCABN,11,2)="PRD^2^PROSTHETIC DEVICE NAME^DELIVERY DATE"
|
||||
;
|
||||
N RCDR,RCI,RCIB,RCUNK S RCIB=""
|
||||
D BILL^IBRFN3(PRCABN,.RCIB)
|
||||
S RCUNK="UNK"
|
||||
I RCIB=0 S RCA(PRCABN,RCY)="No IB Bill/Claim Information" G IBSQ
|
||||
; - allow sites to refer bill but not electronically
|
||||
I $P($G(RCCAT(+$G(PRCA("CAT")))),U,1)'=1 S ^TMP("RCRCVL",$J,"XM",PRCABN,0)=RCY G IBSQ
|
||||
; - set XM primary bill information
|
||||
S RCCNT=RCCNT+1
|
||||
S ^TMP("RCRCVL",$J,"XM",PRCABN,0)=RCY
|
||||
S RCDR="BN1^"_$G(PRCA("BNAME"),RCUNK)_U_$P($G(PRCA("CAT")),U,3)_U_$P($G(PRCA("STATUS")),U,3)_U_+$P($$BILL^RCJIBFN2(PRCABN),U,3)_U_$G(RCIB("TOC"))_U_$G(RCIB("TCF"))_U_$G(RCIB("STF"))_U_$G(RCIB("STT"))
|
||||
S ^TMP("RCRCVL",$J,"XM",PRCABN,1,1)=RCDR S RCDR=""
|
||||
S ^TMP("RCRCVL",$J,"XM",PRCABN,1,2)="BN2^"_$G(RCIB("TCG"))_U_$G(RCIB("DFP"))_U_$G(RCIB("TAX"))_U_$G(PRCA("REF REASON"))
|
||||
S ^TMP("RCRCVL",$J,"XM",PRCABN,2,1)="BINS^"_$P($G(RCIB("PIN")),U,5)_U_$P($G(RCIB("PIN")),U,6)_U_$P($G(RCIB("PIN")),U,7)_U_$S($G(RCIB("CRE"))]"":RCIB("CRE"),$G(RCIB("CRA"))]"":RCIB("CRA"),$G(RCIB("CRO"))]"":RCIB("CRO"),1:"")
|
||||
S ^TMP("RCRCVL",$J,"XM",PRCABN,3,1)="PAT^"_$E($G(VADM(1),RCUNK),1,30)_U_$P($G(VADM(2)),U,1)_U_$P($G(VADM(3)),U,1)_U_$P($G(VADM(5)),U)_U_$G(RCIB("SR"))_U_$G(VAPA(1))_U_$G(VAPA(2))_U_$G(VAPA(3))_U_$G(VAPA(4))_U_$P($G(VAPA(5)),U,2)_U_+$G(VAPA(6))
|
||||
S ^TMP("RCRCVL",$J,"XM",PRCABN,4,1)="INS^"_$P($G(RCIB("PIN")),U,1)_U_$G(RCIB("PIN","MMA"))_U_$P($G(RCIB("PIN")),U,2,4)
|
||||
;
|
||||
; - set multiples if defined
|
||||
I $O(RCIB("OPV",0)) S RCI=0 F S RCI=$O(RCIB("OPV",RCI)) Q:'RCI D
|
||||
.S ^TMP("RCRCVL",$J,"XM",PRCABN,6,RCI)="OPV^"_RCI_U_RCIB("OPV",RCI)
|
||||
I $O(RCIB("DXS",0)) S RCI=0 F S RCI=$O(RCIB("DXS",RCI)) Q:'RCI D
|
||||
.S ^TMP("RCRCVL",$J,"XM",PRCABN,7,RCI)="DXS^"_RCI_U_RCIB("DXS",RCI)
|
||||
I $O(RCIB("RVC",0)) S RCI=0 F S RCI=$O(RCIB("RCV",RCI)) Q:'RCI D
|
||||
.S ^TMP("RCRCVL",$J,"XM",PRCABN,8,RCI)="RVC^"_RCI_U_RCIB("RCV",RCI)
|
||||
I $O(RCIB("PRC",0)) S RCI=0 F S RCI=$O(RCIB("PRC",RCI)) Q:'RCI D
|
||||
.S ^TMP("RCRCVL",$J,"XM",PRCABN,9,RCI)="PRC^"_RCI_U_RCIB("PRC",RCI)
|
||||
I $O(RCIB("RXF",0)) S RCI=0 F S RCI=$O(RCIB("RXF",RCI)) Q:'RCI D
|
||||
.S ^TMP("RCRCVL",$J,"XM",PRCABN,10,RCI)="RXF^"_RCI_U_RCIB("RXF",RCI)
|
||||
I $O(RCIB("PDR",0)) S RCI=0 F S RCI=$O(RCIB("PDR",RCI)) Q:'RCI D
|
||||
.S ^TMP("RCRCVL",$J,"XM",PRCABN,11,RCI)="PDR^"_RCI_U_RCIB("PDR",RCI)
|
||||
;
|
||||
; - set Current Debtor Name and Address if different
|
||||
S RCI=""
|
||||
I $G(PRCA("DEBTNM"))'=$P($G(RCIB("PIN")),U,1) S RCI=1
|
||||
I 'RCI,$G(PRCA("DEBTAD1"))'=$P($G(RCIB("PIN","MMA")),U,1) S RCI=1
|
||||
I 'RCI,$P($G(PRCA("DEBTADD")),U,7)'=$P($G(PRCA("PIN","MMA")),U,7)
|
||||
I RCI S ^TMP("RCRCVL",$J,"XM",PRCABN,5,1)="INSUP^"_$E($G(PRCA("DEBTNM")),1,30)_U_$G(PRCA("DEBTAD1"))_U_$G(PRCA("DEBTAD2"))_U_$G(PRCA("DEBTAD3"))_U_$G(PRCA("DEBTCT"))_U_$G(PRCA("DEBTST"))_U_$G(PRCA("DEBTZIP"))_U_$P($G(PRCA("DEBTADD")),U,7)
|
||||
;
|
||||
IBSQ K DFN,PRCA,RCCAT,VA,VADM,VAPA
|
||||
Q
|
||||
;RCRCXM1
|
||||
RCRCXM1 ;ALB/CMS - AR/RC ORIGINAL TRANSMISSION SET ;09/08/97
|
||||
V ;;4.5;Accounts Receivable;**63,122,189**;Mar 20, 1995
|
||||
;;Per VHA Directive 10-93-142, this routine should not be modified.
|
||||
;
|
||||
Q
|
||||
;
|
||||
IBS ;Set the IB Bill Information data line from RCRCVXM
|
||||
;Return: ^TMP("RCRCVL",$J,"XM")
|
||||
;S ^TMP("RCRCVL",$J,"XM",PRCABN,1,1)="BN1^BILL#^CAT.ABB^STATUS.ABB^CURRENT BALANCE^BILL TYPE^FORM TYPE^BILL DATE FROM^BILL DATE TO"
|
||||
;S ^TMP("RCRCVL",$J,"XM",PRCABN,1,2)="BN2^TOTAL BILL CHARGES^OFFSET AMT^OFFSET DESC.^DATE FIRST PRINTED^TAX ID^REFERRAL REASON CODE^REFERRAL COMMENT"
|
||||
;S ^TMP("RCRCVL",$J,"XM",PRCABN,2,1)="BINS^NAME OF INSURED^SUBSCRIBER ID#^RELATIONSHIP TO INSURED^CONDITION RELATED TO^"
|
||||
;S ^TMP("RCRCVL",$J,"XM",PRCABN,3,1)="PAT^PAT NAME^SSN^DOB^SEX^SENSITIVE RECORD Y/N^ADD1^ADD2^ADD3^CITY^STATE^ZIP"
|
||||
;S ^TMP("RCRCVL",$J,"XM",PRCABN,4,1)="INS^INSURER NAME^ADD1^ADD2^ADD3^CITY^STATE^ZIP^PHONE^PROVIDER ID#^GROUP NAME^GROUP #"
|
||||
;S ^TMP("RCRCVL",$J,"XM",PRCABN,5,1)="INSUP^DEBTNAME^DEBT ADD1^DEBT ADD2^DEBT ADD3^CITY^STATE^ZIP^PHONE
|
||||
;S ^TMP("RCRCVL",$J,"XM",PRCABN,6,1)="OPV^1^OPV DATE1"
|
||||
;S ^TMP("RCRCVL",$J,"XM",PRCABN,6,2)="OPV^2^OPV DATE2"
|
||||
;S ^TMP("RCRCVL",$J,"XM",PRCABN,7,1)="DXS^1^DIAGNOSIS CODE^DESCRIPTION"
|
||||
;S ^TMP("RCRCVL",$J,"XM",PRCABN,7,2)="DXS^2^DIAGNOSIS CODE^DESCRIPTION"
|
||||
;S ^TMP("RCRCVL",$J,"XM",PRCABN,8,1)="RVC^1^REVENUE CODE^DESCRIPTION^RATE^UNITS^TOTAL CHARGES"
|
||||
;S ^TMP("RCRCVL",$J,"XM",PRCABN,8,2)="RVC^2^REVENUE CODE^DESCRIPTION^RATE^UNITS^TOTAL CHARGES"
|
||||
;S ^TMP("RCRCVL",$J,"XM",PRCABN,9,1)="PRC^1^PROCEDURE CODE^PROCEDURE DATE^PLACE OF SERVICE CODE^PLACE OF SERVICE^TYPE OF SERVICE CODE^TYPE OF SERVICE"
|
||||
;S ^TMP("RCRCVL",$J,"XM",PRCABN,9,2)="PRC^2^PROCEDURE CODE^PROCEDURE DATE^PLACE OF SERVICE CODE^PLACE OF SERVICE^TYPE OF SERVICE CODE^TYPE OF SERVICE"
|
||||
;S ^TMP("RCRCVL",$J,"XM",PRCABN,10,1)="RXF^1^RX #^REFILL DATE^DRUG^NAME^DAYS SUPPLY^QUANTITY^NDC NUMBER"
|
||||
;S ^TMP("RCRCVL",$J,"XM",PRCABN,10,2)="RXF^2^RX #^REFILL DATE^DRUG^NAME^DAYS SUPPLY^QUANTITY^NDC NUMBER"
|
||||
;S ^TMP("RCRCVL",$J,"XM",PRCABN,11,1)="PRD^1^PROSTHETIC DEVICE NAME^DELIVERY DATE"
|
||||
;S ^TMP("RCRCVL",$J,"XM",PRCABN,11,2)="PRD^2^PROSTHETIC DEVICE NAME^DELIVERY DATE"
|
||||
;
|
||||
N RCDR,RCI,RCIB,RCUNK S RCIB=""
|
||||
D BILL^IBRFN3(PRCABN,.RCIB)
|
||||
S RCUNK="UNK"
|
||||
I RCIB=0 S RCA(PRCABN,RCY)="No IB Bill/Claim Information" G IBSQ
|
||||
; - allow sites to refer bill but not electronically
|
||||
I $P($G(RCCAT(+$G(PRCA("CAT")))),U,1)'=1 S ^TMP("RCRCVL",$J,"XM",PRCABN,0)=RCY G IBSQ
|
||||
; - set XM primary bill information
|
||||
S RCCNT=RCCNT+1
|
||||
S ^TMP("RCRCVL",$J,"XM",PRCABN,0)=RCY
|
||||
S RCDR="BN1^"_$G(PRCA("BNAME"),RCUNK)_U_$P($G(PRCA("CAT")),U,3)_U_$P($G(PRCA("STATUS")),U,3)_U_+$P($$BILL^RCJIBFN2(PRCABN),U,3)_U_$G(RCIB("TOC"))_U_$G(RCIB("TCF"))_U_$G(RCIB("STF"))_U_$G(RCIB("STT"))
|
||||
S ^TMP("RCRCVL",$J,"XM",PRCABN,1,1)=RCDR S RCDR=""
|
||||
S ^TMP("RCRCVL",$J,"XM",PRCABN,1,2)="BN2^"_$G(RCIB("TCG"))_U_$G(RCIB("DFP"))_U_$G(RCIB("TAX"))_U_$G(PRCA("REF REASON"))
|
||||
S ^TMP("RCRCVL",$J,"XM",PRCABN,2,1)="BINS^"_$P($G(RCIB("PIN")),U,5)_U_$P($G(RCIB("PIN")),U,6)_U_$P($G(RCIB("PIN")),U,7)_U_$S($G(RCIB("CRE"))]"":RCIB("CRE"),$G(RCIB("CRA"))]"":RCIB("CRA"),$G(RCIB("CRO"))]"":RCIB("CRO"),1:"")
|
||||
S ^TMP("RCRCVL",$J,"XM",PRCABN,3,1)="PAT^"_$E($G(VADM(1),RCUNK),1,30)_U_$P($G(VADM(2)),U,1)_U_$P($G(VADM(3)),U,1)_U_$P($G(VADM(5)),U)_U_$G(RCIB("SR"))_U_$G(VAPA(1))_U_$G(VAPA(2))_U_$G(VAPA(3))_U_$G(VAPA(4))_U_$P($G(VAPA(5)),U,2)_U_+$G(VAPA(6))
|
||||
S ^TMP("RCRCVL",$J,"XM",PRCABN,4,1)="INS^"_$P($G(RCIB("PIN")),U,1)_U_$G(RCIB("PIN","MMA"))_U_$P($G(RCIB("PIN")),2,4)
|
||||
;
|
||||
; - set multiples if defined
|
||||
I $O(RCIB("OPV",0)) S RCI=0 F S RCI=$O(RCIB("OPV",RCI)) Q:'RCI D
|
||||
.S ^TMP("RCRCVL",$J,"XM",PRCABN,6,RCI)="OPV^"_RCI_U_RCIB("OPV",RCI)
|
||||
I $O(RCIB("DXS",0)) S RCI=0 F S RCI=$O(RCIB("DXS",RCI)) Q:'RCI D
|
||||
.S ^TMP("RCRCVL",$J,"XM",PRCABN,7,RCI)="DXS^"_RCI_U_RCIB("DXS",RCI)
|
||||
I $O(RCIB("RVC",0)) S RCI=0 F S RCI=$O(RCIB("RCV",RCI)) Q:'RCI D
|
||||
.S ^TMP("RCRCVL",$J,"XM",PRCABN,8,RCI)="RVC^"_RCI_U_RCIB("RCV",RCI)
|
||||
I $O(RCIB("PRC",0)) S RCI=0 F S RCI=$O(RCIB("PRC",RCI)) Q:'RCI D
|
||||
.S ^TMP("RCRCVL",$J,"XM",PRCABN,9,RCI)="PRC^"_RCI_U_RCIB("PRC",RCI)
|
||||
I $O(RCIB("RXF",0)) S RCI=0 F S RCI=$O(RCIB("RXF",RCI)) Q:'RCI D
|
||||
.S ^TMP("RCRCVL",$J,"XM",PRCABN,10,RCI)="RXF^"_RCI_U_RCIB("RXF",RCI)
|
||||
I $O(RCIB("PDR",0)) S RCI=0 F S RCI=$O(RCIB("PDR",RCI)) Q:'RCI D
|
||||
.S ^TMP("RCRCVL",$J,"XM",PRCABN,11,RCI)="PDR^"_RCI_U_RCIB("PDR",RCI)
|
||||
;
|
||||
; - set Current Debtor Name and Address if different
|
||||
S RCI=""
|
||||
I $G(PRCA("DEBTNM"))'=$P($G(RCIB("PIN")),U,1) S RCI=1
|
||||
I 'RCI,$G(PRCA("DEBTAD1"))'=$P($G(RCIB("PIN","MMA")),U,1) S RCI=1
|
||||
I 'RCI,$P($G(PRCA("DEBTADD")),U,7)'=$P($G(PRCA("PIN","MMA")),U,7)
|
||||
I RCI S ^TMP("RCRCVL",$J,"XM",PRCABN,5,1)="INSUP^"_$E($G(PRCA("DEBTNM")),1,30)_U_$G(PRCA("DEBTAD1"))_U_$G(PRCA("DEBTAD2"))_U_$G(PRCA("DEBTAD3"))_U_$G(PRCA("DEBTCT"))_U_$G(PRCA("DEBTST"))_U_$G(PRCA("DEBTZIP"))_U_$P($G(PRCA("DEBTADD")),U,7)
|
||||
;
|
||||
IBSQ K DFN,PRCA,RCCAT,VA,VADM,VAPA
|
||||
Q
|
||||
;RCRCXM1
|
||||
|
|
|
|||
|
|
@ -1,53 +1,51 @@
|
|||
RCXVDC ;DAOU/ALA-AR Data Extraction Data Creation ;02-JUL-03
|
||||
;;4.5;Accounts Receivable;**201,228,256**;Mar 20, 1995;Build 6
|
||||
;;Per VHA Directive 2004-038, this routine should not be modified.
|
||||
;
|
||||
Q
|
||||
EN ; Entry Point
|
||||
NEW RCXVD0,RCXVEVDT,RCXVBCN
|
||||
NEW RCXVI,RCXVCP,RCXVPC,RCXVPFDT,RCXVPTDT
|
||||
NEW RCXVBLNA,RCXVBLNB,RCXVICN
|
||||
I DFN="" S DFN=$P($G(^PRCA(430,RCXVBLN,0)),U,7) ;
|
||||
K ^TMP($J)
|
||||
D D430^RCXVDC1
|
||||
I DFN'="" D D2^RCXVDC2
|
||||
D D399^RCXVDC3
|
||||
D D399PC^RCXVDC4
|
||||
D D350^RCXVDC5
|
||||
D D3625^RCXVDC7
|
||||
I RCXVRT="D"!(RCXVRT="C")!(RCXVRT="E") D D433^RCXVDC6
|
||||
I RCXVRT="H" D D433B^RCXVDC6
|
||||
;
|
||||
FILE ;
|
||||
W "REC:"_RCXVBLNA,!
|
||||
W "430:"_$G(^TMP($J,RCXVBLN,"1-430A"))_RCXVU
|
||||
W $G(^TMP($J,RCXVBLN,"1-430B"))_RCXVU
|
||||
W $G(^TMP($J,RCXVBLN,"1-430C"))
|
||||
W !
|
||||
I DFN'="" W "2:"_$G(^TMP($J,RCXVBLN,"2-2A"))_RCXVU_$G(^TMP($J,RCXVBLN,"2-2B")),!
|
||||
I $G(^TMP($J,RCXVBLN,"3-399A"))'="" W "399:"_^TMP($J,RCXVBLN,"3-399A")_RCXVU_^TMP($J,RCXVBLN,"3-399B")_RCXVU_^TMP($J,RCXVBLN,"3-399C")_RCXVU_^TMP($J,RCXVBLN,"3-399D"),!
|
||||
S RCXVPC=0
|
||||
F S RCXVPC=$O(^TMP($J,RCXVBLN,"4-399A",RCXVPC)) Q:'RCXVPC D
|
||||
. I $G(^TMP($J,RCXVBLN,"4-399A",RCXVPC))'="" D
|
||||
.. W "399.0304:"
|
||||
.. W $G(^TMP($J,RCXVBLN,"4-399A",RCXVPC))
|
||||
.. W RCXVU
|
||||
.. F RCXVCP=1:1 Q:('$D(^TMP($J,RCXVBLN,"4-399A",RCXVPC,RCXVCP))) D
|
||||
... I RCXVCP>1 W "~"
|
||||
... W $G(^TMP($J,RCXVBLN,"4-399A",RCXVPC,RCXVCP))
|
||||
... Q
|
||||
.. W !
|
||||
. I $G(^TMP($J,RCXVBLN,"4-399B",RCXVPC))'="" W "399.042:"_$G(^TMP($J,RCXVBLN,"4-399B",RCXVPC)),!
|
||||
. Q
|
||||
S RCXVI=""
|
||||
F S RCXVI=$O(^TMP($J,RCXVBLN,"5-350A",RCXVI)) Q:RCXVI="" D
|
||||
. W "350:"_^TMP($J,RCXVBLN,"5-350A",RCXVI),!
|
||||
S RCXVI=""
|
||||
F S RCXVI=$O(^TMP($J,RCXVBLN,"7-362.5A",RCXVI)) Q:RCXVI="" D
|
||||
. W "362.5:"_^TMP($J,RCXVBLN,"7-362.5A",RCXVI),!
|
||||
; LOOP THRU ^TMP($J,RCXVBLN,"6-433A",RCXVI)
|
||||
S RCXVI=""
|
||||
F S RCXVI=$O(^TMP($J,RCXVBLN,"6-433A",RCXVI)) Q:RCXVI="" D
|
||||
. W "433:"_$G(^TMP($J,RCXVBLN,"6-433A",RCXVI)),!
|
||||
. Q
|
||||
Q
|
||||
RCXVDC ;DAOU/ALA-AR Data Extraction Data Creation ;02-JUL-03
|
||||
;;4.5;Accounts Receivable;**201,228**;Mar 20, 1995
|
||||
;
|
||||
Q
|
||||
EN ; Entry Point
|
||||
NEW RCXVD0,RCXVEVDT,RCXVBCN
|
||||
NEW RCXVI,RCXVCP,RCXVPC,RCXVPFDT,RCXVPTDT
|
||||
NEW RCXVBLNA,RCXVBLNB,RCXVICN
|
||||
I DFN="" S DFN=$P($G(^PRCA(430,RCXVBLN,0)),U,7) ;
|
||||
K ^TMP($J)
|
||||
D D430^RCXVDC1
|
||||
I DFN'="" D D2^RCXVDC2
|
||||
D D399^RCXVDC3
|
||||
D D399PC^RCXVDC4
|
||||
D D350^RCXVDC5
|
||||
D D3625^RCXVDC7
|
||||
I RCXVRT="D"!(RCXVRT="C")!(RCXVRT="E") D D433^RCXVDC6
|
||||
I RCXVRT="H" D D433B^RCXVDC6
|
||||
;
|
||||
FILE ;
|
||||
W "REC:"_RCXVBLNA,!
|
||||
W "430:"_$G(^TMP($J,RCXVBLN,"1-430A"))_RCXVU
|
||||
W $G(^TMP($J,RCXVBLN,"1-430B"))_RCXVU
|
||||
W $G(^TMP($J,RCXVBLN,"1-430C"))
|
||||
W !
|
||||
I DFN'="" W "2:"_$G(^TMP($J,RCXVBLN,"2-2A"))_RCXVU_$G(^TMP($J,RCXVBLN,"2-2B")),!
|
||||
I $G(^TMP($J,RCXVBLN,"3-399A"))'="" W "399:"_^TMP($J,RCXVBLN,"3-399A")_RCXVU_^TMP($J,RCXVBLN,"3-399B")_RCXVU_^TMP($J,RCXVBLN,"3-399C")_RCXVU_^TMP($J,RCXVBLN,"3-399D"),!
|
||||
S RCXVPC=0
|
||||
F S RCXVPC=$O(^TMP($J,RCXVBLN,"4-399A",RCXVPC)) Q:'RCXVPC D
|
||||
. W "399.0304:"
|
||||
. W $G(^TMP($J,RCXVBLN,"4-399A",RCXVPC))
|
||||
. W RCXVU
|
||||
. F RCXVCP=1:1 Q:('$D(^TMP($J,RCXVBLN,"4-399A",RCXVPC,RCXVCP))) D
|
||||
. . I RCXVCP>1 W "~"
|
||||
. . W $G(^TMP($J,RCXVBLN,"4-399A",RCXVPC,RCXVCP))
|
||||
. . Q
|
||||
. W !
|
||||
. I $D(^TMP($J,RCXVBLN,"4-399B",RCXVPC)) W "399.042:"_$G(^TMP($J,RCXVBLN,"4-399B",RCXVPC)),!
|
||||
. Q
|
||||
S RCXVI=""
|
||||
F S RCXVI=$O(^TMP($J,RCXVBLN,"5-350A",RCXVI)) Q:RCXVI="" D
|
||||
. W "350:"_^TMP($J,RCXVBLN,"5-350A",RCXVI),!
|
||||
S RCXVI=""
|
||||
F S RCXVI=$O(^TMP($J,RCXVBLN,"7-362.5A",RCXVI)) Q:RCXVI="" D
|
||||
. W "362.5:"_^TMP($J,RCXVBLN,"7-362.5A",RCXVI),!
|
||||
; LOOP THRU ^TMP($J,RCXVBLN,"6-433A",RCXVI)
|
||||
S RCXVI=""
|
||||
F S RCXVI=$O(^TMP($J,RCXVBLN,"6-433A",RCXVI)) Q:RCXVI="" D
|
||||
. W "433:"_$G(^TMP($J,RCXVBLN,"6-433A",RCXVI)),!
|
||||
. Q
|
||||
Q
|
||||
|
|
|
|||
|
|
@ -1,95 +1,69 @@
|
|||
RCXVDC4 ;DAOU/ALA-AR Data Extraction Data Creation ;02-JUL-03
|
||||
;;4.5;Accounts Receivable;**201,227,228,248,251,256**;Mar 20, 1995;Build 6
|
||||
;;Per VHA Directive 2004-038, this routine should not be modified.
|
||||
;
|
||||
; Procedures
|
||||
Q
|
||||
D399PC ;
|
||||
I RCXVD0="" Q
|
||||
N RCXVD,RCXVDA,RCXVB,RCXVPC,RCXVP1,RCXVP2,RCXVP3,RCXVMULT
|
||||
N RCXVDT3,RCXVCP,RCXVPCDT,RCXVPS1,RCXVPS2,RCXVPS,RCXVPSER,RCXVNPI,RCXVCNT,RCXVMH
|
||||
;RCXVPC=PROC. CODE IEN, RCXVCP=CPT CODE IEN
|
||||
; LOOP THRU PROC.
|
||||
S RCXVMH="",(RCXVPC,RCXVCNT)=0
|
||||
F S RCXVPC=$O(^DGCR(399,RCXVD0,"CP",RCXVPC)) Q:'RCXVPC D D399PCA
|
||||
S RCXVPC=0
|
||||
F S RCXVPC=$O(^DGCR(399,RCXVD0,"RC",RCXVPC)) Q:'RCXVPC D D39942
|
||||
Q
|
||||
D399PCA ;
|
||||
S RCXVD=$G(^DGCR(399,RCXVD0,"CP",RCXVPC,0)) Q:RCXVD=""
|
||||
S RCXVP1=$P(RCXVD,U,1),RCXVVP="",RCXVVP1=""
|
||||
I RCXVP1'="" S RCXVVP="^"_$P(RCXVP1,";",2)_$P(RCXVP1,";",1)_",0)"
|
||||
I RCXVVP'="" S RCXVVP1=$P($G(@RCXVVP),U,1) I RCXVVP1="" D
|
||||
. NEW CT
|
||||
. S CT=$G(^TMP("RCXVBREC",$J,0))+1,^TMP("RCXVBREC",$J,0)=CT
|
||||
. S ^TMP("RCXVBREC",$J,CT,0)="Bill # "_$P($G(^DGCR(399,RCXVD0,0)),"^",1)_" has a bad CPT code at IEN # "_RCXVPC_" check ^DGCR(399,"_RCXVD0_",""CP"","_RCXVPC_",0)"
|
||||
S RCXVDA=RCXVBLNA_RCXVU_RCXVVP1 ; PROC.
|
||||
S RCXVDT=$P(RCXVD,U,2)
|
||||
S RCXVPCDT=$E($$HLDATE^HLFNC(RCXVDT),1,8)
|
||||
S RCXVDA=RCXVDA_RCXVU_RCXVPCDT ; DT
|
||||
S RCXVP1=$P(RCXVD,U,11),RCXVP2=""
|
||||
I RCXVP1'="" S RCXVP1=$P($G(^IBA(362.3,RCXVP1,0)),U,1)
|
||||
I RCXVP1'="" S RCXVP2=$P($G(^ICD9(RCXVP1,0)),U,1)
|
||||
S RCXVDA=RCXVDA_RCXVU_RCXVP2 ; ASSOC DXN (1)
|
||||
S RCXVP1=$P(RCXVD,U,7),RCXVP2=""
|
||||
I RCXVP1'="" S RCXVP2=$P($G(^SC(RCXVP1,0)),U,1)
|
||||
S RCXVDA=RCXVDA_RCXVU_RCXVP2 ; ASSC. CLNC (P)
|
||||
S RCXVP1=$P(RCXVD,U,18),(RCXVP2,RCXVPS,RCXVPSER,RCXVNPI)=""
|
||||
I RCXVP1'="" S RCXVP2=$$GET1^DIQ(200,RCXVP1_",",.01,"E"),RCXVNPI=$P($$NPI^XUSNPI("Individual_ID",RCXVP1),RCXVU,1) S:+RCXVNPI<1 RCXVNPI="" D
|
||||
. S RCXVPS=$$GET^XUA4A72(RCXVP1,RCXVDT)
|
||||
. S RCXVPS=$P(RCXVPS,U,3)
|
||||
. S RCXVPSER=$$GET1^DIQ(200,RCXVP1_",",29,"E")
|
||||
. Q
|
||||
;provider^provider npi^specialty^service/section
|
||||
S RCXVDA=RCXVDA_RCXVU_RCXVP2_RCXVU_RCXVNPI_RCXVU_RCXVPS_RCXVU_RCXVPSER
|
||||
S RCXVCNT=RCXVCNT+1,^TMP($J,RCXVBLN,"4-399A",RCXVCNT)=RCXVDA
|
||||
; LOOP THRU CPT
|
||||
S RCXVCP=0,RCXVMULT=0
|
||||
F S RCXVCP=$O(^DGCR(399,RCXVD0,"CP",RCXVPC,"MOD",RCXVCP)) Q:'RCXVCP D
|
||||
. Q:'($D(^DGCR(399,RCXVD0,"CP",RCXVPC,"MOD",RCXVCP,0)))
|
||||
. ; ^DGCR(399,D0,CP,D1,MOD,D2,0)= (#.01) CPT MODIFIER SEQUENCE [1N]
|
||||
. ; (#.02) CPT ==>MODIFIER [2P:81.3]
|
||||
. S RCXVP1=$P($G(^DGCR(399,RCXVD0,"CP",RCXVPC,"MOD",RCXVCP,0)),U,2)
|
||||
. Q:RCXVP1=""
|
||||
. S RCXVMULT=RCXVMULT+1
|
||||
. S RCXVP2=$P($G(^DIC(81.3,RCXVP1,0)),U,1)
|
||||
. S ^TMP($J,RCXVBLN,"4-399A",RCXVCNT,RCXVMULT)=RCXVP2
|
||||
. Q
|
||||
;
|
||||
; *256 - loop through 399.042 to find CPT procedure
|
||||
MATCH N RCXVCPT1,RCXVFND,X
|
||||
S RCXVCPT1=$P(RCXVD,";",1) ;proc
|
||||
S (RCXVFND,RCXVCP)=0
|
||||
F S RCXVCP=$O(^DGCR(399,RCXVD0,"RC",RCXVCP)) Q:'RCXVCP!RCXVFND D
|
||||
. Q:$F(RCXVMH,";"_RCXVCP) ;quit if CPT proc match
|
||||
. S RCXVD1=$G(^DGCR(399,RCXVD0,"RC",RCXVCP,0))
|
||||
. Q:RCXVD1=""
|
||||
. S X=$P(RCXVD1,U,6) ;CPT proc
|
||||
. I RCXVCPT1'="",X'="",RCXVCPT1=X D
|
||||
.. S RCXVFND=1
|
||||
.. S X=$P(RCXVD1,U)
|
||||
.. S RCXVDB=RCXVBLNA_RCXVU_$$GET1^DIQ(399.2,X_",",.01,"E") ; Revenue Code
|
||||
.. S X=$P(RCXVD1,U,6)
|
||||
.. S RCXVDB=RCXVDB_RCXVU_$$GET1^DIQ(81,X_",",.01,"E") ; Procedures [P]
|
||||
.. S RCXVDB=RCXVDB_RCXVU_RCXVPCDT ; PROC. DT
|
||||
.. S RCXVDB=RCXVDB_RCXVU_$P(RCXVD1,U,2) ; Charges
|
||||
.. S ^TMP($J,RCXVBLN,"4-399B",RCXVCNT)=RCXVDB
|
||||
.. S RCXVMH=RCXVMH_";"_RCXVCP
|
||||
I 'RCXVFND S ^TMP($J,RCXVBLN,"4-399B",RCXVCNT)=""
|
||||
Q
|
||||
;
|
||||
D39942 ; charge
|
||||
N X
|
||||
Q:$F(RCXVMH,";"_RCXVPC)
|
||||
S RCXVD1=$G(^DGCR(399,RCXVD0,"RC",RCXVPC,0))
|
||||
Q:RCXVD1=""
|
||||
S X=$P(RCXVD1,U)
|
||||
S RCXVDB=RCXVBLNA_RCXVU_$$GET1^DIQ(399.2,X_",",.01,"E") ; Revenue Code
|
||||
S RCXVDB=RCXVDB_RCXVU_"" ;No CPT proc
|
||||
S RCXVDB=RCXVDB_RCXVU_"" ; No proc dt
|
||||
S RCXVDB=RCXVDB_RCXVU_$P(RCXVD1,U,2) ; Charges
|
||||
S RCXVCNT=RCXVCNT+1
|
||||
S ^TMP($J,RCXVBLN,"4-399A",RCXVCNT)=""
|
||||
S ^TMP($J,RCXVBLN,"4-399B",RCXVCNT)=RCXVDB
|
||||
Q
|
||||
;
|
||||
RCXVDC4 ;DAOU/ALA-AR Data Extraction Data Creation ;02-JUL-03
|
||||
;;4.5;Accounts Receivable;**201,227,228,248,251**;Mar 20, 1995;Build 21
|
||||
;;Per VHA Directive 2004-038, this routine should not be modified.
|
||||
;
|
||||
; Procedures
|
||||
Q
|
||||
D399PC ;
|
||||
I RCXVD0="" Q
|
||||
N RCXVD,RCXVDA,RCXVB,RCXVPC,RCXVP1,RCXVP2,RCXVP3,RCXVMULT
|
||||
N RCXVDT3,RCXVCP,RCXVPCDT,RCXVPS1,RCXVPS2,RCXVPS,RCXVPSER,RCXVNPI
|
||||
;RCXVPC=PROC. CODE IEN, RCXVCP=CPT CODE IEN
|
||||
; LOOP THRU PROC.
|
||||
S RCXVPC=0
|
||||
F S RCXVPC=$O(^DGCR(399,RCXVD0,"CP",RCXVPC)) Q:'RCXVPC D D399PCA
|
||||
Q
|
||||
D399PCA ;
|
||||
S RCXVD=$G(^DGCR(399,RCXVD0,"CP",RCXVPC,0)) Q:RCXVD=""
|
||||
S RCXVP1=$P(RCXVD,U,1),RCXVVP="",RCXVVP1=""
|
||||
I RCXVP1'="" S RCXVVP="^"_$P(RCXVP1,";",2)_$P(RCXVP1,";",1)_",0)"
|
||||
I RCXVVP'="" S RCXVVP1=$P($G(@RCXVVP),U,1) I RCXVVP1="" D
|
||||
. NEW CT
|
||||
. S CT=$G(^TMP("RCXVBREC",$J,0))+1,^TMP("RCXVBREC",$J,0)=CT
|
||||
. S ^TMP("RCXVBREC",$J,CT,0)="Bill # "_$P($G(^DGCR(399,RCXVD0,0)),"^",1)_" has a bad CPT code at IEN # "_RCXVPC_" check ^DGCR(399,"_RCXVD0_",""CP"","_RCXVPC_",0)"
|
||||
S RCXVDA=RCXVBLNA_RCXVU_RCXVVP1 ; PROC.
|
||||
S RCXVDT=$P(RCXVD,U,2)
|
||||
S RCXVPCDT=$E($$HLDATE^HLFNC(RCXVDT),1,8)
|
||||
S RCXVDA=RCXVDA_RCXVU_RCXVPCDT ; DT
|
||||
S RCXVP1=$P(RCXVD,U,11),RCXVP2=""
|
||||
I RCXVP1'="" S RCXVP1=$P($G(^IBA(362.3,RCXVP1,0)),U,1)
|
||||
I RCXVP1'="" S RCXVP2=$P($G(^ICD9(RCXVP1,0)),U,1)
|
||||
S RCXVDA=RCXVDA_RCXVU_RCXVP2 ; ASSOC DXN (1)
|
||||
S RCXVP1=$P(RCXVD,U,7),RCXVP2=""
|
||||
I RCXVP1'="" S RCXVP2=$P($G(^SC(RCXVP1,0)),U,1)
|
||||
S RCXVDA=RCXVDA_RCXVU_RCXVP2 ; ASSC. CLNC (P)
|
||||
S RCXVP1=$P(RCXVD,U,18),(RCXVP2,RCXVPS,RCXVPSER,RCXVNPI)=""
|
||||
I RCXVP1'="" S RCXVP2=$$GET1^DIQ(200,RCXVP1_",",.01,"E"),RCXVNPI=$P($$NPI^XUSNPI("Individual_ID",RCXVP1),RCXVU,1) S:+RCXVNPI<1 RCXVNPI="" D
|
||||
. S RCXVPS=$$GET^XUA4A72(RCXVP1,RCXVDT)
|
||||
. S RCXVPS=$P(RCXVPS,U,3)
|
||||
. S RCXVPSER=$$GET1^DIQ(200,RCXVP1_",",29,"E")
|
||||
. Q
|
||||
;provider^provider npi^specialty^service/section
|
||||
S RCXVDA=RCXVDA_RCXVU_RCXVP2_RCXVU_RCXVNPI_RCXVU_RCXVPS_RCXVU_RCXVPSER
|
||||
S ^TMP($J,RCXVBLN,"4-399A",RCXVPC)=RCXVDA
|
||||
; LOOP THRU CPT
|
||||
S RCXVCP=0,RCXVMULT=0
|
||||
F S RCXVCP=$O(^DGCR(399,RCXVD0,"CP",RCXVPC,"MOD",RCXVCP)) Q:'RCXVCP D
|
||||
. Q:'($D(^DGCR(399,RCXVD0,"CP",RCXVPC,"MOD",RCXVCP,0)))
|
||||
. ; ^DGCR(399,D0,CP,D1,MOD,D2,0)= (#.01) CPT MODIFIER SEQUENCE [1N]
|
||||
. ; (#.02) CPT ==>MODIFIER [2P:81.3]
|
||||
. S RCXVP1=$P($G(^DGCR(399,RCXVD0,"CP",RCXVPC,"MOD",RCXVCP,0)),U,2)
|
||||
. Q:RCXVP1=""
|
||||
. S RCXVMULT=RCXVMULT+1
|
||||
. S RCXVP2=$P($G(^DIC(81.3,RCXVP1,0)),U,1)
|
||||
. S ^TMP($J,RCXVBLN,"4-399A",RCXVPC,RCXVMULT)=RCXVP2
|
||||
. Q
|
||||
D39942 ; CHARGES FROM 399.042
|
||||
; LOOP THRU 399.042
|
||||
N X
|
||||
S RCXVD1=$G(^DGCR(399,RCXVD0,"RC",RCXVPC,0))
|
||||
I RCXVD1="" Q
|
||||
S X=$P(RCXVD1,U)
|
||||
S RCXVDB=RCXVBLNA_RCXVU_$$GET1^DIQ(399.2,X_",",.01,"E") ; Revenue Code
|
||||
S X=$P(RCXVD1,U,6)
|
||||
S RCXVDB=RCXVDB_RCXVU_$$GET1^DIQ(81,X_",",.01,"E") ; Procedures [P]
|
||||
S RCXVDB=RCXVDB_RCXVU_RCXVPCDT ; PROC. DT
|
||||
S RCXVDB=RCXVDB_RCXVU_$P(RCXVD1,U,2) ; Charges
|
||||
S ^TMP($J,RCXVBLN,"4-399B",RCXVPC)=RCXVDB
|
||||
Q
|
||||
;
|
||||
|
|
|
|||
|
|
@ -1,58 +1,58 @@
|
|||
RCXVFTP ;DAOU/ALA-FTP AR Data Extract Batch Files ;08-SEP-03
|
||||
;;4.5;Accounts Receivable;**201,256**;Mar 20, 1995;Build 6
|
||||
;
|
||||
;**Program Description**
|
||||
; This code will ftp a batch file
|
||||
;
|
||||
EN(FILE,DIREC) ;
|
||||
; Input Parameter
|
||||
; FILE = Filename
|
||||
; DIREC = Directory
|
||||
S RCXVPTH=$S($G(DIREC)'="":DIREC,1:RCXVDIR)
|
||||
;
|
||||
SYS ; Get system type
|
||||
S RCXVSYS=$$VERSION^%ZOSV(1)
|
||||
I RCXVSYS["DSM" S RCXVSYS="VMS",RCXVSYT="DSM"
|
||||
I RCXVSYS["MSM" D
|
||||
. I RCXVSYS["NT"!(RCXVSYS["PC") S RCXVSYS="MSM",RCXVSYT="MSM" Q
|
||||
. E S RCXVSYS="UNIX",RCXVSYT="MSM"
|
||||
I RCXVSYS["Cache" D
|
||||
. I RCXVSYS["VMS" S RCXVSYS="VMS",RCXVSYT="CACHE" Q
|
||||
. S RCXVSYS="CACHE",RCXVSYT="CACHE"
|
||||
;
|
||||
I RCXVSYS="VMS" S RCXVNME=FILE_";1"
|
||||
I RCXVSYS'="VMS" S RCXVNME=FILE
|
||||
;
|
||||
ARC ; Directly FTP to the Boston Allocation Resource Center
|
||||
I $$GET1^DIQ(342,"1,",20.06,"I")="P" D
|
||||
. S RCXVIP="MORPHEUS.ARC.MED.VA.GOV"
|
||||
. S RCXVUSR="mccf"
|
||||
. S RCXVPAS="1qaz2wsx"
|
||||
;
|
||||
I $$GET1^DIQ(342,"1,",20.06,"I")'="P" D
|
||||
. S RCXVIP="MORPHEUS.ARC.MED.VA.GOV"
|
||||
. S RCXVUSR="cbotest1"
|
||||
. S RCXVPAS="1qaz2wsx"
|
||||
;
|
||||
I RCXVSYS="VMS" D ^RCXVFTV
|
||||
I RCXVSYS'="VMS" D ^RCXVFTC
|
||||
;
|
||||
S RCXVARRY(RCXVTXT)="",RCXVARRY(RCXVBAT)="",RCXVARRY(RCXVNME)=""
|
||||
S Y=$$DEL^%ZISH(RCXVPTH,$NA(RCXVARRY))
|
||||
K RCXVARRY,%ZISHF,%ZISHO,%ZISUB,DIREC,FILE,I,RCXCT,RCXI,RCXOKAY,RCXVBAT
|
||||
K RCXVFTP,RCXVHNDL,RCXVIP,RCXVNME,RCXVOUT,RCXVPAS,RCXVPTH,RCXVSCR,XMY
|
||||
K RCXVSYS,RCXVSYT,RCXVTXT,RCXVUSR,RCXVVMS,CNT,QER,QFL,RCXMGRP,XMSUB
|
||||
K VALMSG,RCXVROOT
|
||||
Q
|
||||
;
|
||||
FCK ; Check that file is ready to read
|
||||
S QFL=0,CNT=0,QER=0
|
||||
FQT I QFL Q
|
||||
D OPEN^%ZISH(RCXVHNDL,RCXVPTH,RCXVSCR,"R")
|
||||
I POP D G FQT
|
||||
. HANG 5
|
||||
. S CNT=CNT+1
|
||||
. I CNT>10 S QFL=1,QER=1 D CLOSE^%ZISH(RCXVHNDL)
|
||||
S QFL=1 D CLOSE^%ZISH(RCXVHNDL)
|
||||
G FQT
|
||||
;
|
||||
RCXVFTP ;DAOU/ALA-FTP AR Data Extract Batch Files ;08-SEP-03
|
||||
;;4.5;Accounts Receivable;**201**;Mar 20, 1995
|
||||
;
|
||||
;**Program Description**
|
||||
; This code will ftp a batch file
|
||||
;
|
||||
EN(FILE,DIREC) ;
|
||||
; Input Parameter
|
||||
; FILE = Filename
|
||||
; DIREC = Directory
|
||||
S RCXVPTH=$S($G(DIREC)'="":DIREC,1:RCXVDIR)
|
||||
;
|
||||
SYS ; Get system type
|
||||
S RCXVSYS=$$VERSION^%ZOSV(1)
|
||||
I RCXVSYS["DSM" S RCXVSYS="VMS",RCXVSYT="DSM"
|
||||
I RCXVSYS["MSM" D
|
||||
. I RCXVSYS["NT"!(RCXVSYS["PC") S RCXVSYS="MSM",RCXVSYT="MSM" Q
|
||||
. E S RCXVSYS="UNIX",RCXVSYT="MSM"
|
||||
I RCXVSYS["Cache" D
|
||||
. I RCXVSYS["VMS" S RCXVSYS="VMS",RCXVSYT="CACHE" Q
|
||||
. S RCXVSYS="CACHE",RCXVSYT="CACHE"
|
||||
;
|
||||
I RCXVSYS="VMS" S RCXVNME=FILE_";1"
|
||||
I RCXVSYS'="VMS" S RCXVNME=FILE
|
||||
;
|
||||
ARC ; Directly FTP to the Boston Allocation Resource Center
|
||||
I $$GET1^DIQ(342,"1,",20.06,"I")="P" D
|
||||
. S RCXVIP="MORPHEUS.ARC.MED.VA.GOV"
|
||||
. S RCXVUSR="mccf"
|
||||
. S RCXVPAS="1qaz2wsx"
|
||||
;
|
||||
I $$GET1^DIQ(342,"1,",20.06,"I")'="P" D
|
||||
. S RCXVIP="MORPHEUS.ARC.MED.VA.GOV"
|
||||
. S RCXVUSR="cbotest"
|
||||
. S RCXVPAS="1qaz2wsx"
|
||||
;
|
||||
I RCXVSYS="VMS" D ^RCXVFTV
|
||||
I RCXVSYS'="VMS" D ^RCXVFTC
|
||||
;
|
||||
S RCXVARRY(RCXVTXT)="",RCXVARRY(RCXVBAT)="",RCXVARRY(RCXVNME)=""
|
||||
S Y=$$DEL^%ZISH(RCXVPTH,$NA(RCXVARRY))
|
||||
K RCXVARRY,%ZISHF,%ZISHO,%ZISUB,DIREC,FILE,I,RCXCT,RCXI,RCXOKAY,RCXVBAT
|
||||
K RCXVFTP,RCXVHNDL,RCXVIP,RCXVNME,RCXVOUT,RCXVPAS,RCXVPTH,RCXVSCR,XMY
|
||||
K RCXVSYS,RCXVSYT,RCXVTXT,RCXVUSR,RCXVVMS,CNT,QER,QFL,RCXMGRP,XMSUB
|
||||
K VALMSG,RCXVROOT
|
||||
Q
|
||||
;
|
||||
FCK ; Check that file is ready to read
|
||||
S QFL=0,CNT=0,QER=0
|
||||
FQT I QFL Q
|
||||
D OPEN^%ZISH(RCXVHNDL,RCXVPTH,RCXVSCR,"R")
|
||||
I POP D G FQT
|
||||
. HANG 5
|
||||
. S CNT=CNT+1
|
||||
. I CNT>10 S QFL=1,QER=1 D CLOSE^%ZISH(RCXVHNDL)
|
||||
S QFL=1 D CLOSE^%ZISH(RCXVHNDL)
|
||||
G FQT
|
||||
;
|
||||
|
|
|
|||
|
|
@ -1,75 +1,74 @@
|
|||
GMRACMR4 ;HIRMFO/WAA-PATIENT NOT ASKED ABOUT ALLERGIES ;10/1/92
|
||||
;;4.0;Adverse Reaction Tracking;**33**;Mar 29, 1996;Build 5
|
||||
EN1 ;This is the main entry point for this program
|
||||
D EN1^GMRACMR G:GMRAOUT EXIT
|
||||
DEV ; *** Select output device, force queuing
|
||||
S GMRAZIS=""
|
||||
S:GMRASEL'="1," GMRAZIS="Q"
|
||||
W !! D DEV^GMRAUTL I POP S GMRAOUT=1 G EXIT
|
||||
I $D(IO("Q")) D G EXIT
|
||||
. K IO("Q")
|
||||
. S ZTRTN="ENTSK^GMRACMR4"
|
||||
. S ZTSAVE("GMRA*")="",ZTSAVE("^TMP($J,")=""
|
||||
. S ZTDESC="List of patients without ID band or Chart marked"
|
||||
. D ^%ZTLOAD
|
||||
. W !!,$S($D(ZTSK):"Request queued...",1:"Request NOT queued please try later...")
|
||||
. Q
|
||||
E D ENTSK
|
||||
Q
|
||||
ENTSK U IO
|
||||
D EN1^GMRACMR2,EN1^GMRACMR3
|
||||
S GMRAPAGE=0,X="NOW" D ^%DT S GMRAPDT=$$DATE^GMRAUTL1(Y)
|
||||
D SITE^GMRAUTL S GMRASITE=$G(^GMRD(120.84,GMRASITE,0))
|
||||
D PRINT
|
||||
G EXIT
|
||||
PRINT ;PRINT THE DATE
|
||||
D PRE^GMRAPNA
|
||||
S GMRAHLOC="" F S GMRAHLOC=$O(^TMP($J,"GMRAWC","C",GMRAHLOC)) Q:GMRAHLOC="" S GMRAX=0 Q:GMRAOUT F S GMRAX=$O(^(GMRAHLOC,GMRAX)) Q:GMRAX<1 D Q:GMRAOUT
|
||||
.S GMRA=^TMP($J,"GMRAWC",GMRAX)
|
||||
.D HEAD Q:GMRAOUT
|
||||
.W !!,?10,$S(GMRA="W":"WARD",GMRA="M":"MODULE",GMRA="C":"CLINIC",1:"UNKNOWN"),": ",$P(^SC(GMRAX,0),U)
|
||||
.S GMRACNT=0
|
||||
.S GMRADATE=0 F S GMRADATE=$O(^TMP($J,"GMRAWC",GMRAX,GMRADATE)) Q:GMRADATE="" S (GMRAFLG,GMRADFN)=0 F S GMRADFN=$O(^TMP($J,"GMRAWC",GMRAX,GMRADATE,GMRADFN)) Q:GMRADFN<1 D Q:GMRAOUT
|
||||
..Q:'$$PRDTST^GMRAUTL1(GMRADFN) ;GMRA*4*33 Exclude test patient from report if production or legacy environment.
|
||||
..S GMRAI=0 F S GMRAI=$O(^GMR(120.8,"B",GMRADFN,GMRAI)) Q:GMRAI<1 D Q:GMRAOUT
|
||||
...Q:'$D(^GMR(120.8,GMRAI,0)) Q:$P($G(^GMR(120.86,GMRADFN,0)),U,2)'=1
|
||||
...Q:$D(^GMR(120.8,GMRAI,"ER"))
|
||||
...Q:$P(^GMR(120.8,GMRAI,0),U,2)=""
|
||||
...S (GMRA("C"),GMRA("I"),GMRA("M"))=1
|
||||
...I '$O(^GMR(120.8,GMRAI,13,0)) S (GMRA("C"),GMRA("M"))=0
|
||||
...I GMRA'="W",GMRA("M") Q
|
||||
...I GMRA="W",$P(GMRASITE,U,5)'=0,'$$IDMARK^GMRACMR5(GMRADFN,GMRADATE,GMRAI) S (GMRA("I"),GMRA("M"))=0
|
||||
...I GMRA("M") Q
|
||||
...S GMRACNT=GMRACNT+1
|
||||
...W ! I GMRAFLG'=GMRADFN W $E($P(^DPT(GMRADFN,0),U),1,30) S (DFN,GMRAFLG)=GMRADFN S GMRAPID="" D VAD^GMRAUTL1(GMRADFN,"","","","","","","",.GMRAPID) W ?30,GMRAPID K GMRAPID
|
||||
...W ?45,$E($P(^GMR(120.8,GMRAI,0),U,2),1,20)
|
||||
...I GMRA="W" W ?66,$S(('GMRA("C")&'GMRA("I")):"ID BAND/CHART",('GMRA("C")):"CHART",('GMRA("I")):"ID BAND",1:"ERROR")
|
||||
...E W ?66,$S('GMRA("C"):"CHART",1:"ERROR")
|
||||
...I $Y>(IOSL-4) D HEAD Q:GMRAOUT
|
||||
...Q
|
||||
..Q
|
||||
.D NOPAT^GMRAPNA
|
||||
.Q
|
||||
D CLOSE^GMRAUTL
|
||||
Q
|
||||
HEAD ;HEADER PAGE FOR PRINTOUT
|
||||
S GMRAPAGE=GMRAPAGE+1,GMRATL="" I $E(IOST,1)="C",GMRAPAGE=1 W @IOF
|
||||
I $E(IOST,1)="C",GMRAPAGE'=1 D Q:GMRAOUT
|
||||
.S DIR(0)="E" D ^DIR I 'Y S GMRAOUT=1
|
||||
.K Y
|
||||
.Q
|
||||
W:GMRAPAGE'=1 @IOF
|
||||
W !,GMRAPDT,?22,"PATIENTS WITH UNMARKED ID BAND/CHART",?70,"PAGE ",GMRAPAGE
|
||||
I GMRASEL["1" S GMRATL="CURRENT INPATIENTS"
|
||||
I GMRASEL["2" S GMRATL=$S(GMRATL="":"OUTPATIENTS",1:GMRATL_" / OUTPATIENTS")
|
||||
I GMRASEL["3" S GMRATL=$S(GMRATL="":"NEW ADMISSIONS",1:GMRATL_" / NEW ADMISSIONS")
|
||||
W !,?(40-($L(GMRATL)/2)),GMRATL
|
||||
I (GMRASEL["2"!(GMRASEL["3")) W !,?22,"FROM ",$$DATE^GMRAUTL1(GMRAST),?43,"TO ",$$DATE^GMRAUTL1(GMRAED)
|
||||
W !!,"PATIENT",?30,"SSN",?45,"ALLERGY",?66,"UNMARKED"
|
||||
W !,$$REPEAT^XLFSTR("-",79)
|
||||
I $D(ZTQUEUED) S:$$STPCK^GMRAUTL1 GMRAOUT=1 ; Check if stopped by user
|
||||
Q
|
||||
EXIT ;
|
||||
K ^TMP($J,"GMRAWC")
|
||||
D KILL^XUSCLEAN
|
||||
Q
|
||||
GMRACMR4 ;HIRMFO/WAA-PATIENT NOT ASKED ABOUT ALLERGIES ; 10/1/92
|
||||
;;4.0;Adverse Reaction Tracking;;Mar 29, 1996
|
||||
EN1 ;This is the main entry point for this program
|
||||
D EN1^GMRACMR G:GMRAOUT EXIT
|
||||
DEV ; *** Select output device, force queueing
|
||||
S GMRAZIS=""
|
||||
S:GMRASEL'="1," GMRAZIS="Q"
|
||||
W !! D DEV^GMRAUTL I POP S GMRAOUT=1 G EXIT
|
||||
I $D(IO("Q")) D G EXIT
|
||||
. K IO("Q")
|
||||
. S ZTRTN="ENTSK^GMRACMR4"
|
||||
. S ZTSAVE("GMRA*")="",ZTSAVE("^TMP($J,")=""
|
||||
. S ZTDESC="List of patients without ID band or Chart marked"
|
||||
. D ^%ZTLOAD
|
||||
. W !!,$S($D(ZTSK):"Request queued...",1:"Request NOT queued please try later...")
|
||||
. Q
|
||||
E D ENTSK
|
||||
Q
|
||||
ENTSK U IO
|
||||
D EN1^GMRACMR2,EN1^GMRACMR3
|
||||
S GMRAPAGE=0,X="NOW" D ^%DT S GMRAPDT=$$DATE^GMRAUTL1(Y)
|
||||
D SITE^GMRAUTL S GMRASITE=$G(^GMRD(120.84,GMRASITE,0))
|
||||
D PRINT
|
||||
G EXIT
|
||||
PRINT ;PRINT THE DATE
|
||||
D PRE^GMRAPNA
|
||||
S GMRAHLOC="" F S GMRAHLOC=$O(^TMP($J,"GMRAWC","C",GMRAHLOC)) Q:GMRAHLOC="" S GMRAX=0 Q:GMRAOUT F S GMRAX=$O(^(GMRAHLOC,GMRAX)) Q:GMRAX<1 D Q:GMRAOUT
|
||||
.S GMRA=^TMP($J,"GMRAWC",GMRAX)
|
||||
.D HEAD Q:GMRAOUT
|
||||
.W !!,?10,$S(GMRA="W":"WARD",GMRA="M":"MODULE",GMRA="C":"CLINIC",1:"UNKNOWN"),": ",$P(^SC(GMRAX,0),U)
|
||||
.S GMRACNT=0
|
||||
.S GMRADATE=0 F S GMRADATE=$O(^TMP($J,"GMRAWC",GMRAX,GMRADATE)) Q:GMRADATE="" S (GMRAFLG,GMRADFN)=0 F S GMRADFN=$O(^TMP($J,"GMRAWC",GMRAX,GMRADATE,GMRADFN)) Q:GMRADFN<1 D Q:GMRAOUT
|
||||
..S GMRAI=0 F S GMRAI=$O(^GMR(120.8,"B",GMRADFN,GMRAI)) Q:GMRAI<1 D Q:GMRAOUT
|
||||
...Q:'$D(^GMR(120.8,GMRAI,0)) Q:$P($G(^GMR(120.86,GMRADFN,0)),U,2)'=1
|
||||
...Q:$D(^GMR(120.8,GMRAI,"ER"))
|
||||
...Q:$P(^GMR(120.8,GMRAI,0),U,2)=""
|
||||
...S (GMRA("C"),GMRA("I"),GMRA("M"))=1
|
||||
...I '$O(^GMR(120.8,GMRAI,13,0)) S (GMRA("C"),GMRA("M"))=0
|
||||
...I GMRA'="W",GMRA("M") Q
|
||||
...I GMRA="W",$P(GMRASITE,U,5)'=0,'$$IDMARK^GMRACMR5(GMRADFN,GMRADATE,GMRAI) S (GMRA("I"),GMRA("M"))=0
|
||||
...I GMRA("M") Q
|
||||
...S GMRACNT=GMRACNT+1
|
||||
...W ! I GMRAFLG'=GMRADFN W $E($P(^DPT(GMRADFN,0),U),1,30) S (DFN,GMRAFLG)=GMRADFN S GMRAPID="" D VAD^GMRAUTL1(GMRADFN,"","","","","","","",.GMRAPID) W ?30,GMRAPID K GMRAPID
|
||||
...W ?45,$E($P(^GMR(120.8,GMRAI,0),U,2),1,20)
|
||||
...I GMRA="W" W ?66,$S(('GMRA("C")&'GMRA("I")):"ID BAND/CHART",('GMRA("C")):"CHART",('GMRA("I")):"ID BAND",1:"ERROR")
|
||||
...E W ?66,$S('GMRA("C"):"CHART",1:"ERROR")
|
||||
...I $Y>(IOSL-4) D HEAD Q:GMRAOUT
|
||||
...Q
|
||||
..Q
|
||||
.D NOPAT^GMRAPNA
|
||||
.Q
|
||||
D CLOSE^GMRAUTL
|
||||
Q
|
||||
HEAD ;HEADER PAGE FOR PRINTOUT
|
||||
S GMRAPAGE=GMRAPAGE+1,GMRATL="" I $E(IOST,1)="C",GMRAPAGE=1 W @IOF
|
||||
I $E(IOST,1)="C",GMRAPAGE'=1 D Q:GMRAOUT
|
||||
.S DIR(0)="E" D ^DIR I 'Y S GMRAOUT=1
|
||||
.K Y
|
||||
.Q
|
||||
W:GMRAPAGE'=1 @IOF
|
||||
W !,GMRAPDT,?22,"PATIENTS WITH UNMARKED ID BAND/CHART",?70,"PAGE ",GMRAPAGE
|
||||
I GMRASEL["1" S GMRATL="CURRENT INPATIENTS"
|
||||
I GMRASEL["2" S GMRATL=$S(GMRATL="":"OUTPATIENTS",1:GMRATL_" / OUTPATIENTS")
|
||||
I GMRASEL["3" S GMRATL=$S(GMRATL="":"NEW ADMISSIONS",1:GMRATL_" / NEW ADMISSIONS")
|
||||
W !,?(40-($L(GMRATL)/2)),GMRATL
|
||||
I (GMRASEL["2"!(GMRASEL["3")) W !,?22,"FROM ",$$DATE^GMRAUTL1(GMRAST),?43,"TO ",$$DATE^GMRAUTL1(GMRAED)
|
||||
W !!,"PATIENT",?30,"SSN",?45,"ALLERGY",?66,"UNMARKED"
|
||||
W !,$$REPEAT^XLFSTR("-",79)
|
||||
I $D(ZTQUEUED) S:$$STPCK^GMRAUTL1 GMRAOUT=1 ; Check if stopped by user
|
||||
Q
|
||||
EXIT ;
|
||||
K ^TMP($J,"GMRAWC")
|
||||
D KILL^XUSCLEAN
|
||||
Q
|
||||
|
|
|
|||
|
|
@ -1,42 +1,41 @@
|
|||
GMRADSP5 ;HIRMFO/YMP,RM,WAA-LISTING OF ALLERGIES TO SIGNED OFF ALLERGIES ;8/16/92
|
||||
;;4.0;Adverse Reaction Tracking;**33**;Mar 29, 1996;Build 5
|
||||
EN1 ; Entry to PATIENT ALLERGIES NOT SIGNED OFF option
|
||||
S GMRAOUT=0
|
||||
S GMRAHEAD(1)=$J("ALLERGY/ADVERSE REACTIONS TO BE SIGNED OFF",59),GMRAHEAD(4)=$J("ORIGINATOR",10)_$J("PATIENT",21)_$J("ALLERGY",19)_$J("ORIGINATION DATE/TIME",29),(GMRAHEAD(3),GMRAHEAD(5),GMRAHEAD(6))="",$P(GMRAHEAD(5),"-",81)=""
|
||||
S GMRANOW=$$NOW^XLFDT,GMRANOW=$$FMTE^XLFDT(GMRANOW,"2P")
|
||||
S GMRAHEAD(1.5)=$J("Run Date/Time: "_GMRANOW,55)
|
||||
K GMRAZIS D DEV^GMRAUTL I POP S GMRAOUT=1 G EXIT
|
||||
I $D(IO("Q")) D TASK G EXIT
|
||||
EN2 S (GMRAORG,GMRADT)=""
|
||||
F GMRAREC=0:0 S GMRAREC=$O(^GMR(120.8,"ASGN",GMRAREC)) Q:GMRAREC'>0 D EN2A
|
||||
G DISP
|
||||
Q
|
||||
EN2A S GMRATEMP=$G(^GMR(120.8,GMRAREC,0)) Q:GMRATEMP=""
|
||||
I '$D(^XUSEC("GMRA-ALLERGY VERIFY",DUZ)) Q:$P(GMRATEMP,U,5)'=DUZ
|
||||
Q:'$$PRDTST^GMRAUTL1($P(GMRATEMP,U)) ;GMRA*4*33 Exclude test patient if production or legacy environment.
|
||||
S DFN=$P(GMRATEMP,U) D PID^VADPT6 S GMRASSN=VA("BID") D KVA^VADPT
|
||||
I $P(GMRATEMP,U,5)'="" S ^TMP($J,"GMRADSP",$P(^VA(200,$P(GMRATEMP,U,5),0),U),$P(GMRATEMP,U,5),$P(GMRATEMP,U,4),$P(GMRATEMP,U),GMRAREC)=$P(GMRATEMP,U,2)_U_$E($P(^DPT($P(GMRATEMP,U),0),U),1,14)_"("_GMRASSN_")"
|
||||
Q
|
||||
DISP S GMRAPG=0 D HDR^GMRADSP3 W:'$D(^TMP($J,"GMRADSP")) !!!,?7,"NO DATA FOR THIS REPORT"
|
||||
S GMRAORG="" F S GMRAORG=$O(^TMP($J,"GMRADSP",GMRAORG)) Q:GMRAORG=""!GMRAOUT D Q:GMRAOUT
|
||||
.S GMRAIEN="" F S GMRAIEN=$O(^TMP($J,"GMRADSP",GMRAORG,GMRAIEN)) Q:GMRAIEN=""!GMRAOUT D Q:GMRAOUT
|
||||
..S GMRADT="" F S GMRADT=$O(^TMP($J,"GMRADSP",GMRAORG,GMRAIEN,GMRADT)) Q:GMRADT=""!GMRAOUT D Q:GMRAOUT
|
||||
...S GMRADFN="" F S GMRADFN=$O(^TMP($J,"GMRADSP",GMRAORG,GMRAIEN,GMRADT,GMRADFN)) Q:GMRADFN=""!GMRAOUT D EN3
|
||||
...Q
|
||||
..Q
|
||||
.Q
|
||||
EXIT ;Quit and kill
|
||||
D CLOSE^GMRAUTL
|
||||
K ^TMP($J,"GMRADSP"),X,Y,Z
|
||||
D KILL^XUSCLEAN
|
||||
Q
|
||||
EN3 S GMRAPAT="" F S GMRAPAT=$O(^TMP($J,"GMRADSP",GMRAORG,GMRAIEN,GMRADT,GMRADFN,GMRAPAT)) Q:GMRAPAT=""!GMRAOUT S GMRALL=$G(^(GMRAPAT)) I GMRALL'="" D Q:GMRAOUT
|
||||
.S Y=GMRADT D D^DIQ W !,$E(GMRAORG,1,15),?17,$P(GMRALL,U,2),?42,$E($P(GMRALL,U),1,16),?59,Y
|
||||
.D:IOSL-4<$Y EOP^GMRADSP3 Q:GMRAOUT
|
||||
.Q
|
||||
Q
|
||||
TASK ;
|
||||
S ZTDESC="Patient reactions not signed off",ZTRTN="EN2^GMRADSP5",ZTDTH="",ZTIO=ION,ZTSAVE("GMRA*")="",ZTSAVE("DFN")="" D ^%ZTLOAD
|
||||
W !!,$S($D(ZTSK):"Request queued...",1:"Request NOT queued please try later...")
|
||||
K ZTRTN,ZTDH,ZTSAVE,ZTDTH,ZTSK
|
||||
Q
|
||||
GMRADSP5 ;HIRMFO/YMP,RM,WAA-LISTING OF ALLERGIES TO SIGNED OFF ALLERGIES ; 8/16/92
|
||||
;;4.0;Adverse Reaction Tracking;;Mar 29, 1996
|
||||
EN1 ; Entry to PATIENT ALLERGIES NOT SIGNED OFF option
|
||||
S GMRAOUT=0
|
||||
S GMRAHEAD(1)=$J("ALLERGY/ADVERSE REACTIONS TO BE SIGNED OFF",59),GMRAHEAD(4)=$J("ORIGINATOR",10)_$J("PATIENT",21)_$J("ALLERGY",19)_$J("ORIGINATION DATE/TIME",29),(GMRAHEAD(3),GMRAHEAD(5),GMRAHEAD(6))="",$P(GMRAHEAD(5),"-",81)=""
|
||||
S GMRANOW=$$NOW^XLFDT,GMRANOW=$$FMTE^XLFDT(GMRANOW,"2P")
|
||||
S GMRAHEAD(1.5)=$J("Run Date/Time: "_GMRANOW,55)
|
||||
K GMRAZIS D DEV^GMRAUTL I POP S GMRAOUT=1 G EXIT
|
||||
I $D(IO("Q")) D TASK G EXIT
|
||||
EN2 S (GMRAORG,GMRADT)=""
|
||||
F GMRAREC=0:0 S GMRAREC=$O(^GMR(120.8,"ASGN",GMRAREC)) Q:GMRAREC'>0 D EN2A
|
||||
G DISP
|
||||
Q
|
||||
EN2A S GMRATEMP=$G(^GMR(120.8,GMRAREC,0)) Q:GMRATEMP=""
|
||||
I '$D(^XUSEC("GMRA-ALLERGY VERIFY",DUZ)) Q:$P(GMRATEMP,U,5)'=DUZ
|
||||
S DFN=$P(GMRATEMP,U) D PID^VADPT6 S GMRASSN=VA("BID") D KVA^VADPT
|
||||
I $P(GMRATEMP,U,5)'="" S ^TMP($J,"GMRADSP",$P(^VA(200,$P(GMRATEMP,U,5),0),U),$P(GMRATEMP,U,5),$P(GMRATEMP,U,4),$P(GMRATEMP,U),GMRAREC)=$P(GMRATEMP,U,2)_U_$E($P(^DPT($P(GMRATEMP,U),0),U),1,14)_"("_GMRASSN_")"
|
||||
Q
|
||||
DISP S GMRAPG=0 D HDR^GMRADSP3 W:'$D(^TMP($J,"GMRADSP")) !!!,?7,"NO DATA FOR THIS REPORT"
|
||||
S GMRAORG="" F S GMRAORG=$O(^TMP($J,"GMRADSP",GMRAORG)) Q:GMRAORG=""!GMRAOUT D Q:GMRAOUT
|
||||
.S GMRAIEN="" F S GMRAIEN=$O(^TMP($J,"GMRADSP",GMRAORG,GMRAIEN)) Q:GMRAIEN=""!GMRAOUT D Q:GMRAOUT
|
||||
..S GMRADT="" F S GMRADT=$O(^TMP($J,"GMRADSP",GMRAORG,GMRAIEN,GMRADT)) Q:GMRADT=""!GMRAOUT D Q:GMRAOUT
|
||||
...S GMRADFN="" F S GMRADFN=$O(^TMP($J,"GMRADSP",GMRAORG,GMRAIEN,GMRADT,GMRADFN)) Q:GMRADFN=""!GMRAOUT D EN3
|
||||
...Q
|
||||
..Q
|
||||
.Q
|
||||
EXIT ;Quit and kill
|
||||
D CLOSE^GMRAUTL
|
||||
K ^TMP($J,"GMRADSP"),X,Y,Z
|
||||
D KILL^XUSCLEAN
|
||||
Q
|
||||
EN3 S GMRAPAT="" F S GMRAPAT=$O(^TMP($J,"GMRADSP",GMRAORG,GMRAIEN,GMRADT,GMRADFN,GMRAPAT)) Q:GMRAPAT=""!GMRAOUT S GMRALL=$G(^(GMRAPAT)) I GMRALL'="" D Q:GMRAOUT
|
||||
.S Y=GMRADT D D^DIQ W !,$E(GMRAORG,1,15),?17,$P(GMRALL,U,2),?42,$E($P(GMRALL,U),1,16),?59,Y
|
||||
.D:IOSL-4<$Y EOP^GMRADSP3 Q:GMRAOUT
|
||||
.Q
|
||||
Q
|
||||
TASK ;
|
||||
S ZTDESC="Patient reactions not signed off",ZTRTN="EN2^GMRADSP5",ZTDTH="",ZTIO=ION,ZTSAVE("GMRA*")="",ZTSAVE("DFN")="" D ^%ZTLOAD
|
||||
W !!,$S($D(ZTSK):"Request queued...",1:"Request NOT queued please try later...")
|
||||
K ZTRTN,ZTDH,ZTSAVE,ZTDTH,ZTSK
|
||||
Q
|
||||
|
|
|
|||
|
|
@ -1,30 +1,29 @@
|
|||
GMRAEF2 ;HIRMFO/WAA-FDA EXCEPTION REPORT ;11/29/95 15:01
|
||||
;;4.0;Adverse Reaction Tracking;**33**;Mar 29, 1996;Build 5
|
||||
EN1 ; Entry to PRINT ALL FDA EXCEPTIONS WITHIN A D/T RANGE option
|
||||
S GMRAOUT=0 K DIR
|
||||
S DIR(0)="DO^:DT:ETX",DIR("A")="Select Start Date"
|
||||
D ^DIR K DIR
|
||||
I $D(DTOUT)!($D(DUOUT))!($D(DIRUT))!($D(DIROUT)) S GMRAOUT=1 G EXIT
|
||||
S (GMRABGDT,GMRASTDT)=Y K Y
|
||||
S DIR(0)="DO^"_GMRABGDT_":NOW:ETX",DIR("A")="Select End Date",DIR("B")="T"
|
||||
D ^DIR K DIR
|
||||
I $D(DTOUT)!($D(DUOUT))!($D(DIRUT))!($D(DIROUT)) S GMRAOUT=1 G EXIT
|
||||
S GMRAEDT=Y,GMRAENDT=((Y+1)-.0000001) K Y
|
||||
EN2 ;
|
||||
S GMRABGDT=GMRABGDT-.0000001
|
||||
F S GMRABGDT=$O(^GMR(120.8,"AODT",GMRABGDT)) Q:GMRABGDT<1 Q:GMRABGDT>GMRAENDT S GMRAIEN=0 F S GMRAIEN=$O(^GMR(120.8,"AODT",GMRABGDT,GMRAIEN)) Q:GMRAIEN<1 D
|
||||
.S GMRA(0)=$G(^GMR(120.8,GMRAIEN,0))
|
||||
.Q:$P(GMRA(0),U,2)=""
|
||||
.Q:$D(^GMR(120.8,GMRAIEN,"ER"))
|
||||
.I $P(GMRA(0),U,6)'="o"!($P(GMRA(0),U,20)'["D") Q
|
||||
.I '$P(GMRA(0),U,12) Q
|
||||
.I $$CMPFDA^GMRAEF1(GMRAIEN) Q
|
||||
.S GMRDFN=$P(GMRA(0),U)
|
||||
.Q:'$$PRDTST^GMRAUTL1(GMRDFN) ;GMRA*4*33 Exclude test patient from report if production or legacy environment.
|
||||
.S ^TMP($J,"GMRAEF",GMRDFN,GMRABGDT)=GMRAIEN
|
||||
.Q
|
||||
D EN1^GMRAEF
|
||||
EXIT ;EXIT OF ROUTINE
|
||||
K GMRAY,GMRAX,GMRAIEN,GMRDFN,GMRBGDT,GMRENDT,GMRDT,GMRAOUT
|
||||
K GMRA,GMRABGDT,GMRAENDT
|
||||
Q
|
||||
GMRAEF2 ;HIRMFO/WAA-FDA EXCEPTION REPORT ;11/29/95 15:01
|
||||
;;4.0;Adverse Reaction Tracking;;Mar 29, 1996
|
||||
EN1 ; Entry to PRINT ALL FDA EXCEPTIONS WITHIN A D/T RANGE option
|
||||
S GMRAOUT=0 K DIR
|
||||
S DIR(0)="DO^:DT:ETX",DIR("A")="Select Start Date"
|
||||
D ^DIR K DIR
|
||||
I $D(DTOUT)!($D(DUOUT))!($D(DIRUT))!($D(DIROUT)) S GMRAOUT=1 G EXIT
|
||||
S (GMRABGDT,GMRASTDT)=Y K Y
|
||||
S DIR(0)="DO^"_GMRABGDT_":NOW:ETX",DIR("A")="Select End Date",DIR("B")="T"
|
||||
D ^DIR K DIR
|
||||
I $D(DTOUT)!($D(DUOUT))!($D(DIRUT))!($D(DIROUT)) S GMRAOUT=1 G EXIT
|
||||
S GMRAEDT=Y,GMRAENDT=((Y+1)-.0000001) K Y
|
||||
EN2 ;
|
||||
S GMRABGDT=GMRABGDT-.0000001
|
||||
F S GMRABGDT=$O(^GMR(120.8,"AODT",GMRABGDT)) Q:GMRABGDT<1 Q:GMRABGDT>GMRAENDT S GMRAIEN=0 F S GMRAIEN=$O(^GMR(120.8,"AODT",GMRABGDT,GMRAIEN)) Q:GMRAIEN<1 D
|
||||
.S GMRA(0)=$G(^GMR(120.8,GMRAIEN,0))
|
||||
.Q:$P(GMRA(0),U,2)=""
|
||||
.Q:$D(^GMR(120.8,GMRAIEN,"ER"))
|
||||
.I $P(GMRA(0),U,6)'="o"!($P(GMRA(0),U,20)'["D") Q
|
||||
.I '$P(GMRA(0),U,12) Q
|
||||
.I $$CMPFDA^GMRAEF1(GMRAIEN) Q
|
||||
.S GMRDFN=$P(GMRA(0),U)
|
||||
.S ^TMP($J,"GMRAEF",GMRDFN,GMRABGDT)=GMRAIEN
|
||||
.Q
|
||||
D EN1^GMRAEF
|
||||
EXIT ;EXIT OF ROUTINE
|
||||
K GMRAY,GMRAX,GMRAIEN,GMRDFN,GMRBGDT,GMRENDT,GMRDT,GMRAOUT
|
||||
K GMRA,GMRABGDT,GMRAENDT
|
||||
Q
|
||||
|
|
|
|||
|
|
@ -1,68 +1,67 @@
|
|||
GMRAFDA3 ;HIRMFO/WAA-DISPLAY FDA REPORT OVER DT RANGE ;12/1/95 11:34
|
||||
;;4.0;Adverse Reaction Tracking;**33**;Mar 29, 1996;Build 5
|
||||
EN1 ; Entry for PRINT ALL FDA EVENTS WITHIN D/T RANGE option
|
||||
S GMRAOUT=0 K DIR
|
||||
S DIR(0)="DO^:NOW:EXT",DIR("A")="Select Start Date/Time"
|
||||
D ^DIR K DIR
|
||||
I $D(DIRUT) G EXIT
|
||||
S GMRABGDT=Y K Y
|
||||
S DIR(0)="DO^"_GMRABGDT_":NOW:EXT",DIR("A")="Select End Date/Time",DIR("B")="T"
|
||||
D ^DIR K DIR
|
||||
I $D(DIRUT) G EXIT
|
||||
S GMRAENDT=Y K Y
|
||||
EN2 ;
|
||||
S GMRABGDT=GMRABGDT-.0000001
|
||||
S GMRAENDT=$S($P(GMRAENDT,".",2)="":GMRAENDT_".24",1:(GMRAENDT+.000001))
|
||||
YN F S %=1 W !,"Do you want an Abbreviated report" D YN^DICN S:%=-1 %=2,GMRAOUT=1 Q:% W !,"ENTER ""Y"" FOR YES OR ""N"" FOR NO",$C(7)
|
||||
G:GMRAOUT EXIT
|
||||
S GMRAYN=%
|
||||
PRINTER ;Select printer
|
||||
S GMRAOUT=0,GMRAPG=0
|
||||
W ! K GMRAZIS S:GMRAYN=2 GMRAZIS="QM132S60" D DEV^GMRAUTL I POP W !,"PLEASE TRY LATER" G EXIT
|
||||
I $D(IO("Q")) D G EXIT
|
||||
.S ZTRTN="PRINT^GMRAFDA3",ZTSAVE("GMRAPG")="",ZTSAVE("GMRAOUT")="",ZTSAVE("GMRABGDT")="",ZTSAVE("GMRAENDT")="",ZTSAVE("GMRAYN")=""
|
||||
.S ZTDESC="Print FDA Report by Date/Time" D ^%ZTLOAD
|
||||
.W !!,$S($D(ZTSK):"Request queued...",1:"Request NOT queued please try later...")
|
||||
.Q
|
||||
U IO D PRINT U IO(0)
|
||||
D CLOSE^GMRAUTL
|
||||
G EXIT
|
||||
Q
|
||||
PRINT ;Central Print
|
||||
N GMRACNT S GMRACNT=0
|
||||
S GMRAFLG=0,GMRANOW=$$NOW^XLFDT,GMRANOW=$$FMTE^XLFDT(GMRANOW,"1")
|
||||
I IOST?1"C".E W @IOF
|
||||
I GMRAYN=1 D HDR1
|
||||
F S GMRABGDT=$O(^GMR(120.85,"B",GMRABGDT)) Q:GMRABGDT<1!(GMRABGDT>GMRAENDT)!(GMRAOUT) S GMRAPA1=0 F S GMRAPA1=$O(^GMR(120.85,"B",GMRABGDT,GMRAPA1)) Q:GMRAPA1<1 D Q:GMRAOUT
|
||||
.I +$P($G(^GMR(120.8,+$P($G(^GMR(120.85,+GMRAPA1,0)),U,15),"ER")),U,1)=1 Q
|
||||
.I GMRAYN=2 D PRT^GMRAFDA1 Q
|
||||
.I $Y>(IOSL-3) D HEAD Q:GMRAOUT
|
||||
.S GMRAPA1(0)=$G(^GMR(120.85,GMRAPA1,0)) Q:GMRAPA1(0)=""
|
||||
.S GMRAPA(0)=$G(^GMR(120.8,$P(GMRAPA1(0),U,15),0)) Q:GMRAPA(0)=""
|
||||
.S DFN=$P(GMRAPA(0),U) D PID^VADPT6
|
||||
.Q:'$$PRDTST^GMRAUTL1(DFN) ;GMRA*4*33 Exclude test patient from report if production or legacy environment.
|
||||
.S GMRACNT=GMRACNT+1
|
||||
.W !,$E($P(^DPT(DFN,0),U),1,23)," (",VA("PID"),")" K VA,DFN
|
||||
.W ?32,$E($P(GMRAPA(0),U,2),1,28)
|
||||
.W ?62 S Y=$P(GMRAPA1(0),U),Y=$$DATE^GMRAUTL1(Y) W $P(Y,":",1,2) K Y
|
||||
.I $P($G(^GMR(120.85,GMRAPA1,"PTC1")),U,5) D
|
||||
..W !,?5,"(SENT TO FDA: " S Y=$P(^GMR(120.85,GMRAPA1,"PTC1"),U,5),Y=$$DATE^GMRAUTL1(Y) W $P(Y,":",1,2),")" K Y
|
||||
.Q
|
||||
.K GMRAPA1(0),GMRAPA(0)
|
||||
.Q
|
||||
I 'GMRACNT W !,?30,"NO DATA FOR THIS REPORT"
|
||||
Q
|
||||
HEAD ;Header Print
|
||||
HDR ;
|
||||
I IOST?1"C".E K DIR S DIR(0)="E" D ^DIR K DIR I Y'>0 S GMRAOUT=1 Q
|
||||
W @IOF
|
||||
HDR1 S GMRAPG=GMRAPG+1
|
||||
W GMRANOW,?70,"Page: ",GMRAPG
|
||||
W !,?30,"FDA ABBREVIATED REPORT"
|
||||
W !,"PATIENT",?32,"SUSPECTED AGENT",?62,"D/T OF EVENT"
|
||||
W !,$$REPEAT^XLFSTR("-",79),!
|
||||
Q
|
||||
EXIT ;EXIT
|
||||
K ^TMP($J,"GMRAEF")
|
||||
D KILL^XUSCLEAN
|
||||
Q
|
||||
GMRAFDA3 ;HIRMFO/WAA-DISPLAY FDA REPORT OVER DT RANGE ;12/1/95 11:34
|
||||
;;4.0;Adverse Reaction Tracking;;Mar 29, 1996
|
||||
EN1 ; Entry for PRINT ALL FDA EVENTS WITHIN D/T RANGE option
|
||||
S GMRAOUT=0 K DIR
|
||||
S DIR(0)="DO^:NOW:EXT",DIR("A")="Select Start Date/Time"
|
||||
D ^DIR K DIR
|
||||
I $D(DIRUT) G EXIT
|
||||
S GMRABGDT=Y K Y
|
||||
S DIR(0)="DO^"_GMRABGDT_":NOW:EXT",DIR("A")="Select End Date/Time",DIR("B")="T"
|
||||
D ^DIR K DIR
|
||||
I $D(DIRUT) G EXIT
|
||||
S GMRAENDT=Y K Y
|
||||
EN2 ;
|
||||
S GMRABGDT=GMRABGDT-.0000001
|
||||
S GMRAENDT=$S($P(GMRAENDT,".",2)="":GMRAENDT_".24",1:(GMRAENDT+.000001))
|
||||
YN F S %=1 W !,"Do you want an Abbreviated report" D YN^DICN S:%=-1 %=2,GMRAOUT=1 Q:% W !,"ENTER ""Y"" FOR YES OR ""N"" FOR NO",$C(7)
|
||||
G:GMRAOUT EXIT
|
||||
S GMRAYN=%
|
||||
PRINTER ;Select printer
|
||||
S GMRAOUT=0,GMRAPG=0
|
||||
W ! K GMRAZIS S:GMRAYN=2 GMRAZIS="QM132S60" D DEV^GMRAUTL I POP W !,"PLEASE TRY LATER" G EXIT
|
||||
I $D(IO("Q")) D G EXIT
|
||||
.S ZTRTN="PRINT^GMRAFDA3",ZTSAVE("GMRAPG")="",ZTSAVE("GMRAOUT")="",ZTSAVE("GMRABGDT")="",ZTSAVE("GMRAENDT")="",ZTSAVE("GMRAYN")=""
|
||||
.S ZTDESC="Print FDA Report by Date/Time" D ^%ZTLOAD
|
||||
.W !!,$S($D(ZTSK):"Request queued...",1:"Request NOT queued please try later...")
|
||||
.Q
|
||||
U IO D PRINT U IO(0)
|
||||
D CLOSE^GMRAUTL
|
||||
G EXIT
|
||||
Q
|
||||
PRINT ;Central Print
|
||||
N GMRACNT S GMRACNT=0
|
||||
S GMRAFLG=0,GMRANOW=$$NOW^XLFDT,GMRANOW=$$FMTE^XLFDT(GMRANOW,"1")
|
||||
I IOST?1"C".E W @IOF
|
||||
I GMRAYN=1 D HDR1
|
||||
F S GMRABGDT=$O(^GMR(120.85,"B",GMRABGDT)) Q:GMRABGDT<1!(GMRABGDT>GMRAENDT)!(GMRAOUT) S GMRAPA1=0 F S GMRAPA1=$O(^GMR(120.85,"B",GMRABGDT,GMRAPA1)) Q:GMRAPA1<1 D Q:GMRAOUT
|
||||
.I +$P($G(^GMR(120.8,+$P($G(^GMR(120.85,+GMRAPA1,0)),U,15),"ER")),U,1)=1 Q
|
||||
.I GMRAYN=2 D PRT^GMRAFDA1 Q
|
||||
.I $Y>(IOSL-3) D HEAD Q:GMRAOUT
|
||||
.S GMRAPA1(0)=$G(^GMR(120.85,GMRAPA1,0)) Q:GMRAPA1(0)=""
|
||||
.S GMRAPA(0)=$G(^GMR(120.8,$P(GMRAPA1(0),U,15),0)) Q:GMRAPA(0)=""
|
||||
.S DFN=$P(GMRAPA(0),U) D PID^VADPT6
|
||||
.S GMRACNT=GMRACNT+1
|
||||
.W !,$E($P(^DPT(DFN,0),U),1,23)," (",VA("PID"),")" K VA,DFN
|
||||
.W ?32,$E($P(GMRAPA(0),U,2),1,28)
|
||||
.W ?62 S Y=$P(GMRAPA1(0),U),Y=$$DATE^GMRAUTL1(Y) W $P(Y,":",1,2) K Y
|
||||
.I $P($G(^GMR(120.85,GMRAPA1,"PTC1")),U,5) D
|
||||
..W !,?5,"(SENT TO FDA: " S Y=$P(^GMR(120.85,GMRAPA1,"PTC1"),U,5),Y=$$DATE^GMRAUTL1(Y) W $P(Y,":",1,2),")" K Y
|
||||
.Q
|
||||
.K GMRAPA1(0),GMRAPA(0)
|
||||
.Q
|
||||
I 'GMRACNT W !,?30,"NO DATA FOR THIS REPORT"
|
||||
Q
|
||||
HEAD ;Header Print
|
||||
HDR ;
|
||||
I IOST?1"C".E K DIR S DIR(0)="E" D ^DIR K DIR I Y'>0 S GMRAOUT=1 Q
|
||||
W @IOF
|
||||
HDR1 S GMRAPG=GMRAPG+1
|
||||
W GMRANOW,?70,"Page: ",GMRAPG
|
||||
W !,?30,"FDA ABBREVIATED REPORT"
|
||||
W !,"PATIENT",?32,"SUSPECTED AGENT",?62,"D/T OF EVENT"
|
||||
W !,$$REPEAT^XLFSTR("-",79),!
|
||||
Q
|
||||
EXIT ;EXIT
|
||||
K ^TMP($J,"GMRAEF")
|
||||
D KILL^XUSCLEAN
|
||||
Q
|
||||
|
|
|
|||
|
|
@ -1,158 +1,157 @@
|
|||
GMRAGUI1 ;SLC/DAN - CPRS GUI support ;11/17/06 09:50
|
||||
;;4.0;Adverse Reaction Tracking;**21,25,36,38**;Mar 29, 1996;Build 2
|
||||
;
|
||||
Q
|
||||
EN1 ; GETREC, cont'd
|
||||
OBSV ; Get OBSERVATIONS from file 120.85
|
||||
S STRING="~OBSERVATIONS" D NEXT
|
||||
S OBSIEN=0
|
||||
OBSLOOP S OBSIEN=$O(^GMR(120.85,"C",GMRAIEN,OBSIEN)) G:OBSIEN<1 EXIT
|
||||
S GMRA(1)=$G(^GMR(120.85,OBSIEN,0)) Q:'$L(GMRA(1))
|
||||
S STRING="tRecord : "_OBSIEN D NEXT
|
||||
S USRNAM=""
|
||||
S USR=$P(GMRA(1),U,13) I USR'="" D GETUSR
|
||||
S Y=$P(GMRA(1),U,1) X ^DD("DD")
|
||||
S STRING="tDate/Time of Event: "_Y D NEXT
|
||||
S STRING="tObserver : "_USRNAM D NEXT
|
||||
S SEVCOD=$P(GMRA(1),U,14)
|
||||
S SEVER=$S(SEVCOD=1:"MILD",SEVCOD=2:"MODERATE",SEVCOD=3:"SEVERE",1:"")
|
||||
S STRING="tSeverity : "_SEVER D NEXT
|
||||
S Y=$P(GMRA(1),U,18) X ^DD("DD")
|
||||
S STRING="tDate Reported : "_Y D NEXT
|
||||
S USRNAM=""
|
||||
S USR=$P(GMRA(1),U,19) I USR'="" D GETUSR
|
||||
S STRING="tReporting User : "_USRNAM D NEXT
|
||||
S STRING="t" F I=1:1:60 S STRING=STRING_"-"
|
||||
D NEXT
|
||||
G OBSLOOP
|
||||
EXIT Q
|
||||
NEXT ;SET ARRAY NODE AND INCREMENT ARRAY COUNTER
|
||||
S @GMRARRAY@(ND)=STRING,ND=ND+1,STRING=""
|
||||
Q
|
||||
GETUSR S USRNAM=$$GET1^DIQ(200,USR_",",".01")
|
||||
Q
|
||||
;
|
||||
EIE(GMRAIEN,GMRADFN,GMRARRAY) ;Mark individual entry as entered in error
|
||||
N DIE,DA,DR,Y,DIK,DFN,OROLD,VAIN,X,GMRAOUT,GMRAPA
|
||||
L +^XTMP("GMRAED",GMRADFN):1 I '$T D MESS Q
|
||||
S GMRAPA=GMRAIEN
|
||||
S DIE="^GMR(120.8,",DA=GMRAPA,DR="15///1;22///1;23///"_@GMRARRAY@("GMRAERRDT")_";24////"_$G(@GMRARRAY@("GMRAERRBY"),.5) ;36
|
||||
D ^DIE ;Entered in error on date/time by user
|
||||
I $D(@GMRARRAY@("GMRAERRCMTS")) D ADCOM(GMRAPA,"E",$NA(@GMRARRAY@("GMRAERRCMTS"))) ;add comments
|
||||
I $$NKASCR^GMRANKA($P(^GMR(120.8,GMRAPA,0),U)) D
|
||||
.S DIK="^GMR(120.86,",DA=$P(^GMR(120.8,GMRAPA,0),U)
|
||||
.D ^DIK ;If patient's last allergy marked as entered in error then delete assessment
|
||||
S GMRAPA(0)=$G(^GMR(120.8,GMRAPA,0)) Q:GMRAPA(0)=""
|
||||
S GMRAOUT=0
|
||||
D EN1^GMRAEAB ;Sends entered in error bulletin to appropriate mail groups
|
||||
D EN1^GMRAPET0(GMRADFN,GMRAPA,"E",.GMRAOUT) ;21 File Progress Note
|
||||
S DFN=GMRADFN
|
||||
D INP^VADPT S X=$$FIND1^DIC(101,,"BX","GMRA ENTERED IN ERROR")_";ORD(101,"
|
||||
D:X EN^XQOR ;Process protocols hanging off of "entered in error" protocol
|
||||
L -^XTMP("GMRAED",GMRADFN)
|
||||
S ORY=0_$S(+$G(GMRAPN)>0:("^"_+$G(GMRAPN)),1:"") ;38 Return IEN of progress note if created
|
||||
Q
|
||||
;
|
||||
ADCOM(ENTRY,TYPE,GMRACOM) ;Add comments to allergies
|
||||
;
|
||||
N FDA,GMRAI,X,DIWL,DIWR
|
||||
K ^UTILITY($J,"W") S DIWL=1,DIWR=60 S GMRAI=0 F S GMRAI=$O(@GMRACOM@(GMRAI)) Q:'+GMRAI S X=@GMRACOM@(GMRAI) D ^DIWP
|
||||
S GMRACOM="^UTILITY($J,""W"",1)"
|
||||
S FDA(120.826,"+1,"_ENTRY_",",.01)=$$NOW^XLFDT
|
||||
S FDA(120.826,"+1,"_ENTRY_",",1)=DUZ
|
||||
S FDA(120.826,"+1,"_ENTRY_",",1.5)=TYPE
|
||||
S FDA(120.826,"+1,"_ENTRY_",",2)=GMRACOM
|
||||
D UPDATE^DIE("","FDA")
|
||||
Q
|
||||
;
|
||||
NKA ;Change patient assessment to NKA
|
||||
;
|
||||
N DA,DR,DIE,NKA,DFN
|
||||
S DFN=ORDFN
|
||||
L +^XTMP("GMRAED",DFN):1 I '$T D MESS Q
|
||||
S NKA=$$NKA^GMRANKA(DFN)
|
||||
I NKA=0 Q ;Patient is already NKA
|
||||
I NKA=1 S ORY="-1^Patient has active allergies - can't mark as NKA" Q
|
||||
L +^GMR(120.86,0):5 I '$T S ORY="-1^Unable to update assessment - try again." Q
|
||||
I '$D(^GMR(120.86,DFN,0)) D ;Add assessment entry
|
||||
.S $P(^GMR(120.86,0),U,3,4)=(DFN_"^"_($P(^GMR(120.86,0),U,4)+1))
|
||||
.S ^GMR(120.86,DFN,0)=DFN_U,^GMR(120.86,"B",DFN,DFN)=""
|
||||
L -^GMR(120.86,0) L +^GMR(120.86,DFN,0):5 I '$T S ORY="-1^Unable to update assessment - try again." Q
|
||||
S DIE="^GMR(120.86,",DA=DFN,DR="1////0;2////"_DUZ_";3///NOW" D ^DIE
|
||||
S ORY=0
|
||||
L -^XTMP("GMRAED",DFN)
|
||||
Q
|
||||
;
|
||||
UPDATE(GMRAIEN,DFN,GMRARRAY) ;Add/edit allergies
|
||||
N NEW,NKA,FDA,NODE,IEN,SUB,FILE,DA,DIK,SIEN,GMRAS0,GMRAIEN,GMRAL,GMRAPA,GMRAAR,GMRALL,GMRADFN,GMRAOUT,GMRAROT
|
||||
S NEW='$G(GMRAIEN)
|
||||
I NEW,$$DUPCHK^GMRAOR0(DFN,$P(@GMRARRAY@("GMRAGNT"),U))=1 S ORY="-1^Patient already has a "_$P(@GMRARRAY@("GMRAGNT"),U)_" reaction entered. No duplicates allowed." Q
|
||||
L +^XTMP("GMRAED",DFN):1 I '$T D MESS Q
|
||||
D SITE^GMRAUTL S GMRASITE(0)=$G(^GMRD(120.84,+GMRASITE,0))
|
||||
S NKA='$$NKA^GMRANKA(DFN) ;is patient NKA?
|
||||
I NKA,NEW D
|
||||
.S FDA(120.86,"?+"_DFN_",",.01)=DFN
|
||||
.S FDA(120.86,"?+"_DFN_",",1)=1
|
||||
.S FDA(120.86,"?+"_DFN_",",2)=DUZ
|
||||
.S FDA(120.86,"?+"_DFN_",",3)=$G(@GMRARRAY@("GMRAORDT"),$$NOW^XLFDT)
|
||||
.S IEN(DFN)=DFN
|
||||
.D UPDATE^DIE("","FDA","IEN")
|
||||
K FDA,IEN
|
||||
S NODE=$S($G(NEW):"+1,",1:(GMRAIEN_","))
|
||||
S:$G(NEW) FDA(120.8,NODE,.01)=DFN
|
||||
I $P($G(@GMRARRAY@("GMRAGNT")),U,2)["50.67" S $P(@GMRARRAY@("GMRAGNT"),U,2)=$$TGTOG^PSNAPIS($P(@GMRARRAY@("GMRAGNT"),U))_";PSNDF(50.6,"
|
||||
F SUB="GMRAGNT;.02","GMRATYPE;3.1","GMRANATR;17","GMRAORIG;5","GMRAORDT;4","GMRAOBHX;6" D
|
||||
.S FDA(120.8,NODE,$P(SUB,";",2))=$P(@GMRARRAY@($P(SUB,";")),U)
|
||||
.I (SUB["GMRAGNT"),NEW S FDA(120.8,NODE,1)=$P(@GMRARRAY@($P(SUB,";")),U,2)
|
||||
D UPDATE^DIE("","FDA","IEN")
|
||||
S:NEW GMRAIEN=IEN(1)
|
||||
K FDA
|
||||
F SUB="GMRACHT","GMRAIDBN" D
|
||||
.Q:'$D(@GMRARRAY@(SUB)) ;Stop if no updates
|
||||
.S FILE=$S(SUB="GMRACHT":120.813,1:120.814)
|
||||
.S FDA(FILE,"+1,"_GMRAIEN_",",.01)=@GMRARRAY@(SUB,1)
|
||||
.S FDA(FILE,"+1,"_GMRAIEN_",",1)=DUZ
|
||||
.D UPDATE^DIE("","FDA")
|
||||
I $D(@GMRARRAY@("GMRACMTS")) D ADCOM(GMRAIEN,"O",$NA(@GMRARRAY@("GMRACMTS"))) ;Add comments if included
|
||||
K FDA
|
||||
S SUB=0 F S SUB=$O(@GMRARRAY@("GMRASYMP",SUB)) Q:'+SUB D
|
||||
.S GMRAS0=^(SUB) ;Naked from above
|
||||
.Q:$P(^(SUB),U)="" ;25 No text or free text entered so don't store
|
||||
.S SIEN=$O(^GMR(120.8,GMRAIEN,10,"B",$P(GMRAS0,U),0))
|
||||
.I SIEN,$P(^GMR(120.8,GMRAIEN,10,SIEN,0),U,4)=$P(GMRAS0,U,3) Q ;Exists and nothing has changed
|
||||
.I SIEN,$P(GMRAS0,U,5)="@" S DIK="^GMR(120.8,"_GMRAIEN_",",DA(1)=GMRAIEN,DA=SIEN D ^DIK Q ;Sign/symptom deleted
|
||||
.S:'SIEN FDA(120.81,"+1,"_GMRAIEN_",",.01)=$S($P(GMRAS0,U)="FT":$O(^GMRD(120.83,"B","OTHER REACTION",0)),1:$P(GMRAS0,U))
|
||||
.S NODE=$S(SIEN:SIEN_","_GMRAIEN,1:"+1,"_GMRAIEN_",")
|
||||
.S:$P(GMRAS0,U)="FT" FDA(120.81,NODE,1)=$P(GMRAS0,U,2)
|
||||
.S FDA(120.81,NODE,2)=DUZ
|
||||
.S FDA(120.81,NODE,3)=$P(GMRAS0,U,3)
|
||||
.D UPDATE^DIE("","FDA","","ERR")
|
||||
.S GMRAROT($P(GMRAS0,U,2))="" ;21 record s/s added
|
||||
I NEW D
|
||||
.S GMRALL(GMRAIEN)="" D VAD^GMRAUTL1(DFN,,.GMRALOC,.GMRANAM) D EN7^GMRAMCB ;Send mark chart/ID band bulletin if needed.
|
||||
.I $P(@GMRARRAY@("GMRAOBHX"),U)="o" D ;if observed reaction add data to 120.85
|
||||
..S GMRAOUT=0 ;21
|
||||
..S GMRAL(GMRAIEN,"O",GMRAIEN)=$G(@GMRARRAY@("GMRARDT"))_"^"_$G(@GMRARRAY@("GMRASEVR"))
|
||||
..S GMRADFN=DFN
|
||||
..S GMRAL(GMRAIEN)="^^"_$P($G(@GMRARRAY@("GMRAGNT")),U)_"^^^^"_$G(@GMRARRAY@("GMRAORIG"))
|
||||
..M GMRAL(GMRAIEN,"S")=@GMRARRAY@("GMRASYMP")
|
||||
..S SUB=0 F S SUB=$O(GMRAL(GMRAIEN,"S",SUB)) Q:'+SUB S $P(GMRAL(GMRAIEN,"S",SUB),U,2)=$P(GMRAL(GMRAIEN,"S",SUB),U,2)_"^" S:$P(GMRAL(GMRAIEN,"S",SUB),U)="FT" $P(GMRAL(GMRAIEN,"S",SUB),U)=$O(^GMRD(120.83,"B","OTHER REACTION",0))
|
||||
..S GMRAL=GMRAIEN
|
||||
..D ADVERSE^GMRAOR7(GMRAIEN,.GMRAL) ;adds entry to 120.85
|
||||
..S GMRAIEN(GMRAIEN)="" ;21
|
||||
..D EN1^GMRAPET0(GMRADFN,.GMRAIEN,"S",.GMRAOUT) ;21 File progress note
|
||||
..I $G(@GMRARRAY@("GMRATYPE"))["D" S GMRAPA=GMRAIEN D EN1^GMRAPTB ;21 Send med-watch update
|
||||
.S GMRAAR=$P($G(@GMRARRAY@("GMRAGNT")),U,2),GMRAPA=GMRAIEN
|
||||
.D EN1^GMRAOR9 S ^TMP($J,"GMRASF",1,GMRAPA)="" D RANGE^GMRASIGN(1) ;add ingredients/classes send appropriate bulletins
|
||||
S ORY=0_$S(+$G(GMRAPN)>0:("^"_+$G(GMRAPN)),1:"") ;38 If note was created send back IEN
|
||||
L -^XTMP("GMRAED",DFN)
|
||||
Q
|
||||
;
|
||||
MESS ;Give out locked message
|
||||
N GMRAXBOS,GMRAL1,GMRAL2
|
||||
S GMRAXBOS=$$BROKER^XWBLIB ;In GUI?
|
||||
S GMRAL1="Another user is editing this patient's allergy information."
|
||||
S GMRAL2="Please refresh/review the patient's information before proceeding."
|
||||
I 'GMRAXBOS W !,GMRAL1,!,GMRAL2 D WAIT^GMRAFX3 Q
|
||||
S ORY="-1^"_GMRAL1_" "_GMRAL2
|
||||
Q
|
||||
GMRAGUI1 ;SLC/DAN - CPRS GUI support ;7/13/06 14:32
|
||||
;;4.0;Adverse Reaction Tracking;**21,25,36**;Mar 29, 1996;Build 9
|
||||
;
|
||||
Q
|
||||
EN1 ; GETREC, cont'd
|
||||
OBSV ; Get OBSERVATIONS from file 120.85
|
||||
S STRING="~OBSERVATIONS" D NEXT
|
||||
S OBSIEN=0
|
||||
OBSLOOP S OBSIEN=$O(^GMR(120.85,"C",GMRAIEN,OBSIEN)) G:OBSIEN<1 EXIT
|
||||
S GMRA(1)=$G(^GMR(120.85,OBSIEN,0)) Q:'$L(GMRA(1))
|
||||
S STRING="tRecord : "_OBSIEN D NEXT
|
||||
S USRNAM=""
|
||||
S USR=$P(GMRA(1),U,13) I USR'="" D GETUSR
|
||||
S Y=$P(GMRA(1),U,1) X ^DD("DD")
|
||||
S STRING="tDate/Time of Event: "_Y D NEXT
|
||||
S STRING="tObserver : "_USRNAM D NEXT
|
||||
S SEVCOD=$P(GMRA(1),U,14)
|
||||
S SEVER=$S(SEVCOD=1:"MILD",SEVCOD=2:"MODERATE",SEVCOD=3:"SEVERE",1:"")
|
||||
S STRING="tSeverity : "_SEVER D NEXT
|
||||
S Y=$P(GMRA(1),U,18) X ^DD("DD")
|
||||
S STRING="tDate Reported : "_Y D NEXT
|
||||
S USRNAM=""
|
||||
S USR=$P(GMRA(1),U,19) I USR'="" D GETUSR
|
||||
S STRING="tReporting User : "_USRNAM D NEXT
|
||||
S STRING="t" F I=1:1:60 S STRING=STRING_"-"
|
||||
D NEXT
|
||||
G OBSLOOP
|
||||
EXIT Q
|
||||
NEXT ;SET ARRAY NODE AND INCREMENT ARRAY COUNTER
|
||||
S @GMRARRAY@(ND)=STRING,ND=ND+1,STRING=""
|
||||
Q
|
||||
GETUSR S USRNAM=$$GET1^DIQ(200,USR_",",".01")
|
||||
Q
|
||||
;
|
||||
EIE(GMRAIEN,GMRADFN,GMRARRAY) ;Mark individual entry as entered in error
|
||||
N DIE,DA,DR,Y,DIK,DFN,OROLD,VAIN,X,GMRAOUT,GMRAPA
|
||||
L +^XTMP("GMRAED",GMRADFN):1 I '$T D MESS Q
|
||||
S GMRAPA=GMRAIEN
|
||||
S DIE="^GMR(120.8,",DA=GMRAPA,DR="15///1;22///1;23///"_@GMRARRAY@("GMRAERRDT")_";24////"_$G(@GMRARRAY@("GMRAERRBY"),.5) ;36
|
||||
D ^DIE ;Entered in error on date/time by user
|
||||
I $D(@GMRARRAY@("GMRAERRCMTS")) D ADCOM(GMRAPA,"E",$NA(@GMRARRAY@("GMRAERRCMTS"))) ;add comments
|
||||
I $$NKASCR^GMRANKA($P(^GMR(120.8,GMRAPA,0),U)) D
|
||||
.S DIK="^GMR(120.86,",DA=$P(^GMR(120.8,GMRAPA,0),U)
|
||||
.D ^DIK ;If patient's last allergy marked as entered in error then delete assessment
|
||||
S GMRAPA(0)=$G(^GMR(120.8,GMRAPA,0)) Q:GMRAPA(0)=""
|
||||
S GMRAOUT=0
|
||||
D EN1^GMRAEAB ;Sends entered in error bulletin to appropriate mail groups
|
||||
D EN1^GMRAPET0(GMRADFN,GMRAPA,"E",.GMRAOUT) ;21 File Progress Note
|
||||
S DFN=GMRADFN
|
||||
D INP^VADPT S X=$$FIND1^DIC(101,,"BX","GMRA ENTERED IN ERROR")_";ORD(101,"
|
||||
D:X EN^XQOR ;Process protocols hanging off of "entered in error" protocol
|
||||
L -^XTMP("GMRAED",GMRADFN)
|
||||
Q
|
||||
;
|
||||
ADCOM(ENTRY,TYPE,GMRACOM) ;Add comments to allergies
|
||||
;
|
||||
N FDA,GMRAI,X,DIWL,DIWR
|
||||
K ^UTILITY($J,"W") S DIWL=1,DIWR=60 S GMRAI=0 F S GMRAI=$O(@GMRACOM@(GMRAI)) Q:'+GMRAI S X=@GMRACOM@(GMRAI) D ^DIWP
|
||||
S GMRACOM="^UTILITY($J,""W"",1)"
|
||||
S FDA(120.826,"+1,"_ENTRY_",",.01)=$$NOW^XLFDT
|
||||
S FDA(120.826,"+1,"_ENTRY_",",1)=DUZ
|
||||
S FDA(120.826,"+1,"_ENTRY_",",1.5)=TYPE
|
||||
S FDA(120.826,"+1,"_ENTRY_",",2)=GMRACOM
|
||||
D UPDATE^DIE("","FDA")
|
||||
Q
|
||||
;
|
||||
NKA ;Change patient assessment to NKA
|
||||
;
|
||||
N DA,DR,DIE,NKA,DFN
|
||||
S DFN=ORDFN
|
||||
L +^XTMP("GMRAED",DFN):1 I '$T D MESS Q
|
||||
S NKA=$$NKA^GMRANKA(DFN)
|
||||
I NKA=0 Q ;Patient is already NKA
|
||||
I NKA=1 S ORY="-1^Patient has active allergies - can't mark as NKA" Q
|
||||
L +^GMR(120.86,0):5 I '$T S ORY="-1^Unable to update assessment - try again." Q
|
||||
I '$D(^GMR(120.86,DFN,0)) D ;Add assessment entry
|
||||
.S $P(^GMR(120.86,0),U,3,4)=(DFN_"^"_($P(^GMR(120.86,0),U,4)+1))
|
||||
.S ^GMR(120.86,DFN,0)=DFN_U,^GMR(120.86,"B",DFN,DFN)=""
|
||||
L -^GMR(120.86,0) L +^GMR(120.86,DFN,0):5 I '$T S ORY="-1^Unable to update assessment - try again." Q
|
||||
S DIE="^GMR(120.86,",DA=DFN,DR="1////0;2////"_DUZ_";3///NOW" D ^DIE
|
||||
S ORY=0
|
||||
L -^XTMP("GMRAED",DFN)
|
||||
Q
|
||||
;
|
||||
UPDATE(GMRAIEN,DFN,GMRARRAY) ;Add/edit allergies
|
||||
N NEW,NKA,FDA,NODE,IEN,SUB,FILE,DA,DIK,SIEN,GMRAS0,GMRAIEN,GMRAL,GMRAPA,GMRAAR,GMRALL,GMRADFN,GMRAOUT,GMRAROT
|
||||
S NEW='$G(GMRAIEN)
|
||||
I NEW,$$DUPCHK^GMRAOR0(DFN,$P(@GMRARRAY@("GMRAGNT"),U))=1 S ORY="-1^Patient already has a "_$P(@GMRARRAY@("GMRAGNT"),U)_" reaction entered. No duplicates allowed." Q
|
||||
L +^XTMP("GMRAED",DFN):1 I '$T D MESS Q
|
||||
D SITE^GMRAUTL S GMRASITE(0)=$G(^GMRD(120.84,+GMRASITE,0))
|
||||
S NKA='$$NKA^GMRANKA(DFN) ;is patient NKA?
|
||||
I NKA,NEW D
|
||||
.S FDA(120.86,"?+"_DFN_",",.01)=DFN
|
||||
.S FDA(120.86,"?+"_DFN_",",1)=1
|
||||
.S FDA(120.86,"?+"_DFN_",",2)=DUZ
|
||||
.S FDA(120.86,"?+"_DFN_",",3)=$G(@GMRARRAY@("GMRAORDT"),$$NOW^XLFDT)
|
||||
.S IEN(DFN)=DFN
|
||||
.D UPDATE^DIE("","FDA","IEN")
|
||||
K FDA,IEN
|
||||
S NODE=$S($G(NEW):"+1,",1:(GMRAIEN_","))
|
||||
S:$G(NEW) FDA(120.8,NODE,.01)=DFN
|
||||
I $P($G(@GMRARRAY@("GMRAGNT")),U,2)["50.67" S $P(@GMRARRAY@("GMRAGNT"),U,2)=$$TGTOG^PSNAPIS($P(@GMRARRAY@("GMRAGNT"),U))_";PSNDF(50.6,"
|
||||
F SUB="GMRAGNT;.02","GMRATYPE;3.1","GMRANATR;17","GMRAORIG;5","GMRAORDT;4","GMRAOBHX;6" D
|
||||
.S FDA(120.8,NODE,$P(SUB,";",2))=$P(@GMRARRAY@($P(SUB,";")),U)
|
||||
.I (SUB["GMRAGNT"),NEW S FDA(120.8,NODE,1)=$P(@GMRARRAY@($P(SUB,";")),U,2)
|
||||
D UPDATE^DIE("","FDA","IEN")
|
||||
S:NEW GMRAIEN=IEN(1)
|
||||
K FDA
|
||||
F SUB="GMRACHT","GMRAIDBN" D
|
||||
.Q:'$D(@GMRARRAY@(SUB)) ;Stop if no updates
|
||||
.S FILE=$S(SUB="GMRACHT":120.813,1:120.814)
|
||||
.S FDA(FILE,"+1,"_GMRAIEN_",",.01)=@GMRARRAY@(SUB,1)
|
||||
.S FDA(FILE,"+1,"_GMRAIEN_",",1)=DUZ
|
||||
.D UPDATE^DIE("","FDA")
|
||||
I $D(@GMRARRAY@("GMRACMTS")) D ADCOM(GMRAIEN,"O",$NA(@GMRARRAY@("GMRACMTS"))) ;Add comments if included
|
||||
K FDA
|
||||
S SUB=0 F S SUB=$O(@GMRARRAY@("GMRASYMP",SUB)) Q:'+SUB D
|
||||
.S GMRAS0=^(SUB) ;Naked from above
|
||||
.Q:$P(^(SUB),U)="" ;25 No text or free text entered so don't store
|
||||
.S SIEN=$O(^GMR(120.8,GMRAIEN,10,"B",$P(GMRAS0,U),0))
|
||||
.I SIEN,$P(^GMR(120.8,GMRAIEN,10,SIEN,0),U,4)=$P(GMRAS0,U,3) Q ;Exists and nothing has changed
|
||||
.I SIEN,$P(GMRAS0,U,5)="@" S DIK="^GMR(120.8,"_GMRAIEN_",",DA(1)=GMRAIEN,DA=SIEN D ^DIK Q ;Sign/symptom deleted
|
||||
.S:'SIEN FDA(120.81,"+1,"_GMRAIEN_",",.01)=$S($P(GMRAS0,U)="FT":$O(^GMRD(120.83,"B","OTHER REACTION",0)),1:$P(GMRAS0,U))
|
||||
.S NODE=$S(SIEN:SIEN_","_GMRAIEN,1:"+1,"_GMRAIEN_",")
|
||||
.S:$P(GMRAS0,U)="FT" FDA(120.81,NODE,1)=$P(GMRAS0,U,2)
|
||||
.S FDA(120.81,NODE,2)=DUZ
|
||||
.S FDA(120.81,NODE,3)=$P(GMRAS0,U,3)
|
||||
.D UPDATE^DIE("","FDA","","ERR")
|
||||
.S GMRAROT($P(GMRAS0,U,2))="" ;21 record s/s added
|
||||
I NEW D
|
||||
.S GMRALL(GMRAIEN)="" D VAD^GMRAUTL1(DFN,,.GMRALOC,.GMRANAM) D EN7^GMRAMCB ;Send mark chart/ID band bulletin if needed.
|
||||
.I $P(@GMRARRAY@("GMRAOBHX"),U)="o" D ;if observed reaction add data to 120.85
|
||||
..S GMRAOUT=0 ;21
|
||||
..S GMRAL(GMRAIEN,"O",GMRAIEN)=$G(@GMRARRAY@("GMRARDT"))_"^"_$G(@GMRARRAY@("GMRASEVR"))
|
||||
..S GMRADFN=DFN
|
||||
..S GMRAL(GMRAIEN)="^^"_$P($G(@GMRARRAY@("GMRAGNT")),U)_"^^^^"_$G(@GMRARRAY@("GMRAORIG"))
|
||||
..M GMRAL(GMRAIEN,"S")=@GMRARRAY@("GMRASYMP")
|
||||
..S SUB=0 F S SUB=$O(GMRAL(GMRAIEN,"S",SUB)) Q:'+SUB S $P(GMRAL(GMRAIEN,"S",SUB),U,2)=$P(GMRAL(GMRAIEN,"S",SUB),U,2)_"^" S:$P(GMRAL(GMRAIEN,"S",SUB),U)="FT" $P(GMRAL(GMRAIEN,"S",SUB),U)=$O(^GMRD(120.83,"B","OTHER REACTION",0))
|
||||
..S GMRAL=GMRAIEN
|
||||
..D ADVERSE^GMRAOR7(GMRAIEN,.GMRAL) ;adds entry to 120.85
|
||||
..S GMRAIEN(GMRAIEN)="" ;21
|
||||
..D EN1^GMRAPET0(GMRADFN,.GMRAIEN,"S",.GMRAOUT) ;21 File progress note
|
||||
..I $G(@GMRARRAY@("GMRATYPE"))["D" S GMRAPA=GMRAIEN D EN1^GMRAPTB ;21 Send med-watch update
|
||||
.S GMRAAR=$P($G(@GMRARRAY@("GMRAGNT")),U,2),GMRAPA=GMRAIEN
|
||||
.D EN1^GMRAOR9 S ^TMP($J,"GMRASF",1,GMRAPA)="" D RANGE^GMRASIGN(1) ;add ingredients/classes send appropriate bulletins
|
||||
S ORY=0
|
||||
L -^XTMP("GMRAED",DFN)
|
||||
Q
|
||||
;
|
||||
MESS ;Give out locked message
|
||||
N GMRAXBOS,GMRAL1,GMRAL2
|
||||
S GMRAXBOS=$$BROKER^XWBLIB ;In GUI?
|
||||
S GMRAL1="Another user is editing this patient's allergy information."
|
||||
S GMRAL2="Please refresh/review the patient's information before proceeding."
|
||||
I 'GMRAXBOS W !,GMRAL1,!,GMRAL2 D WAIT^GMRAFX3 Q
|
||||
S ORY="-1^"_GMRAL1_" "_GMRAL2
|
||||
Q
|
||||
|
|
|
|||
|
|
@ -1,121 +1,121 @@
|
|||
GMRAPET0 ;HIRMFO/RM-VERIFIED ALLERGY TASKS ;11/17/06 10:27
|
||||
;;4.0;Adverse Reaction Tracking;**6,17,21,20,38**;Mar 29, 1996;Build 2
|
||||
EN1(GMRADFN,GMRAPA,GMRACT,GMRAOUT) ;
|
||||
; ENTRY TO PERFORM ALL OF THE TASKS NECESSARY FOR
|
||||
; A PROGRESS NOTE TO BE ENTERED BY ART
|
||||
; INPUT:
|
||||
; GMRADFN = PATIENT IEN IN THE PATIENT FILE
|
||||
; GMRAPA = THE IEN IN THE PATIENT ALLERGY FILE
|
||||
; GMRACT = THE ACTION TO BE ENTERED FOR THIS REACTION
|
||||
; = "V" VERIFICATION OF A REACTION
|
||||
; = "S" SIGN OFF OF A REACTION
|
||||
; = "M" MEDWATCH FORM ENTERD
|
||||
; = "E" REACTION ENERED IN ERROR
|
||||
; OUTPUT:
|
||||
; GMRAOUT = REACTION ALL WAS PASSED
|
||||
; = 1 USER ABORT OR PN FAIL IN SOME WAY
|
||||
; = 0 PASSED
|
||||
;
|
||||
; VARABLE LIST
|
||||
; GMRACW = IS THE PROGRESS NOTE TITLE
|
||||
; GMRALOC = IS THE LOCATION OF THE PATIENT
|
||||
; GMRAHLOC = IS THE LOCATION IN FILE 44
|
||||
; GMRADFN = IS THE PATIENT IEN
|
||||
; GMRADT = IS THE DATE THE EVENT TOOK PLACE
|
||||
; GMRADUZ = IS THE USER WHO ENTERED THE INFORMATION
|
||||
; GMRAPN = IS THE IEN OF THE PROGRESS NOTE THAT WAS ENTERED
|
||||
;
|
||||
;CHECKING FOR A VALID TITLE
|
||||
K ^TMP("TIUP",$J),GMRAPN
|
||||
N GMRACW,GMRALOC,GMRAHLOC,GMRAXBOS ;21
|
||||
S GMRAPN=-1,GMRAXBOS=$$BROKER^XWBLIB ;21 Got GUI?
|
||||
I "VSME"'[GMRACT S GMRAOUT=1 D EXIT Q
|
||||
; The following lines of code which reference Progress Notes files and
|
||||
; routines will have to change when TIU replaces Progress Notes.
|
||||
;S GMRACW=0 F S GMRACW=$O(^GMR(121.2,"B","ADVERSE REACTION/ALLERGY",GMRACW)) Q:GMRACW<1 I $P($G(^GMR(121.1,$P($G(^GMR(121.2,GMRACW,0)),U,2),0)),U)="GENERAL NOTE" Q
|
||||
;-----ADDED BY VAUGHN 1/13/97 FOR TIU REPLACES LINE ABOVE----
|
||||
S GMRACW=+$$WHATITLE^TIUPUTU("ADVERSE REACTION/ALLERGY")
|
||||
;------END---
|
||||
;-----CHANGED BY VAUGHN 1/13/97 FOR TIU---
|
||||
I GMRACW<1!($T(NEW^TIUPNAPI)']"")!('$$CANPICK^TIULP(GMRACW)) S GMRAOUT=1 D EXIT Q ;21
|
||||
;I GMRACW<1!($T(PN^GMRPART)']"") S GMRAOUT=1 D EXIT Q
|
||||
;-----END----
|
||||
D @GMRACT I GMRAOUT D EXIT Q ; THIS TELL'S THE PROGRAM WHERE TO GO
|
||||
S GMRALOC=""
|
||||
D VAD^GMRAUTL1(GMRADFN,"",.GMRALOC,"","","")
|
||||
I GMRALOC'="" S GMRAHLOC=+$G(^DIC(42,GMRALOC,44))
|
||||
;E I '$G(GMRAXBOS) D ASK ;20
|
||||
; Call to Progress Notes
|
||||
; vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
|
||||
;S:'GMRAOUT GMRAPN=+$$PN^GMRPART(GMRADFN,GMRADUZ,GMRADT,GMRACW,GMRAHLOC)
|
||||
;---REPLACED LINE ABOVE WITH LINE BELOW;1/13/97 VAUGHN---
|
||||
I 'GMRAOUT D
|
||||
.S GMRAPN=0 D NEW^TIUPNAPI(.GMRAPN,GMRADFN,GMRADUZ,GMRADT,GMRACW,$G(GMRAHLOC),$S($G(GMRAXBOS):0,1:1)) ;17,21 Allow editing if not in GUI
|
||||
;----------END-------
|
||||
I GMRAPN=-1,'$G(GMRAXBOS) S GMRAOUT=1 W !,"No Progress Note was created." ;21
|
||||
I GMRAPN=0,'$G(GMRAXBOS) W !,"Progress note has not been signed." ;21
|
||||
D EXIT
|
||||
Q
|
||||
EXIT ; Clean up of variables
|
||||
K ^TMP("TIUP",$J),GMRALOC,GMRAHLOC,GMRADUZ ;38 Removed variable GMRAPN from list of variables to kill
|
||||
Q
|
||||
ASK ; Simple file manager query for a location in file 44
|
||||
N DIC
|
||||
S X=""
|
||||
S DIC=44,DIC(0)="AEQ",DIC("A")="Select a Hospital Location: ",DIC("S")="I ""CMW""[$P(^(0),U,3)" ;20
|
||||
W !,"A progress note is being created because you "_$S(GMRACT="V":"verified",GMRACT="E":"inactivated",GMRACT="S":"activated",1:"entered a medwatch form for"),!,$P($G(^GMR(120.8,GMRAPA,0)),U,2),"." ;20
|
||||
W !,"Enter a hospital location to be associated with this note." ;20
|
||||
D ^DIC
|
||||
I $D(DTOUT)!($D(DUOUT)) S GMRAOUT=1 Q
|
||||
S GMRAHLOC=+Y
|
||||
Q
|
||||
V ; Verified Reaction
|
||||
N GMRAI ;21
|
||||
S GMRAPA(0)=$G(^GMR(120.8,GMRAPA,0))
|
||||
S GMRADT=$P(GMRAPA(0),U,17),GMRADUZ=$P(GMRAPA(0),U,18)
|
||||
S:GMRADUZ="" GMRADUZ=DUZ ; Autoverified reaction being reverified
|
||||
S ^TMP("TIUP",$J,1,0)="This patient has had an "_$S($P(GMRAPA(0),"^",14)="P":"adverse reaction reported for ",1:"allergy to ")_$P(GMRAPA(0),"^",2)
|
||||
S ^TMP("TIUP",$J,2,0)="verified on "_$$FMTE^XLFDT(GMRADT,1)_"."
|
||||
S GMRAI=2 D ADDCOM("V",.GMRAI) ;21
|
||||
S ^TMP("TIUP",$J,0)=U_U_GMRAI_U_GMRAI_U_GMRADT_"^^^" ;21
|
||||
Q
|
||||
S ; Signed Reaction
|
||||
N GMRAI,GMRAREAC ;21
|
||||
D NOW^%DTC
|
||||
S GMRADT=%,GMRADUZ=DUZ
|
||||
S GMRAREAC=0,GMRAI=3 F S GMRAREAC=$O(GMRAPA(GMRAREAC)) Q:GMRAREAC<1 S GMRAI=GMRAI+1,^TMP("TIUP",$J,GMRAI,0)=$P($G(^GMR(120.8,GMRAREAC,0)),U,2) S GMRAPA=GMRAREAC D ;21
|
||||
.D ADDCOM("O",.GMRAI) ;21
|
||||
.S GMRAI=GMRAI+1,^TMP("TIUP",$J,GMRAI,0)="" ;21
|
||||
S ^TMP("TIUP",$J,1,0)="This patient has had the following reaction"_$S(GMRAI=3:" ",1:"s ")
|
||||
S ^TMP("TIUP",$J,2,0)="signed-off on "_$$FMTE^XLFDT(GMRADT,1)_"."
|
||||
S ^TMP("TIUP",$J,3,0)="" ;21
|
||||
S ^TMP("TIUP",$J,0)=U_U_GMRAI_U_GMRAI_U_GMRADT_"^^^"
|
||||
Q
|
||||
M ; MedWATCH data entered
|
||||
N X
|
||||
S GMRAPA(0)=$G(^GMR(120.8,GMRAPA,0))
|
||||
D NOW^%DTC
|
||||
S GMRADT=%,GMRADUZ=DUZ
|
||||
S ^TMP("TIUP",$J,1,0)="This patient has had a MEDWatch report completed on "_$$FMTE^XLFDT(GMRADT,1)_" for"
|
||||
S ^TMP("TIUP",$J,2,0)=$S($P(GMRAPA(0),"^",14)="P":"an adverse reaction to ",1:"allergy to ")_$P(GMRAPA(0),"^",2)_"."
|
||||
S ^TMP("TIUP",$J,0)=U_U_"2"_U_"2"_U_GMRADT_"^^^"
|
||||
Q
|
||||
E ; Reaction Entered in Error
|
||||
N GMRAER,GMRAI ;21
|
||||
S GMRAPA(0)=$G(^GMR(120.8,GMRAPA,0))
|
||||
S GMRAER=$G(^GMR(120.8,GMRAPA,"ER")) I GMRAER="" S GMRAOUT=1 Q
|
||||
S GMRADT=$P(GMRAER,U,2),GMRADUZ=$P(GMRAER,U,3)
|
||||
S ^TMP("TIUP",$J,1,0)="The "_$S($P(GMRAPA(0),"^",14)="P":"adverse reaction ",1:"allergy ")_"to "_$P(GMRAPA(0),"^",2)_" was removed on "_$$FMTE^XLFDT($P(GMRADT,"."),2)_"." ;20
|
||||
S ^TMP("TIUP",$J,2,0)="This reaction was either an erroneous entry or was found" ;20
|
||||
S ^TMP("TIUP",$J,3,0)="to no longer be a true "_$S($P(GMRAPA(0),"^",14)="P":"adverse reaction",1:"allergy")_"." ;20
|
||||
S GMRAI=3 D ADDCOM("E",.GMRAI) ;21,20
|
||||
S ^TMP("TIUP",$J,0)=U_U_GMRAI_U_GMRAI_U_GMRADT_"^^^" ;21
|
||||
Q
|
||||
;
|
||||
ADDCOM(TYPE,CNT) ;Add any comments to progress note - section added in patch 21
|
||||
N SUB,ENTRY
|
||||
S ENTRY=$O(^GMR(120.8,GMRAPA,26,"AVER",TYPE,0)) Q:'+ENTRY
|
||||
S CNT=CNT+1,^TMP("TIUP",$J,CNT,0)="",CNT=CNT+1,^TMP("TIUP",$J,CNT,0)="Author's comments:"
|
||||
S CNT=CNT+1,^TMP("TIUP",$J,CNT,0)=""
|
||||
S SUB=0 F S SUB=$O(^GMR(120.8,GMRAPA,26,ENTRY,2,SUB)) Q:'+SUB S CNT=CNT+1,^TMP("TIUP",$J,CNT,0)=^GMR(120.8,GMRAPA,26,ENTRY,2,SUB,0)
|
||||
Q
|
||||
GMRAPET0 ;HIRMFO/RM-VERIFIED ALLERGY TASKS ;4/7/06 12:38
|
||||
;;4.0;Adverse Reaction Tracking;**6,17,21,20**;Mar 29, 1996;Build 1
|
||||
EN1(GMRADFN,GMRAPA,GMRACT,GMRAOUT) ;
|
||||
; ENTRY TO PERFORM ALL OF THE TASKS NECESSARY FOR
|
||||
; A PROGRESS NOTE TO BE ENTERED BY ART
|
||||
; INPUT:
|
||||
; GMRADFN = PATIENT IEN IN THE PATIENT FILE
|
||||
; GMRAPA = THE IEN IN THE PATIENT ALLERGY FILE
|
||||
; GMRACT = THE ACTION TO BE ENTERED FOR THIS REACTION
|
||||
; = "V" VERIFICATION OF A REACTION
|
||||
; = "S" SIGN OFF OF A REACTION
|
||||
; = "M" MEDWATCH FORM ENTERD
|
||||
; = "E" REACTION ENERED IN ERROR
|
||||
; OUTPUT:
|
||||
; GMRAOUT = REACTION ALL WAS PASSED
|
||||
; = 1 USER ABORT OR PN FAIL IN SOME WAY
|
||||
; = 0 PASSED
|
||||
;
|
||||
; VARABLE LIST
|
||||
; GMRACW = IS THE PROGRESS NOTE TITLE
|
||||
; GMRALOC = IS THE LOCATION OF THE PATIENT
|
||||
; GMRAHLOC = IS THE LOCATION IN FILE 44
|
||||
; GMRADFN = IS THE PATIENT IEN
|
||||
; GMRADT = IS THE DATE THE EVENT TOOK PLACE
|
||||
; GMRADUZ = IS THE USER WHO ENTERED THE INFORMATION
|
||||
; GMRAPN = IS THE IEN OF THE PROGRESS NOTE THAT WAS ENTERED
|
||||
;
|
||||
;CHECKING FOR A VALID TITLE
|
||||
K ^TMP("TIUP",$J),GMRAPN
|
||||
N GMRACW,GMRALOC,GMRAHLOC,GMRAXBOS ;21
|
||||
S GMRAPN=-1,GMRAXBOS=$$BROKER^XWBLIB ;21 Got GUI?
|
||||
I "VSME"'[GMRACT S GMRAOUT=1 D EXIT Q
|
||||
; The following lines of code which reference Progress Notes files and
|
||||
; routines will have to change when TIU replaces Progress Notes.
|
||||
;S GMRACW=0 F S GMRACW=$O(^GMR(121.2,"B","ADVERSE REACTION/ALLERGY",GMRACW)) Q:GMRACW<1 I $P($G(^GMR(121.1,$P($G(^GMR(121.2,GMRACW,0)),U,2),0)),U)="GENERAL NOTE" Q
|
||||
;-----ADDED BY VAUGHN 1/13/97 FOR TIU REPLACES LINE ABOVE----
|
||||
S GMRACW=+$$WHATITLE^TIUPUTU("ADVERSE REACTION/ALLERGY")
|
||||
;------END---
|
||||
;-----CHANGED BY VAUGHN 1/13/97 FOR TIU---
|
||||
I GMRACW<1!($T(NEW^TIUPNAPI)']"")!('$$CANPICK^TIULP(GMRACW)) S GMRAOUT=1 D EXIT Q ;21
|
||||
;I GMRACW<1!($T(PN^GMRPART)']"") S GMRAOUT=1 D EXIT Q
|
||||
;-----END----
|
||||
D @GMRACT I GMRAOUT D EXIT Q ; THIS TELL'S THE PROGRAM WHERE TO GO
|
||||
S GMRALOC=""
|
||||
D VAD^GMRAUTL1(GMRADFN,"",.GMRALOC,"","","")
|
||||
I GMRALOC'="" S GMRAHLOC=+$G(^DIC(42,GMRALOC,44))
|
||||
;E I '$G(GMRAXBOS) D ASK ;20
|
||||
; Call to Progress Notes
|
||||
; vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
|
||||
;S:'GMRAOUT GMRAPN=+$$PN^GMRPART(GMRADFN,GMRADUZ,GMRADT,GMRACW,GMRAHLOC)
|
||||
;---REPLACED LINE ABOVE WITH LINE BELOW;1/13/97 VAUGHN---
|
||||
I 'GMRAOUT D
|
||||
.S GMRAPN=0 D NEW^TIUPNAPI(.GMRAPN,GMRADFN,GMRADUZ,GMRADT,GMRACW,$G(GMRAHLOC),$S($G(GMRAXBOS):0,1:1)) ;17,21 Allow editing if not in GUI
|
||||
;----------END-------
|
||||
I GMRAPN=-1,'$G(GMRAXBOS) S GMRAOUT=1 W !,"No Progress Note was created." ;21
|
||||
I GMRAPN=0,'$G(GMRAXBOS) W !,"Progress note has not been signed." ;21
|
||||
D EXIT
|
||||
Q
|
||||
EXIT ; Clean up of variables
|
||||
K ^TMP("TIUP",$J),GMRAPN,GMRALOC,GMRAHLOC,GMRADUZ
|
||||
Q
|
||||
ASK ; Simple file manager query for a location in file 44
|
||||
N DIC
|
||||
S X=""
|
||||
S DIC=44,DIC(0)="AEQ",DIC("A")="Select a Hospital Location: ",DIC("S")="I ""CMW""[$P(^(0),U,3)" ;20
|
||||
W !,"A progress note is being created because you "_$S(GMRACT="V":"verified",GMRACT="E":"inactivated",GMRACT="S":"activated",1:"entered a medwatch form for"),!,$P($G(^GMR(120.8,GMRAPA,0)),U,2),"." ;20
|
||||
W !,"Enter a hospital location to be associated with this note." ;20
|
||||
D ^DIC
|
||||
I $D(DTOUT)!($D(DUOUT)) S GMRAOUT=1 Q
|
||||
S GMRAHLOC=+Y
|
||||
Q
|
||||
V ; Verified Reaction
|
||||
N GMRAI ;21
|
||||
S GMRAPA(0)=$G(^GMR(120.8,GMRAPA,0))
|
||||
S GMRADT=$P(GMRAPA(0),U,17),GMRADUZ=$P(GMRAPA(0),U,18)
|
||||
S:GMRADUZ="" GMRADUZ=DUZ ; Autoverified reaction being reverified
|
||||
S ^TMP("TIUP",$J,1,0)="This patient has had an "_$S($P(GMRAPA(0),"^",14)="P":"adverse reaction reported for ",1:"allergy to ")_$P(GMRAPA(0),"^",2)
|
||||
S ^TMP("TIUP",$J,2,0)="verified on "_$$FMTE^XLFDT(GMRADT,1)_"."
|
||||
S GMRAI=2 D ADDCOM("V",.GMRAI) ;21
|
||||
S ^TMP("TIUP",$J,0)=U_U_GMRAI_U_GMRAI_U_GMRADT_"^^^" ;21
|
||||
Q
|
||||
S ; Signed Reaction
|
||||
N GMRAI,GMRAREAC ;21
|
||||
D NOW^%DTC
|
||||
S GMRADT=%,GMRADUZ=DUZ
|
||||
S GMRAREAC=0,GMRAI=3 F S GMRAREAC=$O(GMRAPA(GMRAREAC)) Q:GMRAREAC<1 S GMRAI=GMRAI+1,^TMP("TIUP",$J,GMRAI,0)=$P($G(^GMR(120.8,GMRAREAC,0)),U,2) S GMRAPA=GMRAREAC D ;21
|
||||
.D ADDCOM("O",.GMRAI) ;21
|
||||
.S GMRAI=GMRAI+1,^TMP("TIUP",$J,GMRAI,0)="" ;21
|
||||
S ^TMP("TIUP",$J,1,0)="This patient has had the following reaction"_$S(GMRAI=3:" ",1:"s ")
|
||||
S ^TMP("TIUP",$J,2,0)="signed-off on "_$$FMTE^XLFDT(GMRADT,1)_"."
|
||||
S ^TMP("TIUP",$J,3,0)="" ;21
|
||||
S ^TMP("TIUP",$J,0)=U_U_GMRAI_U_GMRAI_U_GMRADT_"^^^"
|
||||
Q
|
||||
M ; MedWATCH data entered
|
||||
N X
|
||||
S GMRAPA(0)=$G(^GMR(120.8,GMRAPA,0))
|
||||
D NOW^%DTC
|
||||
S GMRADT=%,GMRADUZ=DUZ
|
||||
S ^TMP("TIUP",$J,1,0)="This patient has had a MEDWatch report completed on "_$$FMTE^XLFDT(GMRADT,1)_" for"
|
||||
S ^TMP("TIUP",$J,2,0)=$S($P(GMRAPA(0),"^",14)="P":"an adverse reaction to ",1:"allergy to ")_$P(GMRAPA(0),"^",2)_"."
|
||||
S ^TMP("TIUP",$J,0)=U_U_"2"_U_"2"_U_GMRADT_"^^^"
|
||||
Q
|
||||
E ; Reaction Entered in Error
|
||||
N GMRAER,GMRAI ;21
|
||||
S GMRAPA(0)=$G(^GMR(120.8,GMRAPA,0))
|
||||
S GMRAER=$G(^GMR(120.8,GMRAPA,"ER")) I GMRAER="" S GMRAOUT=1 Q
|
||||
S GMRADT=$P(GMRAER,U,2),GMRADUZ=$P(GMRAER,U,3)
|
||||
S ^TMP("TIUP",$J,1,0)="The "_$S($P(GMRAPA(0),"^",14)="P":"adverse reaction ",1:"allergy ")_"to "_$P(GMRAPA(0),"^",2)_" was removed on "_$$FMTE^XLFDT($P(GMRADT,"."),2)_"." ;20
|
||||
S ^TMP("TIUP",$J,2,0)="This reaction was either an erroneous entry or was found" ;20
|
||||
S ^TMP("TIUP",$J,3,0)="to no longer be a true "_$S($P(GMRAPA(0),"^",14)="P":"adverse reaction",1:"allergy")_"." ;20
|
||||
S GMRAI=3 D ADDCOM("E",.GMRAI) ;21,20
|
||||
S ^TMP("TIUP",$J,0)=U_U_GMRAI_U_GMRAI_U_GMRADT_"^^^" ;21
|
||||
Q
|
||||
;
|
||||
ADDCOM(TYPE,CNT) ;Add any comments to progress note - section added in patch 21
|
||||
N SUB,ENTRY
|
||||
S ENTRY=$O(^GMR(120.8,GMRAPA,26,"AVER",TYPE,0)) Q:'+ENTRY
|
||||
S CNT=CNT+1,^TMP("TIUP",$J,CNT,0)="",CNT=CNT+1,^TMP("TIUP",$J,CNT,0)="Author's comments:"
|
||||
S CNT=CNT+1,^TMP("TIUP",$J,CNT,0)=""
|
||||
S SUB=0 F S SUB=$O(^GMR(120.8,GMRAPA,26,ENTRY,2,SUB)) Q:'+SUB S CNT=CNT+1,^TMP("TIUP",$J,CNT,0)=^GMR(120.8,GMRAPA,26,ENTRY,2,SUB,0)
|
||||
Q
|
||||
|
|
|
|||
|
|
@ -1,83 +1,82 @@
|
|||
GMRAPFT ;HIRMFO/WAA- PRINT FDA REACTION BY DATE ENTERED/TRACKED ;4/10/97 09:30
|
||||
;;4.0;Adverse Reaction Tracking;**7,33**;Mar 29, 1996;Build 5
|
||||
EN1 ; This routine will loop through the ADT entry point to get all
|
||||
; the entries in that date range.
|
||||
S GMRAOUT=0
|
||||
W !,"Select a Tracking date range for this report."
|
||||
D DT^GMRAPL G:GMRAOUT EXIT
|
||||
D PRINTER
|
||||
EXIT ; Exit of program kill cleanup
|
||||
D KILL^XUSCLEAN
|
||||
Q
|
||||
PRINTER ;Select printer
|
||||
W ! K GMRAZIS D DEV^GMRAUTL I POP W !,"PLEASE TRY LATER" S GMRAOUT=1 Q
|
||||
I $D(IO("Q")) D Q
|
||||
. S ZTRTN="PRINT^GMRAPFT",(ZTSAVE("GMRAOUT"),ZTSAVE("GMAST"),ZTSAVE("GMAEN"))=""
|
||||
. S ZTDESC="List of FDA Reactions over a Date range by Tracking date" D ^%ZTLOAD
|
||||
. W !!,$S($D(ZTSK):"Request queued...",1:"Request NOT queued please try Later.")
|
||||
. Q
|
||||
U IO D PRINT U IO(0)
|
||||
D EXIT
|
||||
Q
|
||||
PRINT ;Queue point for report
|
||||
D NOW^%DTC S GMRADPDT=X
|
||||
S GMRADATE=GMAST-.0001,GMRAPG=1
|
||||
F S GMRADATE=$O(^GMR(120.85,"ARDT",GMRADATE)) Q:GMRADATE<1 Q:GMRADATE>GMAEN D Q:GMRAOUT
|
||||
.S GMRAPA1=0
|
||||
.F S GMRAPA1=$O(^GMR(120.85,"ARDT",GMRADATE,GMRAPA1)) Q:GMRAPA1<1 D Q:GMRAOUT
|
||||
..S GMRAPA1(0)=$G(^GMR(120.85,GMRAPA1,0)) Q:GMRAPA1(0)=""
|
||||
..Q:+$G(^GMR(120.8,$P(GMRAPA1(0),U,15),"ER")) ;data entered in error
|
||||
..D HEAD Q:GMRAOUT
|
||||
..S (GMRAPID,GMRANAME,GMRALOC)=""
|
||||
..S GMRADFN=$P(GMRAPA1(0),U,2),GMRADDT=$P(GMRAPA1(0),U)
|
||||
..Q:'$$PRDTST^GMRAUTL1(GMRADFN) ;GMRA*4*33 Exclude test patient from report if production or legacy system.
|
||||
..D VAD^GMRAUTL1(GMRADFN,GMRADDT,.GMRALOC,.GMRANAME,"",.GMRAPID)
|
||||
..I GMRALOC="" S GMRALOC="OUT PATIENT"
|
||||
..E S GMRALOC=$P($G(^DIC(42,GMRALOC,0)),U)
|
||||
..W !,$E(GMRANAME,1,30) ; Patient Name
|
||||
..K GMRARAC
|
||||
..S GMRARAC=0,GMRACNT=1 F S GMRARAC=$O(^GMR(120.85,GMRAPA1,3,GMRARAC)) Q:GMRARAC<1 D
|
||||
...S GMRARAC(GMRACNT)=$P($G(^GMR(120.85,GMRAPA1,3,GMRARAC,0)),U) Q:GMRARAC(GMRACNT)=""
|
||||
...S GMRACNT=GMRACNT+1
|
||||
...Q
|
||||
..W ?32,"Obs DT: ",$$FMTE^XLFDT($P(GMRAPA1(0),U),"2D") ; Observed Date
|
||||
..W ?49,$E($G(GMRARAC(1)),1,30) ; The 1st reaction that is listed first
|
||||
..W !,"(",GMRAPID,")"
|
||||
..W ?32,"Trk DT: ",$$FMTE^XLFDT($P(GMRAPA1(0),U,18),"2D") ; Tracking Date
|
||||
..W ?49,$E($G(GMRARAC(2)),1,30) ; The 2nd reaction that is listed
|
||||
..W !,"Loc: ",GMRALOC
|
||||
..W ?32,"-------------" ; Separator
|
||||
..W ?49,$E($G(GMRARAC(3)),1,30) ; The 3rd reaction that is listed
|
||||
..W !,"Obs: ",$P($G(^VA(200,$P(GMRAPA1(0),U,19),0)),U) ; User entered
|
||||
..D
|
||||
...N X1,X2,X,Y
|
||||
...S X2=$P(GMRAPA1(0),U),X1=$P(GMRAPA1(0),U,18)
|
||||
...D ^%DTC
|
||||
...W ?32,X," Days Difference" ;Difference
|
||||
...Q
|
||||
..W ?50,$E($G(GMRARAC(4)),1,30) ; The 4th reaction that is listed
|
||||
..S GMRACNT=4 F S GMRACNT=$O(GMRARAC(GMRACNT)) Q:GMRACNT<1 W !,?50,$E($G(GMRARAC(GMRACNT)),1,30) ; The Nth reaction that is listed
|
||||
..W ! ; Put a blank line between the ADRs
|
||||
..Q
|
||||
.Q
|
||||
D CLOSE^GMRAUTL
|
||||
Q
|
||||
HEAD ; Print header information
|
||||
I GMRAPG'=1 Q:$Y<(IOSL-4)
|
||||
I $E(IOST,1)="C" D Q:GMRAOUT
|
||||
.I GMRAPG=1 W @IOF Q
|
||||
.I GMRAPG'=1 D Q:GMRAOUT
|
||||
..N DIR S DIR(0)="E" D ^DIR I 'Y S GMRAOUT=1
|
||||
..K Y
|
||||
..Q
|
||||
.Q
|
||||
Q:GMRAOUT
|
||||
I GMRAPG'=1 W @IOF
|
||||
W "Report Date: ",$P($$FMTE^XLFDT(GMRADPDT),"@"),?70,"Page: ",GMRAPG
|
||||
W !,?22,"Adverse Reaction Tracking Report"
|
||||
W !,?25,"From: ",$$FMTE^XLFDT(GMAST,"2D")," To: ",$$FMTE^XLFDT(GMAEN,"2D")
|
||||
W !,"Patient",?40,"Dates",?49,"Related Reaction"
|
||||
W !,$$REPEAT^XLFSTR("-",78)
|
||||
S GMRAPG=GMRAPG+1
|
||||
I $D(ZTQUEUED) S:$$STPCK^GMRAUTL1 GMRAOUT=1 ; Check if stopped by user
|
||||
Q
|
||||
GMRAPFT ;HIRMFO/WAA- PRINT FDA REACTION BY DATE ENTERED/TRACKED ;4/10/97 09:30
|
||||
;;4.0;Adverse Reaction Tracking;**7**;Mar 29, 1996
|
||||
EN1 ; This routine will loop through the ADT entry point to get all
|
||||
; the entries in that date range.
|
||||
S GMRAOUT=0
|
||||
W !,"Select a Tracking date range for this report."
|
||||
D DT^GMRAPL G:GMRAOUT EXIT
|
||||
D PRINTER
|
||||
EXIT ; Exit of program kill cleanup
|
||||
D KILL^XUSCLEAN
|
||||
Q
|
||||
PRINTER ;Select printer
|
||||
W ! K GMRAZIS D DEV^GMRAUTL I POP W !,"PLEASE TRY LATER" S GMRAOUT=1 Q
|
||||
I $D(IO("Q")) D Q
|
||||
. S ZTRTN="PRINT^GMRAPFT",(ZTSAVE("GMRAOUT"),ZTSAVE("GMAST"),ZTSAVE("GMAEN"))=""
|
||||
. S ZTDESC="List of FDA Reactions over a Date range by Tracking date" D ^%ZTLOAD
|
||||
. W !!,$S($D(ZTSK):"Request queued...",1:"Request NOT queued please try Later.")
|
||||
. Q
|
||||
U IO D PRINT U IO(0)
|
||||
D EXIT
|
||||
Q
|
||||
PRINT ;Queue point for report
|
||||
D NOW^%DTC S GMRADPDT=X
|
||||
S GMRADATE=GMAST-.0001,GMRAPG=1
|
||||
F S GMRADATE=$O(^GMR(120.85,"ARDT",GMRADATE)) Q:GMRADATE<1 Q:GMRADATE>GMAEN D Q:GMRAOUT
|
||||
.S GMRAPA1=0
|
||||
.F S GMRAPA1=$O(^GMR(120.85,"ARDT",GMRADATE,GMRAPA1)) Q:GMRAPA1<1 D Q:GMRAOUT
|
||||
..S GMRAPA1(0)=$G(^GMR(120.85,GMRAPA1,0)) Q:GMRAPA1(0)=""
|
||||
..Q:+$G(^GMR(120.8,$P(GMRAPA1(0),U,15),"ER")) ;data entered in error
|
||||
..D HEAD Q:GMRAOUT
|
||||
..S (GMRAPID,GMRANAME,GMRALOC)=""
|
||||
..S GMRADFN=$P(GMRAPA1(0),U,2),GMRADDT=$P(GMRAPA1(0),U)
|
||||
..D VAD^GMRAUTL1(GMRADFN,GMRADDT,.GMRALOC,.GMRANAME,"",.GMRAPID)
|
||||
..I GMRALOC="" S GMRALOC="OUT PATIENT"
|
||||
..E S GMRALOC=$P($G(^DIC(42,GMRALOC,0)),U)
|
||||
..W !,$E(GMRANAME,1,30) ; Patient Name
|
||||
..K GMRARAC
|
||||
..S GMRARAC=0,GMRACNT=1 F S GMRARAC=$O(^GMR(120.85,GMRAPA1,3,GMRARAC)) Q:GMRARAC<1 D
|
||||
...S GMRARAC(GMRACNT)=$P($G(^GMR(120.85,GMRAPA1,3,GMRARAC,0)),U) Q:GMRARAC(GMRACNT)=""
|
||||
...S GMRACNT=GMRACNT+1
|
||||
...Q
|
||||
..W ?32,"Obs DT: ",$$FMTE^XLFDT($P(GMRAPA1(0),U),"2D") ; Observed Date
|
||||
..W ?49,$E($G(GMRARAC(1)),1,30) ; The 1st reaction that is listed first
|
||||
..W !,"(",GMRAPID,")"
|
||||
..W ?32,"Trk DT: ",$$FMTE^XLFDT($P(GMRAPA1(0),U,18),"2D") ; Tracking Date
|
||||
..W ?49,$E($G(GMRARAC(2)),1,30) ; The 2nd reaction that is listed
|
||||
..W !,"Loc: ",GMRALOC
|
||||
..W ?32,"-------------" ; Seperator
|
||||
..W ?49,$E($G(GMRARAC(3)),1,30) ; The 3rd reaction that is listed
|
||||
..W !,"Obs: ",$P($G(^VA(200,$P(GMRAPA1(0),U,19),0)),U) ; User entered
|
||||
..D
|
||||
...N X1,X2,X,Y
|
||||
...S X2=$P(GMRAPA1(0),U),X1=$P(GMRAPA1(0),U,18)
|
||||
...D ^%DTC
|
||||
...W ?32,X," Days Difference" ;Difference
|
||||
...Q
|
||||
..W ?50,$E($G(GMRARAC(4)),1,30) ; The 4th reaction that is listed
|
||||
..S GMRACNT=4 F S GMRACNT=$O(GMRARAC(GMRACNT)) Q:GMRACNT<1 W !,?50,$E($G(GMRARAC(GMRACNT)),1,30) ; The Nth reaction that is listed
|
||||
..W ! ; Put a blank line between the ADRs
|
||||
..Q
|
||||
.Q
|
||||
D CLOSE^GMRAUTL
|
||||
Q
|
||||
HEAD ; Print header information
|
||||
I GMRAPG'=1 Q:$Y<(IOSL-4)
|
||||
I $E(IOST,1)="C" D Q:GMRAOUT
|
||||
.I GMRAPG=1 W @IOF Q
|
||||
.I GMRAPG'=1 D Q:GMRAOUT
|
||||
..N DIR S DIR(0)="E" D ^DIR I 'Y S GMRAOUT=1
|
||||
..K Y
|
||||
..Q
|
||||
.Q
|
||||
Q:GMRAOUT
|
||||
I GMRAPG'=1 W @IOF
|
||||
W "Report Date: ",$P($$FMTE^XLFDT(GMRADPDT),"@"),?70,"Page: ",GMRAPG
|
||||
W !,?22,"Adverse Reaction Tracking Report"
|
||||
W !,?25,"From: ",$$FMTE^XLFDT(GMAST,"2D")," To: ",$$FMTE^XLFDT(GMAEN,"2D")
|
||||
W !,"Patient",?40,"Dates",?49,"Related Reaction"
|
||||
W !,$$REPEAT^XLFSTR("-",78)
|
||||
S GMRAPG=GMRAPG+1
|
||||
I $D(ZTQUEUED) S:$$STPCK^GMRAUTL1 GMRAOUT=1 ; Check if stopped by user
|
||||
Q
|
||||
|
|
|
|||
|
|
@ -1,110 +1,109 @@
|
|||
GMRAPL ;HIRMFO/WAA- PRINT ALLERGY LIST BY LOCATION ;5/2/97 14:13
|
||||
;;4.0;Adverse Reaction Tracking;**7,33**;Mar 29, 1996;Build 5
|
||||
EN1 ; This routine will loop through the GMRA patient allergy file
|
||||
; to find all patient within the date range that meet the criteria
|
||||
; and then display all the data for those patients first by location
|
||||
; then by date/time range of the reaction.
|
||||
; First select a starting date.
|
||||
; then select an end date.
|
||||
; then select a print device.
|
||||
; GMAST = START DATE
|
||||
; GMAEN = END DATE
|
||||
;
|
||||
S GMRAOUT=0
|
||||
D DT G:GMRAOUT EXIT
|
||||
S GMAPG=1
|
||||
D DEVICE
|
||||
D EXIT
|
||||
Q
|
||||
GET ; This sub routine is to find all the reaction with in this observed
|
||||
; date range.
|
||||
K ^TMP($J,"GMRAPL")
|
||||
N GMADT S GMADT=GMAST-.0001
|
||||
F S GMADT=$O(^GMR(120.8,"AODT",GMADT)) Q:GMADT<1 Q:GMADT>GMAEN D
|
||||
.N GMRAPA S GMRAPA=0
|
||||
.F S GMRAPA=$O(^GMR(120.8,"AODT",GMADT,GMRAPA)) Q:GMRAPA<1 D
|
||||
..S GMRAPA(0)=$G(^GMR(120.8,GMRAPA,0))
|
||||
..; Stop if it is not Signed or if is E/E
|
||||
..Q:GMRAPA(0)="" ; Bad Zero node
|
||||
..Q:'$P(GMRAPA(0),U,12) ; Not signed off
|
||||
..Q:$P($G(^GMR(120.8,GMRAPA,"ER")),U) ; Entered in error
|
||||
..; Get patient name and location.
|
||||
..S GMRATYP=$P(GMRAPA(0),U,20) ; Get the reaction types FDO
|
||||
..S (GMRANAM,GMRALOC,GMRAVIP)=""
|
||||
..Q:'$$PRDTST^GMRAUTL1($P($G(GMRAPA(0)),U)) ;GMRA*4*33 Exclude test patient from report if production or legacy environment
|
||||
..D VAD^GMRAUTL1($P(GMRAPA(0),U),$P(GMRAPA(0),U,4),.GMRALOC,.GMRANAM,"","","","",.GMRAVIP)
|
||||
..I GMRALOC'="",+$G(^DIC(42,GMRALOC,44)) S GMRALOC=$P($G(^SC(+$G(^DIC(42,GMRALOC,44)),0)),U)
|
||||
..I GMRALOC="" S GMRALOC="Out Patients"
|
||||
..;Data format is as follows....
|
||||
..;^TMP($J,"GMRAPL",Ward location,Patient,PID,Reaction Type(FDO),Reaction)
|
||||
..S ^TMP($J,"GMRAPL",$E(GMRALOC,1,30),$E(GMRANAM,1,30),GMRAVIP,GMRATYP,GMRAPA)=""
|
||||
..Q
|
||||
.Q
|
||||
Q
|
||||
PRINT ; Print data in the reaction global
|
||||
I $E(IOST,1)="C" W !,"One moment please...",!
|
||||
D GET
|
||||
S GMRALOC="" F S GMRALOC=$O(^TMP($J,"GMRAPL",GMRALOC)) Q:GMRALOC="" D Q:GMRAOUT
|
||||
.D HEAD Q:GMRAOUT
|
||||
.S GMRANAM="" F S GMRANAM=$O(^TMP($J,"GMRAPL",GMRALOC,GMRANAM)) Q:GMRANAM="" D Q:GMRAOUT
|
||||
..S GMRAVIP="" F S GMRAVIP=$O(^TMP($J,"GMRAPL",GMRALOC,GMRANAM,GMRAVIP)) Q:GMRAVIP="" D Q:GMRAOUT
|
||||
...I $Y>(IOSL-4) D HEAD Q:GMRAOUT
|
||||
...W !,?10,"Patient: ",GMRANAM," (",GMRAVIP,")"
|
||||
...S GMRATYP="" F S GMRATYP=$O(^TMP($J,"GMRAPL",GMRALOC,GMRANAM,GMRAVIP,GMRATYP)) W:GMRATYP="" ! Q:GMRATYP="" D Q:GMRAOUT
|
||||
....S GMRAPA=0 F S GMRAPA=$O(^TMP($J,"GMRAPL",GMRALOC,GMRANAM,GMRAVIP,GMRATYP,GMRAPA)) Q:GMRAPA<1 D Q:GMRAOUT
|
||||
.....S GMRAPA(0)=$G(^GMR(120.8,GMRAPA,0)) Q:GMRAPA(0)=""
|
||||
.....W !,$$FMTE^XLFDT($P(GMRAPA(0),U,4),"1") ;When It was entered
|
||||
.....W ?20,$S($P(GMRAPA(0),U,5)'="":$E($P(^VA(200,$P(GMRAPA(0),U,5),0),U),1,25),1:"<None>") ;Who Entered it
|
||||
.....W ?46,GMRATYP ;Type of reaction
|
||||
.....W ?50,$E($P(GMRAPA(0),U,2),1,30) ;Reaction
|
||||
.....I $Y>(IOSL-4) D HEAD
|
||||
.....Q
|
||||
....Q
|
||||
...Q
|
||||
..Q
|
||||
.Q
|
||||
Q
|
||||
HEAD ; Header
|
||||
I $E(IOST,1)="C" D Q:GMRAOUT
|
||||
.I GMAPG=1 W @IOF Q
|
||||
.I GMAPG'=1 D Q:GMRAOUT
|
||||
..N DIR S DIR(0)="E" D ^DIR I 'Y S GMRAOUT=1
|
||||
..K Y
|
||||
..Q
|
||||
.Q
|
||||
I GMAPG'=1 W @IOF
|
||||
W $$FMTE^XLFDT(GMRAPDT,"1"),?70,"Page: ",GMAPG S GMAPG=GMAPG+1
|
||||
W !,?11,"List all Signed Patient Reactions for",$S(GMRALOC'="Out Patients":" Ward Location ",1:" "),GMRALOC
|
||||
W !,?15,"From ",$$FMTE^XLFDT(GMAST,"1")," to ",$$FMTE^XLFDT(GMAEN,"1")
|
||||
W !,"Date",?20,"Originator",?45,"Type",?50,"Causative Agent"
|
||||
W !,$$REPEAT^XLFSTR("-",79)
|
||||
Q
|
||||
DEVICE ; Select a device to print on
|
||||
D NOW^%DTC S GMRAPDT=X
|
||||
W ! K GMRAZIS D DEV^GMRAUTL I POP W !,"PLEASE TRY LATER" S GMRAOUT=1 Q
|
||||
I $D(IO("Q")) D Q
|
||||
. S ZTRTN="PRINT^GMRAPL",(ZTSAVE("GMAST"),ZTSAVE("GMAEN"),ZTSAVE("GMRAOUT"),ZTSAVE("GMRAPDT"),ZTSAVE("GMAPG"))=""
|
||||
. S ZTDESC="List of Reactions by Ward Location within a date range." D ^%ZTLOAD
|
||||
. W !!,$S($D(ZTSK):"Request queued...",1:"Request NOT queued please try Later.")
|
||||
. Q
|
||||
U IO D PRINT U IO(0)
|
||||
D CLOSE^GMRAUTL
|
||||
D EXIT
|
||||
Q
|
||||
DT ; Get dates
|
||||
S GMAST=$$DATE("Enter Start Date: ") I GMAST<1 S GMRAOUT=1 Q
|
||||
S GMAEN=$$DATE("Enter Ending Date: ",GMAST) I GMAEN<1 S GMRAOUT=1 Q
|
||||
S GMAEN=GMAEN_".24" ;Gives results through entire day when 'T' is selected
|
||||
Q
|
||||
DATE(PROMPT,GMADATE) ; Date sub routine
|
||||
S GMADATE=$G(GMADATE)
|
||||
S DATE=""
|
||||
N DIR
|
||||
S DIR(0)="DAO^"_GMADATE_"::AEP",DIR("A")=PROMPT
|
||||
D ^DIR I $D(DIRUT) S DATE="" Q DATE
|
||||
S DATE=Y
|
||||
Q DATE
|
||||
EXIT ;EXIT ROUTINE DATA
|
||||
K ^TMP($J,"GMRAPL")
|
||||
D KILL^XUSCLEAN
|
||||
Q
|
||||
GMRAPL ;HIRMFO/WAA- PRINT ALLERGY LIST BY LOCATION ;5/2/97 14:13
|
||||
;;4.0;Adverse Reaction Tracking;**7**;Mar 29, 1996
|
||||
EN1 ; This routine will loop thourgh the GMRA patient allergy file
|
||||
; to find all patient within the date range that meet the critera
|
||||
; and then display all the data for those patients first by location
|
||||
; then by date/time range of the reaction.
|
||||
; First select a starting date.
|
||||
; then select an end date.
|
||||
; then select a print device.
|
||||
; GMAST = START DATE
|
||||
; GMAEN = END DATE
|
||||
;
|
||||
S GMRAOUT=0
|
||||
D DT G:GMRAOUT EXIT
|
||||
S GMAPG=1
|
||||
D DEVICE
|
||||
D EXIT
|
||||
Q
|
||||
GET ; This sub routine is to find all the reaction with in this observed
|
||||
; date range.
|
||||
K ^TMP($J,"GMRAPL")
|
||||
N GMADT S GMADT=GMAST-.0001
|
||||
F S GMADT=$O(^GMR(120.8,"AODT",GMADT)) Q:GMADT<1 Q:GMADT>GMAEN D
|
||||
.N GMRAPA S GMRAPA=0
|
||||
.F S GMRAPA=$O(^GMR(120.8,"AODT",GMADT,GMRAPA)) Q:GMRAPA<1 D
|
||||
..S GMRAPA(0)=$G(^GMR(120.8,GMRAPA,0))
|
||||
..; Stop if it is not Signed or if is E/E
|
||||
..Q:GMRAPA(0)="" ; Bad Zero node
|
||||
..Q:'$P(GMRAPA(0),U,12) ; Not signed off
|
||||
..Q:$P($G(^GMR(120.8,GMRAPA,"ER")),U) ; Entered in error
|
||||
..; Get patient name and location.
|
||||
..S GMRATYP=$P(GMRAPA(0),U,20) ; Get the reaction types FDO
|
||||
..S (GMRANAM,GMRALOC,GMRAVIP)=""
|
||||
..D VAD^GMRAUTL1($P(GMRAPA(0),U),$P(GMRAPA(0),U,4),.GMRALOC,.GMRANAM,"","","","",.GMRAVIP)
|
||||
..I GMRALOC'="",+$G(^DIC(42,GMRALOC,44)) S GMRALOC=$P($G(^SC(+$G(^DIC(42,GMRALOC,44)),0)),U)
|
||||
..I GMRALOC="" S GMRALOC="Out Patients"
|
||||
..;Data format is as follows....
|
||||
..;^TMP($J,"GMRAPL",Ward location,Patient,PID,Reaction Type(FDO),Reaction)
|
||||
..S ^TMP($J,"GMRAPL",$E(GMRALOC,1,30),$E(GMRANAM,1,30),GMRAVIP,GMRATYP,GMRAPA)=""
|
||||
..Q
|
||||
.Q
|
||||
Q
|
||||
PRINT ; Print data in the reaction global
|
||||
I $E(IOST,1)="C" W !,"One moment please...",!
|
||||
D GET
|
||||
S GMRALOC="" F S GMRALOC=$O(^TMP($J,"GMRAPL",GMRALOC)) Q:GMRALOC="" D Q:GMRAOUT
|
||||
.D HEAD Q:GMRAOUT
|
||||
.S GMRANAM="" F S GMRANAM=$O(^TMP($J,"GMRAPL",GMRALOC,GMRANAM)) Q:GMRANAM="" D Q:GMRAOUT
|
||||
..S GMRAVIP="" F S GMRAVIP=$O(^TMP($J,"GMRAPL",GMRALOC,GMRANAM,GMRAVIP)) Q:GMRAVIP="" D Q:GMRAOUT
|
||||
...I $Y>(IOSL-4) D HEAD Q:GMRAOUT
|
||||
...W !,?10,"Patient: ",GMRANAM," (",GMRAVIP,")"
|
||||
...S GMRATYP="" F S GMRATYP=$O(^TMP($J,"GMRAPL",GMRALOC,GMRANAM,GMRAVIP,GMRATYP)) W:GMRATYP="" ! Q:GMRATYP="" D Q:GMRAOUT
|
||||
....S GMRAPA=0 F S GMRAPA=$O(^TMP($J,"GMRAPL",GMRALOC,GMRANAM,GMRAVIP,GMRATYP,GMRAPA)) Q:GMRAPA<1 D Q:GMRAOUT
|
||||
.....S GMRAPA(0)=$G(^GMR(120.8,GMRAPA,0)) Q:GMRAPA(0)=""
|
||||
.....W !,$$FMTE^XLFDT($P(GMRAPA(0),U,4),"1") ;When It was entered
|
||||
.....W ?20,$S($P(GMRAPA(0),U,5)'="":$E($P(^VA(200,$P(GMRAPA(0),U,5),0),U),1,25),1:"<None>") ;Who Entered it
|
||||
.....W ?46,GMRATYP ;Type of reaction
|
||||
.....W ?50,$E($P(GMRAPA(0),U,2),1,30) ;Reaction
|
||||
.....I $Y>(IOSL-4) D HEAD
|
||||
.....Q
|
||||
....Q
|
||||
...Q
|
||||
..Q
|
||||
.Q
|
||||
Q
|
||||
HEAD ; Header
|
||||
I $E(IOST,1)="C" D Q:GMRAOUT
|
||||
.I GMAPG=1 W @IOF Q
|
||||
.I GMAPG'=1 D Q:GMRAOUT
|
||||
..N DIR S DIR(0)="E" D ^DIR I 'Y S GMRAOUT=1
|
||||
..K Y
|
||||
..Q
|
||||
.Q
|
||||
I GMAPG'=1 W @IOF
|
||||
W $$FMTE^XLFDT(GMRAPDT,"1"),?70,"Page: ",GMAPG S GMAPG=GMAPG+1
|
||||
W !,?11,"List all Signed Patient Reactions for",$S(GMRALOC'="Out Patients":" Ward Location ",1:" "),GMRALOC
|
||||
W !,?15,"From ",$$FMTE^XLFDT(GMAST,"1")," to ",$$FMTE^XLFDT(GMAEN,"1")
|
||||
W !,"Date",?20,"Originator",?45,"Type",?50,"Causative Agent"
|
||||
W !,$$REPEAT^XLFSTR("-",79)
|
||||
Q
|
||||
DEVICE ; Select a device to print on
|
||||
D NOW^%DTC S GMRAPDT=X
|
||||
W ! K GMRAZIS D DEV^GMRAUTL I POP W !,"PLEASE TRY LATER" S GMRAOUT=1 Q
|
||||
I $D(IO("Q")) D Q
|
||||
. S ZTRTN="PRINT^GMRAPL",(ZTSAVE("GMAST"),ZTSAVE("GMAEN"),ZTSAVE("GMRAOUT"),ZTSAVE("GMRAPDT"),ZTSAVE("GMAPG"))=""
|
||||
. S ZTDESC="List of Reactions by Ward Location within a date range." D ^%ZTLOAD
|
||||
. W !!,$S($D(ZTSK):"Request queued...",1:"Request NOT queued please try Later.")
|
||||
. Q
|
||||
U IO D PRINT U IO(0)
|
||||
D CLOSE^GMRAUTL
|
||||
D EXIT
|
||||
Q
|
||||
DT ; Get dates
|
||||
S GMAST=$$DATE("Enter Start Date: ") I GMAST<1 S GMRAOUT=1 Q
|
||||
S GMAEN=$$DATE("Enter Ending Date: ",GMAST) I GMAEN<1 S GMRAOUT=1 Q
|
||||
S GMAEN=GMAEN_".24" ;Gives results through entire day when 'T' is selected
|
||||
Q
|
||||
DATE(PROMPT,GMADATE) ; Date sub routine
|
||||
S GMADATE=$G(GMADATE)
|
||||
S DATE=""
|
||||
N DIR
|
||||
S DIR(0)="DAO^"_GMADATE_"::AEP",DIR("A")=PROMPT
|
||||
D ^DIR I $D(DIRUT) S DATE="" Q DATE
|
||||
S DATE=Y
|
||||
Q DATE
|
||||
EXIT ;EXIT ROUTINE DATA
|
||||
K ^TMP($J,"GMRAPL")
|
||||
D KILL^XUSCLEAN
|
||||
Q
|
||||
|
|
|
|||
|
|
@ -1,86 +1,85 @@
|
|||
GMRAPNA ;HIRMFO/WAA-PATIENT NOT ASKED ABOUT ALLERGIES ;12/1/95 14:15
|
||||
;;4.0;Adverse Reaction Tracking;**30,33**;Mar 29, 1996;Build 5
|
||||
EN1 ; Entry for LIST BY LOCATION OF UNDOCUMENTED ALLERGIES option
|
||||
D EN1^GMRACMR G:GMRAOUT EXIT
|
||||
D DEV
|
||||
D EXIT
|
||||
Q
|
||||
DEV ; *** Select output device, force queuing
|
||||
;***** NOTE: CHECKS TO SEE IF VALID DEVICE IS SELECTED THEN ALL I HAVE TO DO IS RUN TASK MAN.
|
||||
S GMRAZIS="" S:GMRASEL'="1," GMRAZIS="Q"
|
||||
W !! D DEV^GMRAUTL I POP G EXIT
|
||||
I $D(IO("Q")) D G EXIT
|
||||
. K IO("Q")
|
||||
. S ZTRTN="ENTSK^GMRAPNA"
|
||||
. S ZTSAVE("GMRA*")="",ZTSAVE("^TMP($J,")=""
|
||||
. S ZTDESC="List of patients who have not been asked of allergies"
|
||||
. D ^%ZTLOAD
|
||||
. W !!,$S($D(ZTSK):"Request queued...",1:"Request NOT queued please try later...")
|
||||
. Q
|
||||
E D ENTSK
|
||||
Q
|
||||
ENTSK U IO
|
||||
D EN1^GMRACMR2,EN1^GMRACMR3
|
||||
S GMRAPAGE=0,X="NOW" D ^%DT S GMRAPDT=$$DATE^GMRAUTL1(Y)
|
||||
D PRINT
|
||||
G EXIT
|
||||
PRINT ;PRINT THE DATE
|
||||
D PRE
|
||||
S GMRAHLOC="" F S GMRAHLOC=$O(^TMP($J,"GMRAWC","C",GMRAHLOC)) Q:GMRAHLOC=""!(GMRAOUT) S GMRAX=0 F S GMRAX=$O(^(GMRAHLOC,GMRAX)) Q:GMRAX<1 D Q:GMRAOUT
|
||||
.S GMRA=$G(^TMP($J,"GMRAWC",GMRAX)),GMRACNT=0
|
||||
.I GMRA="" Q
|
||||
.D HEAD Q:GMRAOUT
|
||||
.W !!,?10,$S(GMRA="W":"WARD",GMRA="M":"MODULE",GMRA="C":"CLINIC",1:"UNKNOWN"),": ",$P(^SC(GMRAX,0),U)
|
||||
.S GMRADATE=0 F S GMRADATE=$O(^TMP($J,"GMRAWC",GMRAX,GMRADATE)) Q:GMRADATE="" S GMRADFN=0 Q:GMRAOUT F S GMRADFN=$O(^TMP($J,"GMRAWC",GMRAX,GMRADATE,GMRADFN)) Q:GMRADFN<1 D Q:GMRAOUT
|
||||
..I '$D(^GMR(120.86,GMRADFN,0))
|
||||
..E I +$P(^GMR(120.86,GMRADFN,0),U,4)<$G(GMRAED,9999999) Q
|
||||
..Q:'$D(^DPT(GMRADFN,0))
|
||||
..Q:$$DECEASED^GMRAFX(GMRADFN) ;GMRA*4*30 Prevent deceased patients from appearing on this report.
|
||||
..Q:'$$PRDTST^GMRAUTL1(GMRADFN) ;GMRA*4*33 Exclude test patient from report if production or legacy environment.
|
||||
..S GMRACNT=GMRACNT+1
|
||||
..W !,$P(^DPT(GMRADFN,0),U) S DFN=GMRADFN,VAINDT=$S(GMRADATE="CURRENT":DT,1:GMRADATE) D 1^VADPT W ?30,VA("PID") W:GMRA'="C" ?45,$P(VAIN(2),U,2)
|
||||
..I VAIN(5)'="" W !,?5,"Room/Bed: ",VAIN(5)
|
||||
..D KVAR^VADPT K VA,DFN
|
||||
..I $Y>(IOSL-4) D HEAD Q:GMRAOUT
|
||||
..Q
|
||||
.D NOPAT
|
||||
.Q
|
||||
D CLOSE^GMRAUTL
|
||||
Q
|
||||
NOPAT ; If there are no patients print informational message
|
||||
Q:GMRACNT
|
||||
W !,?24,"* No Patients for this ",$S(GMRA="W":"Ward",GMRA="M":"Module",GMRA="C":"Clinic",1:"UNKNOWN")," *"
|
||||
W !
|
||||
Q
|
||||
HEAD ;HEADER PAGE FOR PRINTOUT
|
||||
S GMRAPAGE=GMRAPAGE+1,GMRATL="" I $E(IOST,1)="C",GMRAPAGE=1 W @IOF
|
||||
I $E(IOST,1)="C",GMRAPAGE'=1 D Q:GMRAOUT
|
||||
.S DIR(0)="E" D ^DIR I 'Y S GMRAOUT=1
|
||||
.K Y
|
||||
.Q
|
||||
I GMRAPAGE'=1 W @IOF
|
||||
W !,GMRAPDT,?23,"PATIENTS NOT ASKED ABOUT ALLERGIES",?70,"PAGE ",GMRAPAGE
|
||||
I GMRASEL["1" S GMRATL="CURRENT INPATIENTS"
|
||||
I GMRASEL["2" S GMRATL=$S(GMRATL="":"OUTPATIENTS",1:GMRATL_" / OUTPATIENTS")
|
||||
I GMRASEL["3" S GMRATL=$S(GMRATL="":"NEW ADMISSIONS",1:GMRATL_" / NEW ADMISSIONS")
|
||||
W !,?(40-($L(GMRATL)/2)),GMRATL
|
||||
I (GMRASEL["2"!(GMRASEL["3")) W !,?23,"FROM ",$$DATE^GMRAUTL1(GMRAST),?42,"TO ",$$DATE^GMRAUTL1(GMRAED)
|
||||
W !!,"PATIENT",?30,"SSN" W:GMRA'="C" ?45,"PROVIDER"
|
||||
W !,$$REPEAT^XLFSTR("-",78)
|
||||
I $D(ZTQUEUED) S:$$STPCK^GMRAUTL1 GMRAOUT=1 ; Check if stopped by user
|
||||
Q
|
||||
PRE ; This will validate the TMP global and fire off Xref
|
||||
N GMRAX,GMRAY,GMRAT1,GMRAT2,GMRAT3
|
||||
Q:'$D(^TMP($J,"GMRAWC"))
|
||||
S GMRAX=0 F S GMRAX=$O(^TMP($J,"GMRAWC",GMRAX)) Q:GMRAX<1 D
|
||||
.S GMRAY=^TMP($J,"GMRAWC",GMRAX)
|
||||
.S GMRAT1=$P($G(^SC(GMRAX,0)),U,2)
|
||||
.S GMRAT2=$P($G(^SC(GMRAX,0)),U)
|
||||
.S GMRAT3=$S(GMRAT1'="":GMRAT1,1:GMRAT2)
|
||||
.S ^TMP($J,"GMRAWC","C",GMRAT3,GMRAX)=""
|
||||
.Q
|
||||
Q
|
||||
EXIT ;
|
||||
K ^TMP($J,"GMRAWC")
|
||||
D KILL^XUSCLEAN
|
||||
Q
|
||||
GMRAPNA ;HIRMFO/WAA-PATIENT NOT ASKED ABOUT ALLERGIES ;12/1/95 14:15
|
||||
;;4.0;Adverse Reaction Tracking;**30**;Mar 29, 1996
|
||||
EN1 ; Entry for LIST BY LOCATION OF UNDOCUMENTED ALLERGIES option
|
||||
D EN1^GMRACMR G:GMRAOUT EXIT
|
||||
D DEV
|
||||
D EXIT
|
||||
Q
|
||||
DEV ; *** Select output device, force queueing
|
||||
;***** NOTE: CHECKS TO SEE IF VALID DEVICE IS SELECTED THEN ALL I HAVE TO DO IS RUN TASK MAN.
|
||||
S GMRAZIS="" S:GMRASEL'="1," GMRAZIS="Q"
|
||||
W !! D DEV^GMRAUTL I POP G EXIT
|
||||
I $D(IO("Q")) D G EXIT
|
||||
. K IO("Q")
|
||||
. S ZTRTN="ENTSK^GMRAPNA"
|
||||
. S ZTSAVE("GMRA*")="",ZTSAVE("^TMP($J,")=""
|
||||
. S ZTDESC="List of patients who have not been asked of allergies"
|
||||
. D ^%ZTLOAD
|
||||
. W !!,$S($D(ZTSK):"Request queued...",1:"Request NOT queued please try later...")
|
||||
. Q
|
||||
E D ENTSK
|
||||
Q
|
||||
ENTSK U IO
|
||||
D EN1^GMRACMR2,EN1^GMRACMR3
|
||||
S GMRAPAGE=0,X="NOW" D ^%DT S GMRAPDT=$$DATE^GMRAUTL1(Y)
|
||||
D PRINT
|
||||
G EXIT
|
||||
PRINT ;PRINT THE DATE
|
||||
D PRE
|
||||
S GMRAHLOC="" F S GMRAHLOC=$O(^TMP($J,"GMRAWC","C",GMRAHLOC)) Q:GMRAHLOC=""!(GMRAOUT) S GMRAX=0 F S GMRAX=$O(^(GMRAHLOC,GMRAX)) Q:GMRAX<1 D Q:GMRAOUT
|
||||
.S GMRA=$G(^TMP($J,"GMRAWC",GMRAX)),GMRACNT=0
|
||||
.I GMRA="" Q
|
||||
.D HEAD Q:GMRAOUT
|
||||
.W !!,?10,$S(GMRA="W":"WARD",GMRA="M":"MODULE",GMRA="C":"CLINIC",1:"UNKNOWN"),": ",$P(^SC(GMRAX,0),U)
|
||||
.S GMRADATE=0 F S GMRADATE=$O(^TMP($J,"GMRAWC",GMRAX,GMRADATE)) Q:GMRADATE="" S GMRADFN=0 Q:GMRAOUT F S GMRADFN=$O(^TMP($J,"GMRAWC",GMRAX,GMRADATE,GMRADFN)) Q:GMRADFN<1 D Q:GMRAOUT
|
||||
..I '$D(^GMR(120.86,GMRADFN,0))
|
||||
..E I +$P(^GMR(120.86,GMRADFN,0),U,4)<$G(GMRAED,9999999) Q
|
||||
..Q:'$D(^DPT(GMRADFN,0))
|
||||
..Q:$$DECEASED^GMRAFX(GMRADFN) ;GMRA*4*30 Prevent deceased patients from appearing on this report.
|
||||
..S GMRACNT=GMRACNT+1
|
||||
..W !,$P(^DPT(GMRADFN,0),U) S DFN=GMRADFN,VAINDT=$S(GMRADATE="CURRENT":DT,1:GMRADATE) D 1^VADPT W ?30,VA("PID") W:GMRA'="C" ?45,$P(VAIN(2),U,2)
|
||||
..I VAIN(5)'="" W !,?5,"Room/Bed: ",VAIN(5)
|
||||
..D KVAR^VADPT K VA,DFN
|
||||
..I $Y>(IOSL-4) D HEAD Q:GMRAOUT
|
||||
..Q
|
||||
.D NOPAT
|
||||
.Q
|
||||
D CLOSE^GMRAUTL
|
||||
Q
|
||||
NOPAT ; If there are no patients print informational message
|
||||
Q:GMRACNT
|
||||
W !,?24,"* No Patients for this ",$S(GMRA="W":"Ward",GMRA="M":"Module",GMRA="C":"Clinic",1:"UNKNOWN")," *"
|
||||
W !
|
||||
Q
|
||||
HEAD ;HEADER PAGE FOR PRINTOUT
|
||||
S GMRAPAGE=GMRAPAGE+1,GMRATL="" I $E(IOST,1)="C",GMRAPAGE=1 W @IOF
|
||||
I $E(IOST,1)="C",GMRAPAGE'=1 D Q:GMRAOUT
|
||||
.S DIR(0)="E" D ^DIR I 'Y S GMRAOUT=1
|
||||
.K Y
|
||||
.Q
|
||||
I GMRAPAGE'=1 W @IOF
|
||||
W !,GMRAPDT,?23,"PATIENTS NOT ASKED ABOUT ALLERGIES",?70,"PAGE ",GMRAPAGE
|
||||
I GMRASEL["1" S GMRATL="CURRENT INPATIENTS"
|
||||
I GMRASEL["2" S GMRATL=$S(GMRATL="":"OUTPATIENTS",1:GMRATL_" / OUTPATIENTS")
|
||||
I GMRASEL["3" S GMRATL=$S(GMRATL="":"NEW ADMISSIONS",1:GMRATL_" / NEW ADMISSIONS")
|
||||
W !,?(40-($L(GMRATL)/2)),GMRATL
|
||||
I (GMRASEL["2"!(GMRASEL["3")) W !,?23,"FROM ",$$DATE^GMRAUTL1(GMRAST),?42,"TO ",$$DATE^GMRAUTL1(GMRAED)
|
||||
W !!,"PATIENT",?30,"SSN" W:GMRA'="C" ?45,"PROVIDER"
|
||||
W !,$$REPEAT^XLFSTR("-",78)
|
||||
I $D(ZTQUEUED) S:$$STPCK^GMRAUTL1 GMRAOUT=1 ; Check if stopped by user
|
||||
Q
|
||||
PRE ; This will validate the TMP global and fire off Xref
|
||||
N GMRAX,GMRAY,GMRAT1,GMRAT2,GMRAT3
|
||||
Q:'$D(^TMP($J,"GMRAWC"))
|
||||
S GMRAX=0 F S GMRAX=$O(^TMP($J,"GMRAWC",GMRAX)) Q:GMRAX<1 D
|
||||
.S GMRAY=^TMP($J,"GMRAWC",GMRAX)
|
||||
.S GMRAT1=$P($G(^SC(GMRAX,0)),U,2)
|
||||
.S GMRAT2=$P($G(^SC(GMRAX,0)),U)
|
||||
.S GMRAT3=$S(GMRAT1'="":GMRAT1,1:GMRAT2)
|
||||
.S ^TMP($J,"GMRAWC","C",GMRAT3,GMRAX)=""
|
||||
.Q
|
||||
Q
|
||||
EXIT ;
|
||||
K ^TMP($J,"GMRAWC")
|
||||
D KILL^XUSCLEAN
|
||||
Q
|
||||
|
|
|
|||
|
|
@ -1,89 +1,88 @@
|
|||
GMRAPST1 ;HIRMFO/WAA- PRINT LISTING OF FATAL REACTIONS ;3/5/97 14:45
|
||||
;;4.0;Adverse Reaction Tracking;**7,33**;Mar 29, 1996;Build 5
|
||||
EN1 ; This routine will loop through the ADT entry point to get all
|
||||
; the entries where the patient has died.
|
||||
S GMRAOUT=0
|
||||
W !,"Select an Observed date range for this report."
|
||||
D DT^GMRAPL G:GMRAOUT EXIT
|
||||
D PRINTER
|
||||
EXIT ; Exit of program kill cleanup
|
||||
D KILL^XUSCLEAN
|
||||
K ^TMP($J,"GMRAPST1")
|
||||
Q
|
||||
PRINTER ;Select printer
|
||||
W ! K GMRAZIS D DEV^GMRAUTL I POP W !,"PLEASE TRY LATER" S GMRAOUT=1 Q
|
||||
I $D(IO("Q")) D Q
|
||||
. S ZTRTN="PRINT^GMRAPST1",(ZTSAVE("GMRAOUT"),ZTSAVE("GMAST"),ZTSAVE("GMAEN"))=""
|
||||
. S ZTDESC="List of Fatal Reaction over a date range" D ^%ZTLOAD
|
||||
. W !!,$S($D(ZTSK):"Request queued...",1:"Request NOT queued please try Later.")
|
||||
. Q
|
||||
U IO D PRINT U IO(0)
|
||||
Q
|
||||
PRINT ;Queue point for report
|
||||
;Loop through the 120.85 file.
|
||||
K ^TMP($J,"GMRAPST1")
|
||||
D NOW^%DTC S GMRADPDT=X
|
||||
S GMRADATE=GMAST-.0001,GMRAPG=1
|
||||
F S GMRADATE=$O(^GMR(120.85,"B",GMRADATE)) Q:GMRADATE<1 Q:GMRADATE>GMAEN D
|
||||
.S GMRAPA1=0 F S GMRAPA1=$O(^GMR(120.85,"B",GMRADATE,GMRAPA1)) Q:GMRAPA1<1 D
|
||||
..S GMRAPA1(0)=$G(^GMR(120.85,GMRAPA1,0)) Q:GMRAPA1(0)="" ;Bad Node
|
||||
..Q:+$G(^GMR(120.8,$P(GMRAPA1(0),U,15),"ER")) ;data entered in error
|
||||
..Q:$P(GMRAPA1(0),U,3)'="y" ; If patient did not die of the reaction
|
||||
..S GMRADFN=$P(GMRAPA1(0),U,2),GMRADDT=$P(GMRAPA1(0),U) ; reaction date
|
||||
..Q:'$$PRDTST^GMRAUTL1(GMRADFN) ;GMRA*4*33 Exclude test patient from report in production or legacy environments.
|
||||
..S (GMRAPID,GMRANAME)=""
|
||||
..D VAD^GMRAUTL1(GMRADFN,GMRADDT,"",.GMRANAME,"",.GMRAPID)
|
||||
..S GMRADIED=$P($G(^DPT(GMRADFN,.35)),U) ; Date patient died
|
||||
..S ^TMP($J,"GMRAPST1",$E(GMRANAME,1,30),GMRAPID,GMRADDT,GMRAPA1)=GMRADIED
|
||||
..Q
|
||||
.Q
|
||||
Q:GMRAOUT
|
||||
I '$D(^TMP($J,"GMRAPST1")) D HEAD W !,"NO DATA FOR THIS REPORT..." Q
|
||||
S GMRANAME=""
|
||||
F S GMRANAME=$O(^TMP($J,"GMRAPST1",GMRANAME)) Q:GMRANAME="" D Q:GMRAOUT
|
||||
.S GMRAPID=""
|
||||
.F S GMRAPID=$O(^TMP($J,"GMRAPST1",GMRANAME,GMRAPID)) Q:GMRAPID="" D Q:GMRAOUT
|
||||
..D HEAD Q:GMRAOUT
|
||||
..W !,$E(GMRANAME,1,22)," (",$E(GMRANAME,1),$P(GMRAPID,"-",3),")"
|
||||
..S GMRADDT=0
|
||||
..F S GMRADDT=$O(^TMP($J,"GMRAPST1",GMRANAME,GMRAPID,GMRADDT)) Q:GMRADDT<1 D Q:GMRAOUT
|
||||
...S GMRAPA1=0
|
||||
...F S GMRAPA1=$O(^TMP($J,"GMRAPST1",GMRANAME,GMRAPID,GMRADDT,GMRAPA1)) Q:GMRAPA1<1 D Q:GMRAOUT W !
|
||||
....S GMRADIED=^TMP($J,"GMRAPST1",GMRANAME,GMRAPID,GMRADDT,GMRAPA1)
|
||||
....W ?31,$$FMTE^XLFDT($P(^GMR(120.85,GMRAPA1,0),U),"2D")
|
||||
....S GMRAX="",GMRACNT=1 K GMRARX
|
||||
....F S GMRAX=$O(^GMR(120.85,GMRAPA1,3,"B",GMRAX)) Q:GMRAX="" D
|
||||
.....S GMRARX(GMRACNT)=GMRAX,GMRACNT=GMRACNT+1
|
||||
.....Q
|
||||
....W ?40,GMRARX(1),?70,$$FMTE^XLFDT(GMRADIED,"2D")
|
||||
....D HEAD Q:GMRAOUT
|
||||
....S GMRACNT=1 F S GMRACNT=$O(GMRARX(GMRACNT)) Q:GMRACNT<1 D Q:GMRAOUT
|
||||
.....W !,?40,GMRARX(GMRACNT) D HEAD Q:GMRAOUT
|
||||
.....Q
|
||||
....Q
|
||||
...Q
|
||||
..W ! D HEAD Q:GMRAOUT
|
||||
..Q
|
||||
.Q
|
||||
D CLOSE^GMRAUTL
|
||||
Q
|
||||
;has the patient died within the date
|
||||
HEAD ; Print header information
|
||||
I GMRAPG'=1 Q:$Y<(IOSL-4)
|
||||
I $E(IOST,1)="C" D Q:GMRAOUT
|
||||
.I GMRAPG=1 W @IOF Q
|
||||
.I GMRAPG'=1 D Q:GMRAOUT
|
||||
..N DIR S DIR(0)="E" D ^DIR I 'Y S GMRAOUT=1
|
||||
..K Y
|
||||
..Q
|
||||
.Q
|
||||
Q:GMRAOUT
|
||||
I GMRAPG'=1 W @IOF
|
||||
W "Report Date: ",$P($$FMTE^XLFDT(GMRADPDT),"@"),?70,"Page: ",GMRAPG
|
||||
W !,?22,"List of Fatal Reaction over a date range"
|
||||
W !,?25,"From: ",$$FMTE^XLFDT(GMAST,"2D")," To: ",$$FMTE^XLFDT(GMAEN,"2D")
|
||||
W !,"Patient",?31,"Dates",?40,"Related Reaction",?70,"Date Died"
|
||||
W !,$$REPEAT^XLFSTR("-",79)
|
||||
S GMRAPG=GMRAPG+1
|
||||
I $D(ZTQUEUED) S:$$STPCK^GMRAUTL1 GMRAOUT=1 ; Check if stopped by user
|
||||
Q
|
||||
GMRAPST1 ;HIRMFO/WAA- PRINT LISTING OF FATAL REACTIONS ;3/5/97 14:45
|
||||
;;4.0;Adverse Reaction Tracking;**7**;Mar 29, 1996
|
||||
EN1 ; This routine will loop through the ADT entry point to get all
|
||||
; the entries where the patient has died.
|
||||
S GMRAOUT=0
|
||||
W !,"Select an Observed date range for this report."
|
||||
D DT^GMRAPL G:GMRAOUT EXIT
|
||||
D PRINTER
|
||||
EXIT ; Exit of program kill cleanup
|
||||
D KILL^XUSCLEAN
|
||||
K ^TMP($J,"GMRAPST1")
|
||||
Q
|
||||
PRINTER ;Select printer
|
||||
W ! K GMRAZIS D DEV^GMRAUTL I POP W !,"PLEASE TRY LATER" S GMRAOUT=1 Q
|
||||
I $D(IO("Q")) D Q
|
||||
. S ZTRTN="PRINT^GMRAPST1",(ZTSAVE("GMRAOUT"),ZTSAVE("GMAST"),ZTSAVE("GMAEN"))=""
|
||||
. S ZTDESC="List of Fatal Reaction over a date range" D ^%ZTLOAD
|
||||
. W !!,$S($D(ZTSK):"Request queued...",1:"Request NOT queued please try Later.")
|
||||
. Q
|
||||
U IO D PRINT U IO(0)
|
||||
Q
|
||||
PRINT ;Queue point for report
|
||||
;Loop through the 120.85 file.
|
||||
K ^TMP($J,"GMRAPST1")
|
||||
D NOW^%DTC S GMRADPDT=X
|
||||
S GMRADATE=GMAST-.0001,GMRAPG=1
|
||||
F S GMRADATE=$O(^GMR(120.85,"B",GMRADATE)) Q:GMRADATE<1 Q:GMRADATE>GMAEN D
|
||||
.S GMRAPA1=0 F S GMRAPA1=$O(^GMR(120.85,"B",GMRADATE,GMRAPA1)) Q:GMRAPA1<1 D
|
||||
..S GMRAPA1(0)=$G(^GMR(120.85,GMRAPA1,0)) Q:GMRAPA1(0)="" ;Bad Node
|
||||
..Q:+$G(^GMR(120.8,$P(GMRAPA1(0),U,15),"ER")) ;data entered in error
|
||||
..Q:$P(GMRAPA1(0),U,3)'="y" ; If patient did not die of the reaction
|
||||
..S GMRADFN=$P(GMRAPA1(0),U,2),GMRADDT=$P(GMRAPA1(0),U) ; reaction date
|
||||
..S (GMRAPID,GMRANAME)=""
|
||||
..D VAD^GMRAUTL1(GMRADFN,GMRADDT,"",.GMRANAME,"",.GMRAPID)
|
||||
..S GMRADIED=$P($G(^DPT(GMRADFN,.35)),U) ; Date patient died
|
||||
..S ^TMP($J,"GMRAPST1",$E(GMRANAME,1,30),GMRAPID,GMRADDT,GMRAPA1)=GMRADIED
|
||||
..Q
|
||||
.Q
|
||||
Q:GMRAOUT
|
||||
I '$D(^TMP($J,"GMRAPST1")) D HEAD W !,"NO DATA FOR THIS REPORT..." Q
|
||||
S GMRANAME=""
|
||||
F S GMRANAME=$O(^TMP($J,"GMRAPST1",GMRANAME)) Q:GMRANAME="" D Q:GMRAOUT
|
||||
.S GMRAPID=""
|
||||
.F S GMRAPID=$O(^TMP($J,"GMRAPST1",GMRANAME,GMRAPID)) Q:GMRAPID="" D Q:GMRAOUT
|
||||
..D HEAD Q:GMRAOUT
|
||||
..W !,$E(GMRANAME,1,22)," (",$E(GMRANAME,1),$P(GMRAPID,"-",3),")"
|
||||
..S GMRADDT=0
|
||||
..F S GMRADDT=$O(^TMP($J,"GMRAPST1",GMRANAME,GMRAPID,GMRADDT)) Q:GMRADDT<1 D Q:GMRAOUT
|
||||
...S GMRAPA1=0
|
||||
...F S GMRAPA1=$O(^TMP($J,"GMRAPST1",GMRANAME,GMRAPID,GMRADDT,GMRAPA1)) Q:GMRAPA1<1 D Q:GMRAOUT W !
|
||||
....S GMRADIED=^TMP($J,"GMRAPST1",GMRANAME,GMRAPID,GMRADDT,GMRAPA1)
|
||||
....W ?31,$$FMTE^XLFDT($P(^GMR(120.85,GMRAPA1,0),U),"2D")
|
||||
....S GMRAX="",GMRACNT=1 K GMRARX
|
||||
....F S GMRAX=$O(^GMR(120.85,GMRAPA1,3,"B",GMRAX)) Q:GMRAX="" D
|
||||
.....S GMRARX(GMRACNT)=GMRAX,GMRACNT=GMRACNT+1
|
||||
.....Q
|
||||
....W ?40,GMRARX(1),?70,$$FMTE^XLFDT(GMRADIED,"2D")
|
||||
....D HEAD Q:GMRAOUT
|
||||
....S GMRACNT=1 F S GMRACNT=$O(GMRARX(GMRACNT)) Q:GMRACNT<1 D Q:GMRAOUT
|
||||
.....W !,?40,GMRARX(GMRACNT) D HEAD Q:GMRAOUT
|
||||
.....Q
|
||||
....Q
|
||||
...Q
|
||||
..W ! D HEAD Q:GMRAOUT
|
||||
..Q
|
||||
.Q
|
||||
D CLOSE^GMRAUTL
|
||||
Q
|
||||
;has the patient died with inthe dat
|
||||
HEAD ; Print header information
|
||||
I GMRAPG'=1 Q:$Y<(IOSL-4)
|
||||
I $E(IOST,1)="C" D Q:GMRAOUT
|
||||
.I GMRAPG=1 W @IOF Q
|
||||
.I GMRAPG'=1 D Q:GMRAOUT
|
||||
..N DIR S DIR(0)="E" D ^DIR I 'Y S GMRAOUT=1
|
||||
..K Y
|
||||
..Q
|
||||
.Q
|
||||
Q:GMRAOUT
|
||||
I GMRAPG'=1 W @IOF
|
||||
W "Report Date: ",$P($$FMTE^XLFDT(GMRADPDT),"@"),?70,"Page: ",GMRAPG
|
||||
W !,?22,"List of Fatal Reaction over a date range"
|
||||
W !,?25,"From: ",$$FMTE^XLFDT(GMAST,"2D")," To: ",$$FMTE^XLFDT(GMAEN,"2D")
|
||||
W !,"Patient",?31,"Dates",?40,"Related Reaction",?70,"Date Died"
|
||||
W !,$$REPEAT^XLFSTR("-",79)
|
||||
S GMRAPG=GMRAPG+1
|
||||
I $D(ZTQUEUED) S:$$STPCK^GMRAUTL1 GMRAOUT=1 ; Check if stopped by user
|
||||
Q
|
||||
|
|
|
|||
|
|
@ -1,91 +1,90 @@
|
|||
GMRAPST2 ;HIRMFO/WAA- PRINT SUM LISTING OF OUT COMES ;3/5/97 14:50
|
||||
;;4.0;Adverse Reaction Tracking;**7,33**;Mar 29, 1996;Build 5
|
||||
EN1 ; This routine will loop through the ADT entry point to get all
|
||||
; the entries in that date range.
|
||||
S GMRAOUT=0
|
||||
W !,"Select an Observed date range for this report."
|
||||
D DT^GMRAPL G:GMRAOUT EXIT
|
||||
D PRINTER
|
||||
EXIT ; Exit of program kill cleanup
|
||||
D KILL^XUSCLEAN
|
||||
Q
|
||||
PRINTER ;Select printer
|
||||
W ! K GMRAZIS D DEV^GMRAUTL I POP W !,"PLEASE TRY LATER" S GMRAOUT=1 Q
|
||||
I $D(IO("Q")) D Q
|
||||
. S ZTRTN="PRINT^GMRAPST2",(ZTSAVE("GMRAOUT"),ZTSAVE("GMAST"),ZTSAVE("GMAEN"))=""
|
||||
. S ZTDESC="Summary of Outcomes" D ^%ZTLOAD
|
||||
. W !!,$S($D(ZTSK):"Request queued...",1:"Request NOT queued please try Later.")
|
||||
. Q
|
||||
U IO D PRINT U IO(0)
|
||||
Q
|
||||
PRINT ;Queue point for report
|
||||
;loop through the 120.85 file and look for the field that
|
||||
D NOW^%DTC S GMRADPDT=X
|
||||
S GMRADATE=GMAST-.0001,GMRAPG=1
|
||||
S (GMRARRAY("YES"),GMRARRAY("NO"),GMRARRAY("NULL"))="",GMRATOT=0
|
||||
F S GMRADATE=$O(^GMR(120.85,"B",GMRADATE)) Q:GMRADATE<1 Q:GMRADATE>GMAEN D
|
||||
.S GMRAPA1=0 F S GMRAPA1=$O(^GMR(120.85,"B",GMRADATE,GMRAPA1)) Q:GMRAPA1<1 D
|
||||
..S GMRAPA1(0)=$G(^GMR(120.85,GMRAPA1,0)) Q:GMRAPA1(0)="" ;Bad Node
|
||||
..Q:+$G(^GMR(120.8,$P(GMRAPA1(0),U,15),"ER")) ;Entered in Error data
|
||||
..Q:'$$PRDTST^GMRAUTL1($P(GMRAPA1(0),U,2)) ;GMRA*4*33 Exclude test patient from report if production or legacy environment.
|
||||
..S GMRATOT=GMRATOT+1
|
||||
..F GMRALAB=1:1 S GMRALINE=$T(TEXT+GMRALAB) Q:$P(GMRALINE,";",3)="" D
|
||||
...S GMRAP=$P(GMRALINE,";",4)
|
||||
...I $P(GMRAPA1(0),U,GMRAP)="y" S $P(GMRARRAY("YES"),U,GMRAP)=$P(GMRARRAY("YES"),U,GMRAP)+1
|
||||
...I $P(GMRAPA1(0),U,GMRAP)="n" S $P(GMRARRAY("NO"),U,GMRAP)=$P(GMRARRAY("NO"),U,GMRAP)+1
|
||||
...I $P(GMRAPA1(0),U,GMRAP)="" S $P(GMRARRAY("NULL"),U,GMRAP)=$P(GMRARRAY("NULL"),U,GMRAP)+1
|
||||
...Q
|
||||
..Q
|
||||
.Q
|
||||
Q:GMRAOUT
|
||||
D HEAD
|
||||
S (GMRAY,GMRAN,GMRANU)=0
|
||||
F GMRALAB=1:1 S GMRALINE=$T(TEXT+GMRALAB) Q:$P(GMRALINE,";",3)="" D
|
||||
.N GMRAP,GMRATAB
|
||||
.S GMRAP=$P(GMRALINE,";",4)
|
||||
.S GMRATAB=40-$L($P(GMRALINE,";",3))
|
||||
.W !,?GMRATAB,$P(GMRALINE,";",3)
|
||||
.W ?42,$P(GMRARRAY("YES"),U,GMRAP)
|
||||
.S GMRAY=GMRAY+$P(GMRARRAY("YES"),U,GMRAP)
|
||||
.W ?53,"| ",$P(GMRARRAY("NO"),U,GMRAP)
|
||||
.S GMRAN=GMRAN+$P(GMRARRAY("NO"),U,GMRAP)
|
||||
.W ?63,"| ",$P(GMRARRAY("NULL"),U,GMRAP)
|
||||
.S GMRANU=GMRANU+$P(GMRARRAY("NULL"),U,GMRAP)
|
||||
.Q
|
||||
W !,?30," ---------------------------------------"
|
||||
W !,?32,"Totals: ",?42,GMRAY,?53,"| ",GMRAN,?63,"| ",GMRANU
|
||||
W !!,?22,"Total number of records processed ",GMRATOT
|
||||
D CLOSE^GMRAUTL
|
||||
Q
|
||||
;has the patient died within the date
|
||||
HEAD ; Print header information
|
||||
I GMRAPG'=1 Q:$Y<(IOSL-4)
|
||||
I $E(IOST,1)="C" D Q:GMRAOUT
|
||||
.I GMRAPG=1 W @IOF Q
|
||||
.I GMRAPG'=1 D Q:GMRAOUT
|
||||
..N DIR S DIR(0)="E" D ^DIR I 'Y S GMRAOUT=1
|
||||
..K Y
|
||||
..Q
|
||||
.Q
|
||||
Q:GMRAOUT
|
||||
I GMRAPG'=1 W @IOF
|
||||
W "Report Date: ",$P($$FMTE^XLFDT(GMRADPDT),"@"),?70,"Page: ",GMRAPG
|
||||
W !,?30,"Summary of Outcomes"
|
||||
W !,?25,"From: ",$$FMTE^XLFDT(GMAST,"2D")," To: ",$$FMTE^XLFDT(GMAEN,"2D")
|
||||
W !,?42,"Yes",?55,"No",?65,"No Response"
|
||||
W !,$$REPEAT^XLFSTR("-",79)
|
||||
S GMRAPG=GMRAPG+1
|
||||
I $D(ZTQUEUED) S:$$STPCK^GMRAUTL1 GMRAOUT=1 ; Check if stopped by user
|
||||
Q
|
||||
TEXT ;;these are the labels that will denote the field data
|
||||
;;Patients that Died: ;3
|
||||
;;Reactions treated with RX drugs: ;4
|
||||
;;Life Threatening illness: ;5
|
||||
;;Required ER/MD visit: ;6
|
||||
;;Required hospitalization: ;7
|
||||
;;Prolonged Hospitalization: ;9
|
||||
;;Resulted in permanent disability: ;10
|
||||
;;Patient recovered: ;11
|
||||
;;Congenital Anomaly: ;16
|
||||
;;Required intervention: ;17
|
||||
;;
|
||||
GMRAPST2 ;HIRMFO/WAA- PRINT SUM LISTING OF OUT COMES ;3/5/97 14:50
|
||||
;;4.0;Adverse Reaction Tracking;**7**;Mar 29, 1996
|
||||
EN1 ; This routine will loop through the ADT entry point to get all
|
||||
; the entries in that date range.
|
||||
S GMRAOUT=0
|
||||
W !,"Select an Observed date range for this report."
|
||||
D DT^GMRAPL G:GMRAOUT EXIT
|
||||
D PRINTER
|
||||
EXIT ; Exit of program kill cleanup
|
||||
D KILL^XUSCLEAN
|
||||
Q
|
||||
PRINTER ;Select printer
|
||||
W ! K GMRAZIS D DEV^GMRAUTL I POP W !,"PLEASE TRY LATER" S GMRAOUT=1 Q
|
||||
I $D(IO("Q")) D Q
|
||||
. S ZTRTN="PRINT^GMRAPST2",(ZTSAVE("GMRAOUT"),ZTSAVE("GMAST"),ZTSAVE("GMAEN"))=""
|
||||
. S ZTDESC="Summary of Outcomes" D ^%ZTLOAD
|
||||
. W !!,$S($D(ZTSK):"Request queued...",1:"Request NOT queued please try Later.")
|
||||
. Q
|
||||
U IO D PRINT U IO(0)
|
||||
Q
|
||||
PRINT ;Queue point for report
|
||||
;loop through the 120.85 file and look for the field that
|
||||
D NOW^%DTC S GMRADPDT=X
|
||||
S GMRADATE=GMAST-.0001,GMRAPG=1
|
||||
S (GMRARRAY("YES"),GMRARRAY("NO"),GMRARRAY("NULL"))="",GMRATOT=0
|
||||
F S GMRADATE=$O(^GMR(120.85,"B",GMRADATE)) Q:GMRADATE<1 Q:GMRADATE>GMAEN D
|
||||
.S GMRAPA1=0 F S GMRAPA1=$O(^GMR(120.85,"B",GMRADATE,GMRAPA1)) Q:GMRAPA1<1 D
|
||||
..S GMRAPA1(0)=$G(^GMR(120.85,GMRAPA1,0)) Q:GMRAPA1(0)="" ;Bad Node
|
||||
..Q:+$G(^GMR(120.8,$P(GMRAPA1(0),U,15),"ER")) ;Entered in Error data
|
||||
..S GMRATOT=GMRATOT+1
|
||||
..F GMRALAB=1:1 S GMRALINE=$T(TEXT+GMRALAB) Q:$P(GMRALINE,";",3)="" D
|
||||
...S GMRAP=$P(GMRALINE,";",4)
|
||||
...I $P(GMRAPA1(0),U,GMRAP)="y" S $P(GMRARRAY("YES"),U,GMRAP)=$P(GMRARRAY("YES"),U,GMRAP)+1
|
||||
...I $P(GMRAPA1(0),U,GMRAP)="n" S $P(GMRARRAY("NO"),U,GMRAP)=$P(GMRARRAY("NO"),U,GMRAP)+1
|
||||
...I $P(GMRAPA1(0),U,GMRAP)="" S $P(GMRARRAY("NULL"),U,GMRAP)=$P(GMRARRAY("NULL"),U,GMRAP)+1
|
||||
...Q
|
||||
..Q
|
||||
.Q
|
||||
Q:GMRAOUT
|
||||
D HEAD
|
||||
S (GMRAY,GMRAN,GMRANU)=0
|
||||
F GMRALAB=1:1 S GMRALINE=$T(TEXT+GMRALAB) Q:$P(GMRALINE,";",3)="" D
|
||||
.N GMRAP,GMRATAB
|
||||
.S GMRAP=$P(GMRALINE,";",4)
|
||||
.S GMRATAB=40-$L($P(GMRALINE,";",3))
|
||||
.W !,?GMRATAB,$P(GMRALINE,";",3)
|
||||
.W ?42,$P(GMRARRAY("YES"),U,GMRAP)
|
||||
.S GMRAY=GMRAY+$P(GMRARRAY("YES"),U,GMRAP)
|
||||
.W ?53,"| ",$P(GMRARRAY("NO"),U,GMRAP)
|
||||
.S GMRAN=GMRAN+$P(GMRARRAY("NO"),U,GMRAP)
|
||||
.W ?63,"| ",$P(GMRARRAY("NULL"),U,GMRAP)
|
||||
.S GMRANU=GMRANU+$P(GMRARRAY("NULL"),U,GMRAP)
|
||||
.Q
|
||||
W !,?30," ---------------------------------------"
|
||||
W !,?32,"Totals: ",?42,GMRAY,?53,"| ",GMRAN,?63,"| ",GMRANU
|
||||
W !!,?22,"Total number of records processed ",GMRATOT
|
||||
D CLOSE^GMRAUTL
|
||||
Q
|
||||
;has the patient died with inthe dat
|
||||
HEAD ; Print header information
|
||||
I GMRAPG'=1 Q:$Y<(IOSL-4)
|
||||
I $E(IOST,1)="C" D Q:GMRAOUT
|
||||
.I GMRAPG=1 W @IOF Q
|
||||
.I GMRAPG'=1 D Q:GMRAOUT
|
||||
..N DIR S DIR(0)="E" D ^DIR I 'Y S GMRAOUT=1
|
||||
..K Y
|
||||
..Q
|
||||
.Q
|
||||
Q:GMRAOUT
|
||||
I GMRAPG'=1 W @IOF
|
||||
W "Report Date: ",$P($$FMTE^XLFDT(GMRADPDT),"@"),?70,"Page: ",GMRAPG
|
||||
W !,?30,"Summary of Outcomes"
|
||||
W !,?25,"From: ",$$FMTE^XLFDT(GMAST,"2D")," To: ",$$FMTE^XLFDT(GMAEN,"2D")
|
||||
W !,?42,"Yes",?55,"No",?65,"No Response"
|
||||
W !,$$REPEAT^XLFSTR("-",79)
|
||||
S GMRAPG=GMRAPG+1
|
||||
I $D(ZTQUEUED) S:$$STPCK^GMRAUTL1 GMRAOUT=1 ; Check if stopped by user
|
||||
Q
|
||||
TEXT ;;these are the labeles that will denote the field data
|
||||
;;Patients that Died: ;3
|
||||
;;Reactions treated with RX drugs: ;4
|
||||
;;Life Threatening illness: ;5
|
||||
;;Required ER/MD visit: ;6
|
||||
;;Required hospitalization: ;7
|
||||
;;Prolonged Hospitalization: ;9
|
||||
;;Resulted in permanent disability: ;10
|
||||
;;Patient recovered: ;11
|
||||
;;Congenital Anomaly: ;16
|
||||
;;Required intervention: ;17
|
||||
;;
|
||||
|
|
|
|||
|
|
@ -1,81 +1,80 @@
|
|||
GMRAPST3 ;HIRMFO/WAA- PRINT FREQUENCY OF DIST OVR DT BY REACT ;3/5/97 15:14
|
||||
;;4.0;Adverse Reaction Tracking;**7,33**;Mar 29, 1996;Build 5
|
||||
EN1 ; This routine will loop through the ADT entry point to get all
|
||||
; the entries in that date range.
|
||||
S GMRAOUT=0
|
||||
W !,"Select an Observed date range for this report."
|
||||
D DT^GMRAPL G:GMRAOUT EXIT
|
||||
D PRINTER
|
||||
EXIT ; Exit of program kill cleanup
|
||||
D KILL^XUSCLEAN
|
||||
K ^TMP($J,"GMRAPST3B")
|
||||
K ^TMP($J,"GMRAPST3A")
|
||||
Q
|
||||
PRINTER ;Select printer
|
||||
W ! K GMRAZIS D DEV^GMRAUTL I POP W !,"PLEASE TRY LATER" S GMRAOUT=1 Q
|
||||
I $D(IO("Q")) D Q
|
||||
. S ZTRTN="PRINT^GMRAPST3",(ZTSAVE("GMRAOUT"),ZTSAVE("GMAST"),ZTSAVE("GMAEN"))=""
|
||||
. S ZTDESC="Frequency Distribution of Causative Agents" D ^%ZTLOAD
|
||||
. W !!,$S($D(ZTSK):"Request queued...",1:"Request NOT queued please try Later.")
|
||||
. Q
|
||||
U IO D PRINT U IO(0)
|
||||
Q
|
||||
PRINT ;Queue point for report
|
||||
;loop through the 120.85 file and look for the field that
|
||||
D NOW^%DTC S GMRADPDT=X
|
||||
S GMRADATE=GMAST-.0001,GMRAPG=1
|
||||
K ^TMP($J,"GMRAPST3A")
|
||||
S GMRATOT=0
|
||||
F S GMRADATE=$O(^GMR(120.85,"B",GMRADATE)) Q:GMRADATE<1 Q:GMRADATE>GMAEN D
|
||||
.S GMRAPA1=0 F S GMRAPA1=$O(^GMR(120.85,"B",GMRADATE,GMRAPA1)) Q:GMRAPA1<1 D
|
||||
..S GMRAPA1(0)=$G(^GMR(120.85,GMRAPA1,0)) Q:GMRAPA1(0)="" ;Bad Node
|
||||
..Q:+$G(^GMR(120.8,$P(GMRAPA1(0),U,15),"ER")) ;Entered in error data
|
||||
..Q:'$$PRDTST^GMRAUTL1($P(GMRAPA1(0),U,2)) ;GMRA*4*33 Exclude test patient from report if production or legacy environment.
|
||||
..S GMRATOT=GMRATOT+1
|
||||
..S GMRAPA=$P(GMRAPA1(0),U,15) Q:'GMRAPA
|
||||
..S GMRAPA(0)=$G(^GMR(120.8,GMRAPA,0)) Q:GMRAPA(0)=""
|
||||
..S GMRAREC=$P(GMRAPA(0),U,2)
|
||||
..S ^TMP($J,"GMRAPST3A",GMRAREC)=$G(^TMP($J,"GMRAPST3A",GMRAREC))+1
|
||||
..Q
|
||||
.Q
|
||||
Q:GMRAOUT
|
||||
Q:'$D(^TMP($J,"GMRAPST3A"))
|
||||
K ^TMP($J,"GMRAPST3B")
|
||||
S GMRAREC=""
|
||||
F S GMRAREC=$O(^TMP($J,"GMRAPST3A",GMRAREC)) Q:GMRAREC="" D
|
||||
.S GMRARECN=$G(^TMP($J,"GMRAPST3A",GMRAREC)) Q:GMRARECN=""
|
||||
.S ^TMP($J,"GMRAPST3B",GMRARECN,GMRAREC)=""
|
||||
.Q
|
||||
D HEAD
|
||||
S GMRARECN=""
|
||||
F S GMRARECN=$O(^TMP($J,"GMRAPST3B",GMRARECN),-1) Q:GMRARECN<1 D Q:GMRAOUT
|
||||
.S GMRAREC=""
|
||||
.F S GMRAREC=$O(^TMP($J,"GMRAPST3B",GMRARECN,GMRAREC)) Q:GMRAREC="" D Q:GMRAOUT
|
||||
..S GMRATAB=30-$L($E(GMRAREC,1,30))
|
||||
..W !,?GMRATAB,$E(GMRAREC,1,30)," :",$J(GMRARECN,5)
|
||||
..D HEAD Q:GMRAOUT
|
||||
..Q
|
||||
.Q
|
||||
W !!,?22,"Total number of records processed ",GMRATOT
|
||||
D CLOSE^GMRAUTL
|
||||
Q
|
||||
;has the patient died within the date
|
||||
HEAD ; Print header information
|
||||
I GMRAPG'=1 Q:$Y<(IOSL-4)
|
||||
I $E(IOST,1)="C" D Q:GMRAOUT
|
||||
.I GMRAPG=1 W @IOF Q
|
||||
.I GMRAPG'=1 D Q:GMRAOUT
|
||||
..N DIR S DIR(0)="E" D ^DIR I 'Y S GMRAOUT=1
|
||||
..K Y
|
||||
..Q
|
||||
.Q
|
||||
Q:GMRAOUT
|
||||
I GMRAPG'=1 W @IOF
|
||||
W "Report Date: ",$P($$FMTE^XLFDT(GMRADPDT),"@"),?70,"Page: ",GMRAPG
|
||||
W !,?20,"Frequency Distribution of Causative Agents"
|
||||
W !,?25,"From: ",$$FMTE^XLFDT(GMAST,"2D")," To: ",$$FMTE^XLFDT(GMAEN,"2D")
|
||||
W !,"Causative Agents",?34,"Number"
|
||||
W !,$$REPEAT^XLFSTR("-",79)
|
||||
S GMRAPG=GMRAPG+1
|
||||
I $D(ZTQUEUED) S:$$STPCK^GMRAUTL1 GMRAOUT=1 ; Check if stopped by user
|
||||
Q
|
||||
GMRAPST3 ;HIRMFO/WAA- PRINT FREQUENCY OF DIST OVR DT BY REACT ;3/5/97 15:14
|
||||
;;4.0;Adverse Reaction Tracking;**7**;Mar 29, 1996
|
||||
EN1 ; This routine will loop through the ADT entry point to get all
|
||||
; the entries in that date range.
|
||||
S GMRAOUT=0
|
||||
W !,"Select an Observed date range for this report."
|
||||
D DT^GMRAPL G:GMRAOUT EXIT
|
||||
D PRINTER
|
||||
EXIT ; Exit of program kill cleanup
|
||||
D KILL^XUSCLEAN
|
||||
K ^TMP($J,"GMRAPST3B")
|
||||
K ^TMP($J,"GMRAPST3A")
|
||||
Q
|
||||
PRINTER ;Select printer
|
||||
W ! K GMRAZIS D DEV^GMRAUTL I POP W !,"PLEASE TRY LATER" S GMRAOUT=1 Q
|
||||
I $D(IO("Q")) D Q
|
||||
. S ZTRTN="PRINT^GMRAPST3",(ZTSAVE("GMRAOUT"),ZTSAVE("GMAST"),ZTSAVE("GMAEN"))=""
|
||||
. S ZTDESC="Frequency Distribution of Causative Agents" D ^%ZTLOAD
|
||||
. W !!,$S($D(ZTSK):"Request queued...",1:"Request NOT queued please try Later.")
|
||||
. Q
|
||||
U IO D PRINT U IO(0)
|
||||
Q
|
||||
PRINT ;Queue point for report
|
||||
;loop through the 120.85 file and look for the field that
|
||||
D NOW^%DTC S GMRADPDT=X
|
||||
S GMRADATE=GMAST-.0001,GMRAPG=1
|
||||
K ^TMP($J,"GMRAPST3A")
|
||||
S GMRATOT=0
|
||||
F S GMRADATE=$O(^GMR(120.85,"B",GMRADATE)) Q:GMRADATE<1 Q:GMRADATE>GMAEN D
|
||||
.S GMRAPA1=0 F S GMRAPA1=$O(^GMR(120.85,"B",GMRADATE,GMRAPA1)) Q:GMRAPA1<1 D
|
||||
..S GMRAPA1(0)=$G(^GMR(120.85,GMRAPA1,0)) Q:GMRAPA1(0)="" ;Bad Node
|
||||
..Q:+$G(^GMR(120.8,$P(GMRAPA1(0),U,15),"ER")) ;Entered in error data
|
||||
..S GMRATOT=GMRATOT+1
|
||||
..S GMRAPA=$P(GMRAPA1(0),U,15) Q:'GMRAPA
|
||||
..S GMRAPA(0)=$G(^GMR(120.8,GMRAPA,0)) Q:GMRAPA(0)=""
|
||||
..S GMRAREC=$P(GMRAPA(0),U,2)
|
||||
..S ^TMP($J,"GMRAPST3A",GMRAREC)=$G(^TMP($J,"GMRAPST3A",GMRAREC))+1
|
||||
..Q
|
||||
.Q
|
||||
Q:GMRAOUT
|
||||
Q:'$D(^TMP($J,"GMRAPST3A"))
|
||||
K ^TMP($J,"GMRAPST3B")
|
||||
S GMRAREC=""
|
||||
F S GMRAREC=$O(^TMP($J,"GMRAPST3A",GMRAREC)) Q:GMRAREC="" D
|
||||
.S GMRARECN=$G(^TMP($J,"GMRAPST3A",GMRAREC)) Q:GMRARECN=""
|
||||
.S ^TMP($J,"GMRAPST3B",GMRARECN,GMRAREC)=""
|
||||
.Q
|
||||
D HEAD
|
||||
S GMRARECN=""
|
||||
F S GMRARECN=$O(^TMP($J,"GMRAPST3B",GMRARECN),-1) Q:GMRARECN<1 D Q:GMRAOUT
|
||||
.S GMRAREC=""
|
||||
.F S GMRAREC=$O(^TMP($J,"GMRAPST3B",GMRARECN,GMRAREC)) Q:GMRAREC="" D Q:GMRAOUT
|
||||
..S GMRATAB=30-$L($E(GMRAREC,1,30))
|
||||
..W !,?GMRATAB,$E(GMRAREC,1,30)," :",$J(GMRARECN,5)
|
||||
..D HEAD Q:GMRAOUT
|
||||
..Q
|
||||
.Q
|
||||
W !!,?22,"Total number of records processed ",GMRATOT
|
||||
D CLOSE^GMRAUTL
|
||||
Q
|
||||
;has the patient died with inthe dat
|
||||
HEAD ; Print header information
|
||||
I GMRAPG'=1 Q:$Y<(IOSL-4)
|
||||
I $E(IOST,1)="C" D Q:GMRAOUT
|
||||
.I GMRAPG=1 W @IOF Q
|
||||
.I GMRAPG'=1 D Q:GMRAOUT
|
||||
..N DIR S DIR(0)="E" D ^DIR I 'Y S GMRAOUT=1
|
||||
..K Y
|
||||
..Q
|
||||
.Q
|
||||
Q:GMRAOUT
|
||||
I GMRAPG'=1 W @IOF
|
||||
W "Report Date: ",$P($$FMTE^XLFDT(GMRADPDT),"@"),?70,"Page: ",GMRAPG
|
||||
W !,?20,"Frequency Distribution of Causative Agents"
|
||||
W !,?25,"From: ",$$FMTE^XLFDT(GMAST,"2D")," To: ",$$FMTE^XLFDT(GMAEN,"2D")
|
||||
W !,"Causative Agents",?34,"Number"
|
||||
W !,$$REPEAT^XLFSTR("-",79)
|
||||
S GMRAPG=GMRAPG+1
|
||||
I $D(ZTQUEUED) S:$$STPCK^GMRAUTL1 GMRAOUT=1 ; Check if stopped by user
|
||||
Q
|
||||
|
|
|
|||
|
|
@ -1,83 +1,82 @@
|
|||
GMRAPST4 ;HIRMFO/WAA- PRINT FREQUENCY OF DIST OVR DT BY DC ;3/5/97 15:15
|
||||
;;4.0;Adverse Reaction Tracking;**7,33**;Mar 29, 1996;Build 5
|
||||
EN1 ; This routine will loop through the ADT entry point to get all
|
||||
; the entries in that date range.
|
||||
S GMRAOUT=0
|
||||
W !,"Select an Observed date range for this report."
|
||||
D DT^GMRAPL G:GMRAOUT EXIT
|
||||
D PRINTER
|
||||
EXIT ; Exit of program kill cleanup
|
||||
K ^TMP($J,"GMRAPST4")
|
||||
D KILL^XUSCLEAN
|
||||
Q
|
||||
PRINTER ;Select printer
|
||||
W ! K GMRAZIS D DEV^GMRAUTL I POP W !,"PLEASE TRY LATER" S GMRAOUT=1 Q
|
||||
I $D(IO("Q")) D Q
|
||||
. S ZTRTN="PRINT^GMRAPST4",(ZTSAVE("GMRAOUT"),ZTSAVE("GMAST"),ZTSAVE("GMAEN"))=""
|
||||
. S ZTDESC="Frequency Distribution of Drug Classes" D ^%ZTLOAD
|
||||
. W !!,$S($D(ZTSK):"Request queued...",1:"Request NOT queued please try Later.")
|
||||
. Q
|
||||
U IO D PRINT U IO(0)
|
||||
Q
|
||||
PRINT ;Queue point for report
|
||||
;loop through the 120.85 file and look for the field that
|
||||
D NOW^%DTC S GMRADPDT=X
|
||||
S GMRADATE=GMAST-.0001,GMRAPG=1
|
||||
K ^TMP($J,"GMRAPST4")
|
||||
S GMRATOT=0
|
||||
F S GMRADATE=$O(^GMR(120.85,"B",GMRADATE)) Q:GMRADATE<1 Q:GMRADATE>GMAEN D
|
||||
.S GMRAPA1=0 F S GMRAPA1=$O(^GMR(120.85,"B",GMRADATE,GMRAPA1)) Q:GMRAPA1<1 D
|
||||
..S GMRAPA1(0)=$G(^GMR(120.85,GMRAPA1,0)) Q:GMRAPA1(0)="" ;Bad Node
|
||||
..Q:+$G(^GMR(120.8,$P(GMRAPA1(0),U,15),"ER")) ;Entered in error data
|
||||
..Q:'$$PRDTST^GMRAUTL1($P(GMRAPA1(0),U,2)) ;GMRA*4*33 Exclude test patient from report if production or legacy environment.
|
||||
..S GMRATOT=GMRATOT+1
|
||||
..S GMRAPA=$P(GMRAPA1(0),U,15) Q:'GMRAPA
|
||||
..S GMRAPA(0)=$G(^GMR(120.8,GMRAPA,0)) Q:GMRAPA(0)=""
|
||||
..S GMRADC=0
|
||||
..F S GMRADC=$O(^GMR(120.8,GMRAPA,3,GMRADC)) Q:GMRADC<1 D
|
||||
...S GMRADCN=$P($G(^GMR(120.8,GMRAPA,3,GMRADC,0)),U) Q:GMRADCN=""
|
||||
...S ^TMP($J,"GMRAPST4",GMRADCN)=$G(^TMP($J,"GMRAPST4",GMRADCN))+1
|
||||
...Q
|
||||
..Q
|
||||
.Q
|
||||
Q:GMRAOUT
|
||||
Q:'$D(^TMP($J,"GMRAPST4"))
|
||||
S GMRADCN=0
|
||||
;Sort in value order.
|
||||
F S GMRADCN=$O(^TMP($J,"GMRAPST4",GMRADCN)) Q:GMRADCN<1 D
|
||||
.S GMRADC=$G(^TMP($J,"GMRAPST4",GMRADCN)) Q:GMRADC<1
|
||||
.S ^TMP($J,"GMRAPST4","B",GMRADC,GMRADCN)=""
|
||||
.Q
|
||||
D HEAD
|
||||
S GMRADC=""
|
||||
F S GMRADC=$O(^TMP($J,"GMRAPST4","B",GMRADC),-1) Q:GMRADC<1 D Q:GMRAOUT
|
||||
.S GMRADCN=0
|
||||
.F S GMRADCN=$O(^TMP($J,"GMRAPST4","B",GMRADC,GMRADCN)) Q:GMRADCN<1 D Q:GMRAOUT
|
||||
..S GMRADC0=$G(^PS(50.605,GMRADCN,0)) Q:GMRADC0=""
|
||||
..S GMRATAB=30-$L($E($P(GMRADC0,U,2),1,30))
|
||||
..W !,?GMRATAB,$E($P(GMRADC0,U,2),1,30)," (",$P(GMRADC0,U),") :",$J(GMRADC,5)
|
||||
..D HEAD Q:GMRAOUT
|
||||
..Q
|
||||
.Q
|
||||
W !!,?22,"Total number of records processed ",GMRATOT
|
||||
D CLOSE^GMRAUTL
|
||||
Q
|
||||
HEAD ; Print header information
|
||||
I GMRAPG'=1 Q:$Y<(IOSL-4)
|
||||
I $E(IOST,1)="C" D Q:GMRAOUT
|
||||
.I GMRAPG=1 W @IOF Q
|
||||
.I GMRAPG'=1 D Q:GMRAOUT
|
||||
..N DIR S DIR(0)="E" D ^DIR I 'Y S GMRAOUT=1
|
||||
..K Y
|
||||
..Q
|
||||
.Q
|
||||
Q:GMRAOUT
|
||||
I GMRAPG'=1 W @IOF
|
||||
W "Report Date: ",$P($$FMTE^XLFDT(GMRADPDT),"@"),?70,"Page: ",GMRAPG
|
||||
W !,?20,"Frequency Distribution of Drug Classes"
|
||||
W !,?25,"From: ",$$FMTE^XLFDT(GMAST,"2D")," To: ",$$FMTE^XLFDT(GMAEN,"2D")
|
||||
W !,"Drug Class",?39,"Number"
|
||||
W !,$$REPEAT^XLFSTR("-",79)
|
||||
S GMRAPG=GMRAPG+1
|
||||
I $D(ZTQUEUED) S:$$STPCK^GMRAUTL1 GMRAOUT=1 ; Check if stopped by user
|
||||
Q
|
||||
GMRAPST4 ;HIRMFO/WAA- PRINT FREQUENCY OF DIST OVR DT BY DC ;3/5/97 15:15
|
||||
;;4.0;Adverse Reaction Tracking;**7**;Mar 29, 1996
|
||||
EN1 ; This routine will loop through the ADT entry point to get all
|
||||
; the entries in that date range.
|
||||
S GMRAOUT=0
|
||||
W !,"Select an Observed date range for this report."
|
||||
D DT^GMRAPL G:GMRAOUT EXIT
|
||||
D PRINTER
|
||||
EXIT ; Exit of program kill cleanup
|
||||
K ^TMP($J,"GMRAPST4")
|
||||
D KILL^XUSCLEAN
|
||||
Q
|
||||
PRINTER ;Select printer
|
||||
W ! K GMRAZIS D DEV^GMRAUTL I POP W !,"PLEASE TRY LATER" S GMRAOUT=1 Q
|
||||
I $D(IO("Q")) D Q
|
||||
. S ZTRTN="PRINT^GMRAPST4",(ZTSAVE("GMRAOUT"),ZTSAVE("GMAST"),ZTSAVE("GMAEN"))=""
|
||||
. S ZTDESC="Frequency Distribution of Drug Classes" D ^%ZTLOAD
|
||||
. W !!,$S($D(ZTSK):"Request queued...",1:"Request NOT queued please try Later.")
|
||||
. Q
|
||||
U IO D PRINT U IO(0)
|
||||
Q
|
||||
PRINT ;Queue point for report
|
||||
;loop through the 120.85 file and look for the field that
|
||||
D NOW^%DTC S GMRADPDT=X
|
||||
S GMRADATE=GMAST-.0001,GMRAPG=1
|
||||
K ^TMP($J,"GMRAPST4")
|
||||
S GMRATOT=0
|
||||
F S GMRADATE=$O(^GMR(120.85,"B",GMRADATE)) Q:GMRADATE<1 Q:GMRADATE>GMAEN D
|
||||
.S GMRAPA1=0 F S GMRAPA1=$O(^GMR(120.85,"B",GMRADATE,GMRAPA1)) Q:GMRAPA1<1 D
|
||||
..S GMRAPA1(0)=$G(^GMR(120.85,GMRAPA1,0)) Q:GMRAPA1(0)="" ;Bad Node
|
||||
..Q:+$G(^GMR(120.8,$P(GMRAPA1(0),U,15),"ER")) ;Entered in error data
|
||||
..S GMRATOT=GMRATOT+1
|
||||
..S GMRAPA=$P(GMRAPA1(0),U,15) Q:'GMRAPA
|
||||
..S GMRAPA(0)=$G(^GMR(120.8,GMRAPA,0)) Q:GMRAPA(0)=""
|
||||
..S GMRADC=0
|
||||
..F S GMRADC=$O(^GMR(120.8,GMRAPA,3,GMRADC)) Q:GMRADC<1 D
|
||||
...S GMRADCN=$P($G(^GMR(120.8,GMRAPA,3,GMRADC,0)),U) Q:GMRADCN=""
|
||||
...S ^TMP($J,"GMRAPST4",GMRADCN)=$G(^TMP($J,"GMRAPST4",GMRADCN))+1
|
||||
...Q
|
||||
..Q
|
||||
.Q
|
||||
Q:GMRAOUT
|
||||
Q:'$D(^TMP($J,"GMRAPST4"))
|
||||
S GMRADCN=0
|
||||
;Sort in value order.
|
||||
F S GMRADCN=$O(^TMP($J,"GMRAPST4",GMRADCN)) Q:GMRADCN<1 D
|
||||
.S GMRADC=$G(^TMP($J,"GMRAPST4",GMRADCN)) Q:GMRADC<1
|
||||
.S ^TMP($J,"GMRAPST4","B",GMRADC,GMRADCN)=""
|
||||
.Q
|
||||
D HEAD
|
||||
S GMRADC=""
|
||||
F S GMRADC=$O(^TMP($J,"GMRAPST4","B",GMRADC),-1) Q:GMRADC<1 D Q:GMRAOUT
|
||||
.S GMRADCN=0
|
||||
.F S GMRADCN=$O(^TMP($J,"GMRAPST4","B",GMRADC,GMRADCN)) Q:GMRADCN<1 D Q:GMRAOUT
|
||||
..S GMRADC0=$G(^PS(50.605,GMRADCN,0)) Q:GMRADC0=""
|
||||
..S GMRATAB=30-$L($E($P(GMRADC0,U,2),1,30))
|
||||
..W !,?GMRATAB,$E($P(GMRADC0,U,2),1,30)," (",$P(GMRADC0,U),") :",$J(GMRADC,5)
|
||||
..D HEAD Q:GMRAOUT
|
||||
..Q
|
||||
.Q
|
||||
W !!,?22,"Total number of records processed ",GMRATOT
|
||||
D CLOSE^GMRAUTL
|
||||
Q
|
||||
HEAD ; Print header information
|
||||
I GMRAPG'=1 Q:$Y<(IOSL-4)
|
||||
I $E(IOST,1)="C" D Q:GMRAOUT
|
||||
.I GMRAPG=1 W @IOF Q
|
||||
.I GMRAPG'=1 D Q:GMRAOUT
|
||||
..N DIR S DIR(0)="E" D ^DIR I 'Y S GMRAOUT=1
|
||||
..K Y
|
||||
..Q
|
||||
.Q
|
||||
Q:GMRAOUT
|
||||
I GMRAPG'=1 W @IOF
|
||||
W "Report Date: ",$P($$FMTE^XLFDT(GMRADPDT),"@"),?70,"Page: ",GMRAPG
|
||||
W !,?20,"Frequency Distribution of Drug Classes"
|
||||
W !,?25,"From: ",$$FMTE^XLFDT(GMAST,"2D")," To: ",$$FMTE^XLFDT(GMAEN,"2D")
|
||||
W !,"Drug Class",?39,"Number"
|
||||
W !,$$REPEAT^XLFSTR("-",79)
|
||||
S GMRAPG=GMRAPG+1
|
||||
I $D(ZTQUEUED) S:$$STPCK^GMRAUTL1 GMRAOUT=1 ; Check if stopped by user
|
||||
Q
|
||||
|
|
|
|||
|
|
@ -1,57 +1,56 @@
|
|||
GMRAPST5 ;HIRMFO/WAA- PRINT TOTAL NUMBER OF REPORTED REACTION ;3/5/97 15:16
|
||||
;;4.0;Adverse Reaction Tracking;**7,33**;Mar 29, 1996;Build 5
|
||||
EN1 ; This routine will loop through the ADT entry point to get all
|
||||
; the entries in that date range.
|
||||
S GMRAOUT=0
|
||||
W !,"Select an Observed date range for this report."
|
||||
D DT^GMRAPL G:GMRAOUT EXIT
|
||||
D PRINTER
|
||||
EXIT ; Exit of program kill cleanup
|
||||
D KILL^XUSCLEAN
|
||||
Q
|
||||
PRINTER ;Select printer
|
||||
W ! K GMRAZIS D DEV^GMRAUTL I POP W !,"PLEASE TRY LATER" S GMRAOUT=1 Q
|
||||
I $D(IO("Q")) D Q
|
||||
. S ZTRTN="PRINT^GMRAPST5",(ZTSAVE("GMRAOUT"),ZTSAVE("GMAST"),ZTSAVE("GMAEN"))=""
|
||||
. S ZTDESC="Reported Reaction over a date range." D ^%ZTLOAD
|
||||
. W !!,$S($D(ZTSK):"Request queued...",1:"Request NOT queued please try Later.")
|
||||
. Q
|
||||
U IO D PRINT U IO(0)
|
||||
Q
|
||||
PRINT ;Queue point for report
|
||||
;loop through the 120.85 file and look for the field that
|
||||
D NOW^%DTC S GMRADPDT=X
|
||||
S GMRADATE=GMAST-.0001,GMRAPG=1
|
||||
S GMRATOT=0
|
||||
F S GMRADATE=$O(^GMR(120.85,"B",GMRADATE)) Q:GMRADATE<1 Q:GMRADATE>GMAEN D
|
||||
.S GMRAPA1=0 F S GMRAPA1=$O(^GMR(120.85,"B",GMRADATE,GMRAPA1)) Q:GMRAPA1<1 D
|
||||
..S GMRAPA1(0)=$G(^GMR(120.85,GMRAPA1,0)) Q:GMRAPA1(0)="" ;Bad Node
|
||||
..Q:+$G(^GMR(120.8,$P(GMRAPA1(0),U,15),"ER")) ;Entered in Error Data
|
||||
..Q:'$$PRDTST^GMRAUTL1($P(GMRAPA1(0),U,2)) ;GMRA*4*33 Exclude test patient from report if production or legacy environment.
|
||||
..S GMRATOT=GMRATOT+1
|
||||
..Q
|
||||
.Q
|
||||
Q:GMRAOUT
|
||||
D HEAD
|
||||
W !,?19,"Total Number of Reported Reactions: ",GMRATOT
|
||||
W !,?27,"From: ",$$FMTE^XLFDT(GMAST,"2D"),?42,"To: ",$$FMTE^XLFDT(GMAEN,"2D")
|
||||
D CLOSE^GMRAUTL
|
||||
Q
|
||||
;has the patient died within the date
|
||||
HEAD ; Print header information
|
||||
I GMRAPG'=1 Q:$Y<(IOSL-4)
|
||||
I $E(IOST,1)="C" D Q:GMRAOUT
|
||||
.I GMRAPG=1 W @IOF Q
|
||||
.I GMRAPG'=1 D Q:GMRAOUT
|
||||
..N DIR S DIR(0)="E" D ^DIR I 'Y S GMRAOUT=1
|
||||
..K Y
|
||||
..Q
|
||||
.Q
|
||||
Q:GMRAOUT
|
||||
I GMRAPG'=1 W @IOF
|
||||
W "Report Date: ",$P($$FMTE^XLFDT(GMRADPDT),"@"),?70,"Page: ",GMRAPG
|
||||
W !,?33,"Reported Reactions"
|
||||
W !,$$REPEAT^XLFSTR("-",79)
|
||||
S GMRAPG=GMRAPG+1
|
||||
I $D(ZTQUEUED) S:$$STPCK^GMRAUTL1 GMRAOUT=1 ; Check if stopped by user
|
||||
Q
|
||||
GMRAPST5 ;HIRMFO/WAA- PRINT TOTAL NUMBER OF REPORTED REACTION ;3/5/97 15:16
|
||||
;;4.0;Adverse Reaction Tracking;**7**;Mar 29, 1996
|
||||
EN1 ; This routine will loop through the ADT entry point to get all
|
||||
; the entries in that date range.
|
||||
S GMRAOUT=0
|
||||
W !,"Select an Observed date range for this report."
|
||||
D DT^GMRAPL G:GMRAOUT EXIT
|
||||
D PRINTER
|
||||
EXIT ; Exit of program kill cleanup
|
||||
D KILL^XUSCLEAN
|
||||
Q
|
||||
PRINTER ;Select printer
|
||||
W ! K GMRAZIS D DEV^GMRAUTL I POP W !,"PLEASE TRY LATER" S GMRAOUT=1 Q
|
||||
I $D(IO("Q")) D Q
|
||||
. S ZTRTN="PRINT^GMRAPST5",(ZTSAVE("GMRAOUT"),ZTSAVE("GMAST"),ZTSAVE("GMAEN"))=""
|
||||
. S ZTDESC="Reported Reaction over a date range." D ^%ZTLOAD
|
||||
. W !!,$S($D(ZTSK):"Request queued...",1:"Request NOT queued please try Later.")
|
||||
. Q
|
||||
U IO D PRINT U IO(0)
|
||||
Q
|
||||
PRINT ;Queue point for report
|
||||
;loop through the 120.85 file and look for the field that
|
||||
D NOW^%DTC S GMRADPDT=X
|
||||
S GMRADATE=GMAST-.0001,GMRAPG=1
|
||||
S GMRATOT=0
|
||||
F S GMRADATE=$O(^GMR(120.85,"B",GMRADATE)) Q:GMRADATE<1 Q:GMRADATE>GMAEN D
|
||||
.S GMRAPA1=0 F S GMRAPA1=$O(^GMR(120.85,"B",GMRADATE,GMRAPA1)) Q:GMRAPA1<1 D
|
||||
..S GMRAPA1(0)=$G(^GMR(120.85,GMRAPA1,0)) Q:GMRAPA1(0)="" ;Bad Node
|
||||
..Q:+$G(^GMR(120.8,$P(GMRAPA1(0),U,15),"ER")) ;Entered in Error Data
|
||||
..S GMRATOT=GMRATOT+1
|
||||
..Q
|
||||
.Q
|
||||
Q:GMRAOUT
|
||||
D HEAD
|
||||
W !,?19,"Total Number of Reported Reactions: ",GMRATOT
|
||||
W !,?27,"From: ",$$FMTE^XLFDT(GMAST,"2D"),?42,"To: ",$$FMTE^XLFDT(GMAEN,"2D")
|
||||
D CLOSE^GMRAUTL
|
||||
Q
|
||||
;has the patient died with inthe dat
|
||||
HEAD ; Print header information
|
||||
I GMRAPG'=1 Q:$Y<(IOSL-4)
|
||||
I $E(IOST,1)="C" D Q:GMRAOUT
|
||||
.I GMRAPG=1 W @IOF Q
|
||||
.I GMRAPG'=1 D Q:GMRAOUT
|
||||
..N DIR S DIR(0)="E" D ^DIR I 'Y S GMRAOUT=1
|
||||
..K Y
|
||||
..Q
|
||||
.Q
|
||||
Q:GMRAOUT
|
||||
I GMRAPG'=1 W @IOF
|
||||
W "Report Date: ",$P($$FMTE^XLFDT(GMRADPDT),"@"),?70,"Page: ",GMRAPG
|
||||
W !,?33,"Reported Reactions"
|
||||
W !,$$REPEAT^XLFSTR("-",79)
|
||||
S GMRAPG=GMRAPG+1
|
||||
I $D(ZTQUEUED) S:$$STPCK^GMRAUTL1 GMRAOUT=1 ; Check if stopped by user
|
||||
Q
|
||||
|
|
|
|||
|
|
@ -1,96 +1,95 @@
|
|||
GMRAPST6 ;HIRMFO/WAA- ADR OUTCOME REPORT ;3/5/97 15:16
|
||||
;;4.0;Adverse Reaction Tracking;**7,33**;Mar 29, 1996;Build 5
|
||||
EN1 ; This routine will loop through the ADT entry point to get all
|
||||
; the entries in that date range.
|
||||
S GMRAOUT=0
|
||||
W !,"Select an Observed date range for this report."
|
||||
D DT^GMRAPL G:GMRAOUT EXIT
|
||||
D PRINTER
|
||||
EXIT ; Exit of program kill cleanup
|
||||
D KILL^XUSCLEAN
|
||||
K ^TMP($J,"GMRAPST6")
|
||||
Q
|
||||
PRINTER ;Select printer
|
||||
W ! K GMRAZIS D DEV^GMRAUTL I POP W !,"PLEASE TRY LATER" S GMRAOUT=1 Q
|
||||
I $D(IO("Q")) D Q
|
||||
. S ZTRTN="PRINT^GMRAPST6",(ZTSAVE("GMRAOUT"),ZTSAVE("GMAST"),ZTSAVE("GMAEN"))=""
|
||||
. S ZTDESC="P&T Committee ADR Outcome Report" D ^%ZTLOAD
|
||||
. W !!,$S($D(ZTSK):"Request queued...",1:"Request NOT queued please try Later.")
|
||||
. Q
|
||||
U IO D PRINT U IO(0)
|
||||
Q
|
||||
PRINT ;Queue point for report
|
||||
;loop through the 120.85 file and look for the field that
|
||||
K ^TMP($J,"GMRAPST6")
|
||||
D NOW^%DTC S GMRADPDT=X
|
||||
S GMRADATE=GMAST-.0001,GMRAPG=1
|
||||
F S GMRADATE=$O(^GMR(120.85,"B",GMRADATE)) Q:GMRADATE<1 Q:GMRADATE>GMAEN D
|
||||
.S GMRAPA1=0 F S GMRAPA1=$O(^GMR(120.85,"B",GMRADATE,GMRAPA1)) Q:GMRAPA1<1 D
|
||||
..S GMRAPA1(0)=$G(^GMR(120.85,GMRAPA1,0)) Q:GMRAPA1(0)="" ;Bad Node
|
||||
..S GMRADDT=$P(GMRAPA1(0),U) ; reaction date
|
||||
..S GMRAPA=$P(GMRAPA1(0),U,15) ; Get the 120.8 entry for this reaction in 120.85
|
||||
..S GMRAPA(0)=$G(^GMR(120.8,GMRAPA,0)) Q:GMRAPA(0)="" ; Bad node
|
||||
..Q:+$G(^GMR(120.8,GMRAPA,"ER")) ;entered in error data
|
||||
..S GMRACA=$P(GMRAPA(0),U,2) ; Causative Agent
|
||||
..S DFN=$P(GMRAPA(0),U),GMRACA=$E(GMRACA,1,22)_"-"_$E($P(^DPT(DFN,0),U),1)_$E($P(^(0),U,9),6,9)
|
||||
..Q:'$$PRDTST^GMRAUTL1(DFN) ;GMRA*4*33 Exclude test patients if production or legacy environment.
|
||||
..S ^TMP($J,"GMRAPST6",GMRADDT,GMRACA,GMRAPA1)=""
|
||||
..Q
|
||||
.Q
|
||||
Q:GMRAOUT
|
||||
I '$D(^TMP($J,"GMRAPST6")) D HEAD W !,"NO DATA FOR THIS REPORT..." Q
|
||||
S GMRAOTH=$G(GMRAOTH,$O(^GMRD(120.83,"B","OTHER REACTION",0)))
|
||||
S GMRADDT=0
|
||||
F S GMRADDT=$O(^TMP($J,"GMRAPST6",GMRADDT)) Q:GMRADDT<1 D Q:GMRAOUT
|
||||
.S GMRACA=""
|
||||
.F S GMRACA=$O(^TMP($J,"GMRAPST6",GMRADDT,GMRACA)) Q:GMRACA="" D Q:GMRAOUT
|
||||
..S GMRAPA1=0
|
||||
..F S GMRAPA1=$O(^TMP($J,"GMRAPST6",GMRADDT,GMRACA,GMRAPA1)) Q:GMRAPA1<1 D Q:GMRAOUT
|
||||
...S GMRAPA1(0)=$G(^GMR(120.85,GMRAPA1,0))
|
||||
...Q:GMRAPA(0)=""
|
||||
...D HEAD Q:GMRAOUT
|
||||
...W !,$J($$FMTE^XLFDT(GMRADDT,"2D"),8) ; Obs Date
|
||||
...W ?8,"|",GMRACA ; Causative Agent
|
||||
...W ?38,"|"
|
||||
...S GMRAREC=0
|
||||
...S GMRAREC=$O(^GMR(120.85,GMRAPA1,2,0)) D:GMRAREC>0 SIGN("0",GMRAREC)
|
||||
...W ?58,"|" W:$P(GMRAPA1(0),U,4)="y" " Y" ; Req Tx with Rx
|
||||
...W ?63,"|" W:$P(GMRAPA1(0),U,7)="y" " Y" ; Req Hosp.
|
||||
...W ?68,"|" W:$P(GMRAPA1(0),U,10)="y" " Y" ; Disability
|
||||
...W ?73,"|" W:$P(GMRAPA1(0),U,3)="y" " Y" ; Death
|
||||
...F S GMRAREC=$O(^GMR(120.85,GMRAPA1,2,GMRAREC)) Q:GMRAREC<1 D SIGN("1",GMRAREC) Q:GMRAOUT
|
||||
...Q:GMRAOUT
|
||||
...D HEAD Q:GMRAOUT W !,?8,"|",?38,"|",?58,"|",?63,"|",?68,"|",?73,"|"
|
||||
...Q
|
||||
..Q
|
||||
.Q
|
||||
D CLOSE^GMRAUTL
|
||||
Q
|
||||
SIGN(CNT,GMRAREC) ; Print Sign/Symptoms
|
||||
N NAM,Y
|
||||
S Y=$G(^GMR(120.85,GMRAPA1,2,GMRAREC,0))
|
||||
S NAM=$S(+Y=GMRAOTH:$P(Y,U,2),$D(^GMRD(120.83,+Y,0)):$P(^GMRD(120.83,+Y,0),U),1:"")
|
||||
I 'CNT W $E(NAM,1,19)
|
||||
E D HEAD Q:GMRAOUT W !,?8,"|",?38,"|",$E(NAM,1,19),?58,"|",?63,"|",?68,"|",?73,"|"
|
||||
Q
|
||||
HEAD ; Print header information
|
||||
I GMRAPG'=1 Q:$Y<(IOSL-4)
|
||||
I $E(IOST,1)="C" D Q:GMRAOUT
|
||||
.I GMRAPG=1 W @IOF Q
|
||||
.I GMRAPG'=1 D Q:GMRAOUT
|
||||
..N DIR S DIR(0)="E" D ^DIR I 'Y S GMRAOUT=1
|
||||
..K Y
|
||||
..Q
|
||||
.Q
|
||||
Q:GMRAOUT
|
||||
I GMRAPG'=1 W @IOF
|
||||
W "Report Date: ",$P($$FMTE^XLFDT(GMRADPDT),"@"),?70,"Page: ",GMRAPG
|
||||
W !,?22,"P&T Committee ADR Outcome Report"
|
||||
W !,?25,"From: ",$$FMTE^XLFDT(GMAST,"2D")," To: ",$$FMTE^XLFDT(GMAEN,"2D")
|
||||
W !,$$REPEAT^XLFSTR("-",79)
|
||||
W !,"Obsv.",?8,"|",?38,"|",?58,"|Req.",?63,"|Req.",?68,"|",?73,"|"
|
||||
W !,"Date",?8,"|Causative agent-Pat. ID",?38,"|Sign/Symptoms",?58,"|Tx",?63,"|Hosp",?68,"|Dis.",?73,"|Death"
|
||||
W !,$$REPEAT^XLFSTR("-",79)
|
||||
S GMRAPG=GMRAPG+1
|
||||
I $D(ZTQUEUED) S:$$STPCK^GMRAUTL1 GMRAOUT=1 ; Check if stopped by user
|
||||
Q
|
||||
GMRAPST6 ;HIRMFO/WAA- ADR OUTCOME REPORT ;3/5/97 15:16
|
||||
;;4.0;Adverse Reaction Tracking;**7**;Mar 29, 1996
|
||||
EN1 ; This routine will loop through the ADT entry point to get all
|
||||
; the entries in that date range.
|
||||
S GMRAOUT=0
|
||||
W !,"Select an Observed date range for this report."
|
||||
D DT^GMRAPL G:GMRAOUT EXIT
|
||||
D PRINTER
|
||||
EXIT ; Exit of program kill cleanup
|
||||
D KILL^XUSCLEAN
|
||||
K ^TMP($J,"GMRAPST6")
|
||||
Q
|
||||
PRINTER ;Select printer
|
||||
W ! K GMRAZIS D DEV^GMRAUTL I POP W !,"PLEASE TRY LATER" S GMRAOUT=1 Q
|
||||
I $D(IO("Q")) D Q
|
||||
. S ZTRTN="PRINT^GMRAPST6",(ZTSAVE("GMRAOUT"),ZTSAVE("GMAST"),ZTSAVE("GMAEN"))=""
|
||||
. S ZTDESC="P&T Committee ADR Outcome Report" D ^%ZTLOAD
|
||||
. W !!,$S($D(ZTSK):"Request queued...",1:"Request NOT queued please try Later.")
|
||||
. Q
|
||||
U IO D PRINT U IO(0)
|
||||
Q
|
||||
PRINT ;Queue point for report
|
||||
;loop through the 120.85 file and look for the field that
|
||||
K ^TMP($J,"GMRAPST6")
|
||||
D NOW^%DTC S GMRADPDT=X
|
||||
S GMRADATE=GMAST-.0001,GMRAPG=1
|
||||
F S GMRADATE=$O(^GMR(120.85,"B",GMRADATE)) Q:GMRADATE<1 Q:GMRADATE>GMAEN D
|
||||
.S GMRAPA1=0 F S GMRAPA1=$O(^GMR(120.85,"B",GMRADATE,GMRAPA1)) Q:GMRAPA1<1 D
|
||||
..S GMRAPA1(0)=$G(^GMR(120.85,GMRAPA1,0)) Q:GMRAPA1(0)="" ;Bad Node
|
||||
..S GMRADDT=$P(GMRAPA1(0),U) ; reaction date
|
||||
..S GMRAPA=$P(GMRAPA1(0),U,15) ; Get the 120.8 entry for this reaction in 120.85
|
||||
..S GMRAPA(0)=$G(^GMR(120.8,GMRAPA,0)) Q:GMRAPA(0)="" ; Bad node
|
||||
..Q:+$G(^GMR(120.8,GMRAPA,"ER")) ;entered in error data
|
||||
..S GMRACA=$P(GMRAPA(0),U,2) ; Causative Agent
|
||||
..S DFN=$P(GMRAPA(0),U),GMRACA=$E(GMRACA,1,22)_"-"_$E($P(^DPT(DFN,0),U),1)_$E($P(^(0),U,9),6,9)
|
||||
..S ^TMP($J,"GMRAPST6",GMRADDT,GMRACA,GMRAPA1)=""
|
||||
..Q
|
||||
.Q
|
||||
Q:GMRAOUT
|
||||
I '$D(^TMP($J,"GMRAPST6")) D HEAD W !,"NO DATA FOR THIS REPORT..." Q
|
||||
S GMRAOTH=$G(GMRAOTH,$O(^GMRD(120.83,"B","OTHER REACTION",0)))
|
||||
S GMRADDT=0
|
||||
F S GMRADDT=$O(^TMP($J,"GMRAPST6",GMRADDT)) Q:GMRADDT<1 D Q:GMRAOUT
|
||||
.S GMRACA=""
|
||||
.F S GMRACA=$O(^TMP($J,"GMRAPST6",GMRADDT,GMRACA)) Q:GMRACA="" D Q:GMRAOUT
|
||||
..S GMRAPA1=0
|
||||
..F S GMRAPA1=$O(^TMP($J,"GMRAPST6",GMRADDT,GMRACA,GMRAPA1)) Q:GMRAPA1<1 D Q:GMRAOUT
|
||||
...S GMRAPA1(0)=$G(^GMR(120.85,GMRAPA1,0))
|
||||
...Q:GMRAPA(0)=""
|
||||
...D HEAD Q:GMRAOUT
|
||||
...W !,$J($$FMTE^XLFDT(GMRADDT,"2D"),8) ; Obs Date
|
||||
...W ?8,"|",GMRACA ; Causative Agent
|
||||
...W ?38,"|"
|
||||
...S GMRAREC=0
|
||||
...S GMRAREC=$O(^GMR(120.85,GMRAPA1,2,0)) D:GMRAREC>0 SIGN("0",GMRAREC)
|
||||
...W ?58,"|" W:$P(GMRAPA1(0),U,4)="y" " Y" ; Req Tx with Rx
|
||||
...W ?63,"|" W:$P(GMRAPA1(0),U,7)="y" " Y" ; Req Hosp.
|
||||
...W ?68,"|" W:$P(GMRAPA1(0),U,10)="y" " Y" ; Disability
|
||||
...W ?73,"|" W:$P(GMRAPA1(0),U,3)="y" " Y" ; Death
|
||||
...F S GMRAREC=$O(^GMR(120.85,GMRAPA1,2,GMRAREC)) Q:GMRAREC<1 D SIGN("1",GMRAREC) Q:GMRAOUT
|
||||
...Q:GMRAOUT
|
||||
...D HEAD Q:GMRAOUT W !,?8,"|",?38,"|",?58,"|",?63,"|",?68,"|",?73,"|"
|
||||
...Q
|
||||
..Q
|
||||
.Q
|
||||
D CLOSE^GMRAUTL
|
||||
Q
|
||||
SIGN(CNT,GMRAREC) ; Print Sign/Symptoms
|
||||
N NAM,Y
|
||||
S Y=$G(^GMR(120.85,GMRAPA1,2,GMRAREC,0))
|
||||
S NAM=$S(+Y=GMRAOTH:$P(Y,U,2),$D(^GMRD(120.83,+Y,0)):$P(^GMRD(120.83,+Y,0),U),1:"")
|
||||
I 'CNT W $E(NAM,1,19)
|
||||
E D HEAD Q:GMRAOUT W !,?8,"|",?38,"|",$E(NAM,1,19),?58,"|",?63,"|",?68,"|",?73,"|"
|
||||
Q
|
||||
HEAD ; Print header information
|
||||
I GMRAPG'=1 Q:$Y<(IOSL-4)
|
||||
I $E(IOST,1)="C" D Q:GMRAOUT
|
||||
.I GMRAPG=1 W @IOF Q
|
||||
.I GMRAPG'=1 D Q:GMRAOUT
|
||||
..N DIR S DIR(0)="E" D ^DIR I 'Y S GMRAOUT=1
|
||||
..K Y
|
||||
..Q
|
||||
.Q
|
||||
Q:GMRAOUT
|
||||
I GMRAPG'=1 W @IOF
|
||||
W "Report Date: ",$P($$FMTE^XLFDT(GMRADPDT),"@"),?70,"Page: ",GMRAPG
|
||||
W !,?22,"P&T Committee ADR Outcome Report"
|
||||
W !,?25,"From: ",$$FMTE^XLFDT(GMAST,"2D")," To: ",$$FMTE^XLFDT(GMAEN,"2D")
|
||||
W !,$$REPEAT^XLFSTR("-",79)
|
||||
W !,"Obsv.",?8,"|",?38,"|",?58,"|Req.",?63,"|Req.",?68,"|",?73,"|"
|
||||
W !,"Date",?8,"|Causative agent-Pat. ID",?38,"|Sign/Symptoms",?58,"|Tx",?63,"|Hosp",?68,"|Dis.",?73,"|Death"
|
||||
W !,$$REPEAT^XLFSTR("-",79)
|
||||
S GMRAPG=GMRAPG+1
|
||||
I $D(ZTQUEUED) S:$$STPCK^GMRAUTL1 GMRAOUT=1 ; Check if stopped by user
|
||||
Q
|
||||
|
|
|
|||
|
|
@ -1,112 +1,111 @@
|
|||
GMRAPST7 ;HIRMFO/WAA- ADVERSE DRUG REACTION REPORT ;3/5/97 15:17
|
||||
;;4.0;Adverse Reaction Tracking;**7,33**;Mar 29, 1996;Build 5
|
||||
EN1 ; This routine will loop through the ADT entry point to get all
|
||||
; the entries in that date range.
|
||||
S GMRAOUT=0
|
||||
W !,"Select an Observed date range for this report."
|
||||
D DT^GMRAPL G:GMRAOUT EXIT
|
||||
D PRINTER
|
||||
EXIT ; Exit of program kill cleanup
|
||||
D KILL^XUSCLEAN
|
||||
K ^TMP($J,"GMRAPST7")
|
||||
Q
|
||||
PRINTER ;Select printer
|
||||
W !!,"This report required a 132 column printer."
|
||||
K GMRAZIS S GMRAZIS="M132" D DEV^GMRAUTL I POP W !,"PLEASE TRY LATER" S GMRAOUT=1 Q
|
||||
I $D(IO("Q")) D Q
|
||||
. S ZTRTN="PRINT^GMRAPST7",(ZTSAVE("GMRAOUT"),ZTSAVE("GMAST"),ZTSAVE("GMAEN"))=""
|
||||
. S ZTDESC="P&T Committee ADR Report" D ^%ZTLOAD
|
||||
. W !!,$S($D(ZTSK):"Request queued...",1:"Request NOT queued please try Later.")
|
||||
. Q
|
||||
U IO D PRINT U IO(0)
|
||||
Q
|
||||
PRINT ;Queue point for report
|
||||
;loop through the 120.85 file and look for the field that
|
||||
K ^TMP($J,"GMRAPST7")
|
||||
D NOW^%DTC S GMRADPDT=X
|
||||
S GMRADATE=GMAST-.0001,GMRAPG=1
|
||||
F S GMRADATE=$O(^GMR(120.85,"B",GMRADATE)) Q:GMRADATE<1 Q:GMRADATE>GMAEN D
|
||||
.S GMRAPA1=0 F S GMRAPA1=$O(^GMR(120.85,"B",GMRADATE,GMRAPA1)) Q:GMRAPA1<1 D
|
||||
..S GMRAPA1(0)=$G(^GMR(120.85,GMRAPA1,0)) Q:GMRAPA1(0)="" ;Bad Node
|
||||
..S GMRADDT=$P(GMRAPA1(0),U) ; reaction date
|
||||
..S GMRAPA=$P(GMRAPA1(0),U,15) ; Get the 120.8 entry for this reaction in 120.85
|
||||
..S GMRAPA(0)=$G(^GMR(120.8,GMRAPA,0)) Q:GMRAPA(0)="" ; Bad node
|
||||
..Q:+$G(^GMR(120.8,GMRAPA,"ER")) ;Entered in error data
|
||||
..S GMRACA=$P(GMRAPA(0),U,2) ; Causative Agent
|
||||
..S DFN=$P(GMRAPA(0),U),GMRACA=$E(GMRACA,1,22)_"-"_$E($P(^DPT(DFN,0),U),1)_$E($P(^(0),U,9),6,9)
|
||||
..Q:'$$PRDTST^GMRAUTL1(DFN) ;GMRA*4*33 Exclude test patients from report if production or legacy environment.
|
||||
..S ^TMP($J,"GMRAPST7",GMRADDT,GMRACA,GMRAPA1)=GMRAPA
|
||||
..Q
|
||||
.Q
|
||||
Q:GMRAOUT
|
||||
I '$D(^TMP($J,"GMRAPST7")) D HEAD W !,"NO DATA FOR THIS REPORT..." Q
|
||||
S GMRAOTH=$G(GMRAOTH,$O(^GMRD(120.83,"B","OTHER REACTION",0)))
|
||||
S GMRADDT=0
|
||||
F S GMRADDT=$O(^TMP($J,"GMRAPST7",GMRADDT)) Q:GMRADDT<1 D Q:GMRAOUT
|
||||
.S GMRACA=""
|
||||
.F S GMRACA=$O(^TMP($J,"GMRAPST7",GMRADDT,GMRACA)) Q:GMRACA="" D Q:GMRAOUT
|
||||
..S GMRAPA1=0
|
||||
..F S GMRAPA1=$O(^TMP($J,"GMRAPST7",GMRADDT,GMRACA,GMRAPA1)) Q:GMRAPA1<1 D Q:GMRAOUT
|
||||
...S GMRAPA=$G(^TMP($J,"GMRAPST7",GMRADDT,GMRACA,GMRAPA1))
|
||||
...Q:GMRAPA=""
|
||||
...S GMRAPA1(0)=$G(^GMR(120.85,GMRAPA1,0))
|
||||
...Q:GMRAPA1(0)=""
|
||||
...S GMRAPA(0)=$G(^GMR(120.8,GMRAPA,0))
|
||||
...Q:GMRAPA(0)=""
|
||||
...D HEAD Q:GMRAOUT
|
||||
...W !,$J($$FMTE^XLFDT(GMRADDT,"2D"),8) ; Obs Date
|
||||
...W ?8,"|",GMRACA ; Causative Agent
|
||||
...W ?38,"|"
|
||||
...S GMRAREC=0
|
||||
...S GMRAREC=$O(^GMR(120.85,GMRAPA1,2,0)) D:GMRAREC>0 SIGN("0",GMRAREC)
|
||||
...W ?58,"| " W $P(GMRAPA(0),U,14) ; Mechanism
|
||||
...W ?63,"|" W $S($P(GMRAPA1(0),U,14)=1:"MILD",$P(GMRAPA1(0),U,14)=2:"MOD.",$P(GMRAPA1(0),U,14)=3:"SVR.",1:"") ; Severity
|
||||
...W ?68,"|"
|
||||
...K ^TMP($J,"GMRAWORD") D WORD^GMRAWORD(GMRAPA,"OVE",60)
|
||||
...S GMRACNT=1 W $G(^TMP($J,"GMRAWORD",GMRACNT))
|
||||
...F S GMRAREC=$O(^GMR(120.85,GMRAPA1,2,GMRAREC)) Q:GMRAREC<1 D SIGN("1",GMRAREC) Q:GMRAOUT
|
||||
...F S GMRACNT=$O(^TMP($J,"GMRAWORD",GMRACNT)) Q:GMRACNT<1 D Q:GMRAOUT
|
||||
....D HEAD Q:GMRAOUT W !,?8,"|",?38,"|",?58,"|",?63,"|",?68,"|"
|
||||
....Q:GMRAOUT
|
||||
....W $G(^TMP($J,"GMRAWORD",GMRACNT))
|
||||
....Q
|
||||
...K ^TMP($J,"GMRAWORD")
|
||||
...Q:GMRAOUT
|
||||
...D HEAD Q:GMRAOUT W !,?8,"|",?38,"|",?58,"|",?63,"|",?68,"|"
|
||||
...Q
|
||||
..Q
|
||||
.Q
|
||||
D CLOSE^GMRAUTL
|
||||
Q
|
||||
SIGN(CNT,GMRAREC) ; Print Sign/Symptoms
|
||||
N NAM,Y
|
||||
S Y=$G(^GMR(120.85,GMRAPA1,2,GMRAREC,0))
|
||||
S NAM=$S(+Y=GMRAOTH:$P(Y,U,2),$D(^GMRD(120.83,+Y,0)):$P(^GMRD(120.83,+Y,0),U),1:"")
|
||||
I 'CNT W $E(NAM,1,19)
|
||||
E D
|
||||
.D HEAD Q:GMRAOUT W !,?8,"|",?38,"|",$E(NAM,1,19),?58,"|",?63,"|",?68,"|"
|
||||
.I $D(^TMP($J,"GMRAWORD",(GMRACNT+1))) S GMRACNT=GMRACNT+1 W $G(^TMP($J,"GMRAWORD",GMRACNT))
|
||||
.Q
|
||||
Q
|
||||
HEAD ; Print header information
|
||||
I GMRAPG'=1 Q:$Y<(IOSL-4)
|
||||
I $E(IOST,1)="C" D Q:GMRAOUT
|
||||
.I GMRAPG=1 W @IOF Q
|
||||
.I GMRAPG'=1 D Q:GMRAOUT
|
||||
..N DIR S DIR(0)="E" D ^DIR I 'Y S GMRAOUT=1
|
||||
..K Y
|
||||
..Q
|
||||
.Q
|
||||
Q:GMRAOUT
|
||||
I GMRAPG'=1 W @IOF
|
||||
N Z
|
||||
W "Report Date: ",$P($$FMTE^XLFDT(GMRADPDT),"@"),?125,"Page: ",GMRAPG
|
||||
W !,?48,"P&T Committee ADR Report"
|
||||
W !,?51,"From: ",$$FMTE^XLFDT(GMAST,"2D")," To: ",$$FMTE^XLFDT(GMAEN,"2D")
|
||||
W !,$$REPEAT^XLFSTR("-",130)
|
||||
W !,"Obsv.",?8,"|",?38,"|",?58,"|ADR",?63,"|ADR",?68,"|"
|
||||
W !,"Date",?8,"|Causative agent-Pat. ID",?38,"|Sign/Symptoms",?58,"|Mech",?63,"|Svr.",?68,"|Comments"
|
||||
W !,$$REPEAT^XLFSTR("-",130)
|
||||
S GMRAPG=GMRAPG+1
|
||||
I $D(ZTQUEUED) S:$$STPCK^GMRAUTL1 GMRAOUT=1 ; Check if stopped by user
|
||||
Q
|
||||
GMRAPST7 ;HIRMFO/WAA- ADVERSE DRUG REACTION REPORT ;3/5/97 15:17
|
||||
;;4.0;Adverse Reaction Tracking;**7**;Mar 29, 1996
|
||||
EN1 ; This routine will loop through the ADT entry point to get all
|
||||
; the entries in that date range.
|
||||
S GMRAOUT=0
|
||||
W !,"Select an Observed date range for this report."
|
||||
D DT^GMRAPL G:GMRAOUT EXIT
|
||||
D PRINTER
|
||||
EXIT ; Exit of program kill cleanup
|
||||
D KILL^XUSCLEAN
|
||||
K ^TMP($J,"GMRAPST7")
|
||||
Q
|
||||
PRINTER ;Select printer
|
||||
W !!,"This report required a 132 column printer."
|
||||
K GMRAZIS S GMRAZIS="M132" D DEV^GMRAUTL I POP W !,"PLEASE TRY LATER" S GMRAOUT=1 Q
|
||||
I $D(IO("Q")) D Q
|
||||
. S ZTRTN="PRINT^GMRAPST7",(ZTSAVE("GMRAOUT"),ZTSAVE("GMAST"),ZTSAVE("GMAEN"))=""
|
||||
. S ZTDESC="P&T Committee ADR Report" D ^%ZTLOAD
|
||||
. W !!,$S($D(ZTSK):"Request queued...",1:"Request NOT queued please try Later.")
|
||||
. Q
|
||||
U IO D PRINT U IO(0)
|
||||
Q
|
||||
PRINT ;Queue point for report
|
||||
;loop through the 120.85 file and look for the field that
|
||||
K ^TMP($J,"GMRAPST7")
|
||||
D NOW^%DTC S GMRADPDT=X
|
||||
S GMRADATE=GMAST-.0001,GMRAPG=1
|
||||
F S GMRADATE=$O(^GMR(120.85,"B",GMRADATE)) Q:GMRADATE<1 Q:GMRADATE>GMAEN D
|
||||
.S GMRAPA1=0 F S GMRAPA1=$O(^GMR(120.85,"B",GMRADATE,GMRAPA1)) Q:GMRAPA1<1 D
|
||||
..S GMRAPA1(0)=$G(^GMR(120.85,GMRAPA1,0)) Q:GMRAPA1(0)="" ;Bad Node
|
||||
..S GMRADDT=$P(GMRAPA1(0),U) ; reaction date
|
||||
..S GMRAPA=$P(GMRAPA1(0),U,15) ; Get the 120.8 entry for this reaction in 120.85
|
||||
..S GMRAPA(0)=$G(^GMR(120.8,GMRAPA,0)) Q:GMRAPA(0)="" ; Bad node
|
||||
..Q:+$G(^GMR(120.8,GMRAPA,"ER")) ;Entered in error data
|
||||
..S GMRACA=$P(GMRAPA(0),U,2) ; Causative Agent
|
||||
..S DFN=$P(GMRAPA(0),U),GMRACA=$E(GMRACA,1,22)_"-"_$E($P(^DPT(DFN,0),U),1)_$E($P(^(0),U,9),6,9)
|
||||
..S ^TMP($J,"GMRAPST7",GMRADDT,GMRACA,GMRAPA1)=GMRAPA
|
||||
..Q
|
||||
.Q
|
||||
Q:GMRAOUT
|
||||
I '$D(^TMP($J,"GMRAPST7")) D HEAD W !,"NO DATA FOR THIS REPORT..." Q
|
||||
S GMRAOTH=$G(GMRAOTH,$O(^GMRD(120.83,"B","OTHER REACTION",0)))
|
||||
S GMRADDT=0
|
||||
F S GMRADDT=$O(^TMP($J,"GMRAPST7",GMRADDT)) Q:GMRADDT<1 D Q:GMRAOUT
|
||||
.S GMRACA=""
|
||||
.F S GMRACA=$O(^TMP($J,"GMRAPST7",GMRADDT,GMRACA)) Q:GMRACA="" D Q:GMRAOUT
|
||||
..S GMRAPA1=0
|
||||
..F S GMRAPA1=$O(^TMP($J,"GMRAPST7",GMRADDT,GMRACA,GMRAPA1)) Q:GMRAPA1<1 D Q:GMRAOUT
|
||||
...S GMRAPA=$G(^TMP($J,"GMRAPST7",GMRADDT,GMRACA,GMRAPA1))
|
||||
...Q:GMRAPA=""
|
||||
...S GMRAPA1(0)=$G(^GMR(120.85,GMRAPA1,0))
|
||||
...Q:GMRAPA1(0)=""
|
||||
...S GMRAPA(0)=$G(^GMR(120.8,GMRAPA,0))
|
||||
...Q:GMRAPA(0)=""
|
||||
...D HEAD Q:GMRAOUT
|
||||
...W !,$J($$FMTE^XLFDT(GMRADDT,"2D"),8) ; Obs Date
|
||||
...W ?8,"|",GMRACA ; Causative Agent
|
||||
...W ?38,"|"
|
||||
...S GMRAREC=0
|
||||
...S GMRAREC=$O(^GMR(120.85,GMRAPA1,2,0)) D:GMRAREC>0 SIGN("0",GMRAREC)
|
||||
...W ?58,"| " W $P(GMRAPA(0),U,14) ; Mechanism
|
||||
...W ?63,"|" W $S($P(GMRAPA1(0),U,14)=1:"MILD",$P(GMRAPA1(0),U,14)=2:"MOD.",$P(GMRAPA1(0),U,14)=3:"SVR.",1:"") ; Severity
|
||||
...W ?68,"|"
|
||||
...K ^TMP($J,"GMRAWORD") D WORD^GMRAWORD(GMRAPA,"OVE",60)
|
||||
...S GMRACNT=1 W $G(^TMP($J,"GMRAWORD",GMRACNT))
|
||||
...F S GMRAREC=$O(^GMR(120.85,GMRAPA1,2,GMRAREC)) Q:GMRAREC<1 D SIGN("1",GMRAREC) Q:GMRAOUT
|
||||
...F S GMRACNT=$O(^TMP($J,"GMRAWORD",GMRACNT)) Q:GMRACNT<1 D Q:GMRAOUT
|
||||
....D HEAD Q:GMRAOUT W !,?8,"|",?38,"|",?58,"|",?63,"|",?68,"|"
|
||||
....Q:GMRAOUT
|
||||
....W $G(^TMP($J,"GMRAWORD",GMRACNT))
|
||||
....Q
|
||||
...K ^TMP($J,"GMRAWORD")
|
||||
...Q:GMRAOUT
|
||||
...D HEAD Q:GMRAOUT W !,?8,"|",?38,"|",?58,"|",?63,"|",?68,"|"
|
||||
...Q
|
||||
..Q
|
||||
.Q
|
||||
D CLOSE^GMRAUTL
|
||||
Q
|
||||
SIGN(CNT,GMRAREC) ; Print Sign/Symptoms
|
||||
N NAM,Y
|
||||
S Y=$G(^GMR(120.85,GMRAPA1,2,GMRAREC,0))
|
||||
S NAM=$S(+Y=GMRAOTH:$P(Y,U,2),$D(^GMRD(120.83,+Y,0)):$P(^GMRD(120.83,+Y,0),U),1:"")
|
||||
I 'CNT W $E(NAM,1,19)
|
||||
E D
|
||||
.D HEAD Q:GMRAOUT W !,?8,"|",?38,"|",$E(NAM,1,19),?58,"|",?63,"|",?68,"|"
|
||||
.I $D(^TMP($J,"GMRAWORD",(GMRACNT+1))) S GMRACNT=GMRACNT+1 W $G(^TMP($J,"GMRAWORD",GMRACNT))
|
||||
.Q
|
||||
Q
|
||||
HEAD ; Print header information
|
||||
I GMRAPG'=1 Q:$Y<(IOSL-4)
|
||||
I $E(IOST,1)="C" D Q:GMRAOUT
|
||||
.I GMRAPG=1 W @IOF Q
|
||||
.I GMRAPG'=1 D Q:GMRAOUT
|
||||
..N DIR S DIR(0)="E" D ^DIR I 'Y S GMRAOUT=1
|
||||
..K Y
|
||||
..Q
|
||||
.Q
|
||||
Q:GMRAOUT
|
||||
I GMRAPG'=1 W @IOF
|
||||
N Z
|
||||
W "Report Date: ",$P($$FMTE^XLFDT(GMRADPDT),"@"),?125,"Page: ",GMRAPG
|
||||
W !,?48,"P&T Committee ADR Report"
|
||||
W !,?51,"From: ",$$FMTE^XLFDT(GMAST,"2D")," To: ",$$FMTE^XLFDT(GMAEN,"2D")
|
||||
W !,$$REPEAT^XLFSTR("-",130)
|
||||
W !,"Obsv.",?8,"|",?38,"|",?58,"|ADR",?63,"|ADR",?68,"|"
|
||||
W !,"Date",?8,"|Causative agent-Pat. ID",?38,"|Sign/Symptoms",?58,"|Mech",?63,"|Svr.",?68,"|Comments"
|
||||
W !,$$REPEAT^XLFSTR("-",130)
|
||||
S GMRAPG=GMRAPG+1
|
||||
I $D(ZTQUEUED) S:$$STPCK^GMRAUTL1 GMRAOUT=1 ; Check if stopped by user
|
||||
Q
|
||||
|
|
|
|||
|
|
@ -1,81 +1,80 @@
|
|||
GMRAPU ;HIRMFO/WAA- PRINT ALLERGY LIST BY LOCATION UNVERIFIED ;8/27/93
|
||||
;;4.0;Adverse Reaction Tracking;**33**;Mar 29, 1996;Build 5
|
||||
EN1 ; This routine will loop through the GMRA patient allergy file (120.8)
|
||||
; to find all patients with unverified reactions
|
||||
;
|
||||
S GMRAOUT=0 D PRINTER
|
||||
EXIT ; Exit of program kill cleanup
|
||||
D KILL^XUSCLEAN
|
||||
K ^TMP($J,"GMRAPU")
|
||||
Q
|
||||
PRINTER ;Select printer
|
||||
W ! K GMRAZIS D DEV^GMRAUTL I POP W !,"PLEASE TRY LATER" S GMRAOUT=1 Q
|
||||
I $D(IO("Q")) D Q
|
||||
. S ZTRTN="PRINT^GMRAPU",ZTSAVE("GMRAOUT")=""
|
||||
. S ZTDESC="List of Unverified Reactions by Ward Location" D ^%ZTLOAD
|
||||
. W !!,$S($D(ZTSK):"Request queued...",1:"Request NOT queued please try Later.")
|
||||
. Q
|
||||
U IO D PRINT U IO(0)
|
||||
Q
|
||||
PRINT ;Queue point for report
|
||||
K ^TMP($J,"GMRAPU") D FIND
|
||||
REPORT ; Print out the report
|
||||
S GMRAOUT=$G(GMRAOUT)
|
||||
S GMALOC="",GMRAPG=1,GMRADATE=$$NOW^XLFDT
|
||||
I '$D(^TMP($J,"GMRAPU")) D HEAD W !,?20,"NO DATA FOR THIS REPORT"
|
||||
F S GMALOC=$O(^TMP($J,"GMRAPU",GMALOC)) Q:GMALOC="" D HEAD Q:GMRAOUT D Q:GMRAOUT
|
||||
.S GMRANAM="" F S GMRANAM=$O(^TMP($J,"GMRAPU",GMALOC,GMRANAM)) Q:GMRANAM="" D Q:GMRAOUT
|
||||
..S GMADFN=0 F S GMADFN=$O(^TMP($J,"GMRAPU",GMALOC,GMRANAM,GMADFN)) Q:GMADFN<1 D Q:GMRAOUT
|
||||
...S GMRASSN="",GMRARB=""
|
||||
...D VAD^GMRAUTL1(GMADFN,"","","","",.GMRASSN,.GMRARB)
|
||||
...W !,GMRARB,$S(GMRARB'="":" ",1:""),GMRANAM," (",GMRASSN,")"
|
||||
...S GMADT=0 F S GMADT=$O(^TMP($J,"GMRAPU",GMALOC,GMRANAM,GMADFN,GMADT)) Q:GMADT<1 S GMRAPA=0 F S GMRAPA=$O(^TMP($J,"GMRAPU",GMALOC,GMRANAM,GMADFN,GMADT,GMRAPA)) Q:GMRAPA<1 D Q:GMRAOUT
|
||||
....S GMRAPA(0)=$G(^GMR(120.8,GMRAPA,0))
|
||||
....Q:GMRAPA(0)=""
|
||||
....W !,?3,$$FMTE^XLFDT(GMADT,"1")
|
||||
....W ?30,$S($P(GMRAPA(0),U,5)'="":$E($P($G(^VA(200,$P(GMRAPA(0),U,5),0)),U),1,24),1:"<None>")
|
||||
....W ?55,$E($P(GMRAPA(0),U,2),1,24)
|
||||
....I $Y>(IOSL-4) D HEAD
|
||||
....Q
|
||||
...Q
|
||||
..Q
|
||||
.Q
|
||||
D CLOSE^GMRAUTL
|
||||
Q
|
||||
HEAD ; Print header information
|
||||
I $E(IOST,1)="C" D Q:GMRAOUT
|
||||
.I GMRAPG=1 W @IOF Q
|
||||
.I GMRAPG'=1 D Q:GMRAOUT
|
||||
..N DIR S DIR(0)="E" D ^DIR I 'Y S GMRAOUT=1
|
||||
..K Y
|
||||
..Q
|
||||
.Q
|
||||
Q:GMRAOUT
|
||||
I GMRAPG'=1 W @IOF
|
||||
W "Report Date: ",$P($$FMTE^XLFDT(GMRADATE),"@"),?70,"Page: ",GMRAPG
|
||||
W !,?19,"List of Unverified Reactions by Ward Location"
|
||||
W !,?30,"Ward Location: ",GMALOC
|
||||
W !,?3,"Origination Date/Time",?30,"Originator",?55,"Reaction"
|
||||
W !,$$REPEAT^XLFSTR("-",78)
|
||||
S GMRAPG=GMRAPG+1
|
||||
I $D(ZTQUEUED) S:$$STPCK^GMRAUTL1 GMRAOUT=1 ; Check if stopped by user
|
||||
Q
|
||||
FIND ; This subroutines will build the data for the report.
|
||||
N GMADFN
|
||||
S GMADFN=0
|
||||
F S GMADFN=$O(^GMR(120.8,"AVER",GMADFN)) Q:GMADFN<1 D
|
||||
.N GMRALOC,GMRANAM,GMALOC,GMRAPA
|
||||
.S GMRANAM="",GMRALOC=""
|
||||
.Q:'$$PRDTST^GMRAUTL1(GMADFN) ;GMRA*4*33 Exclude test patients if production or legacy environment.
|
||||
.D VAD^GMRAUTL1(GMADFN,"",.GMRALOC,.GMRANAM,"","","") I GMRALOC="" S GMALOC="OUTPATIENT"
|
||||
.E S GMALOC=$P($G(^DIC(42,GMRALOC,0)),U)
|
||||
.Q:GMALOC=""
|
||||
.S GMRAPA=0
|
||||
.F S GMRAPA=$O(^GMR(120.8,"AVER",GMADFN,GMRAPA)) Q:GMRAPA<1 D
|
||||
..N GMADT
|
||||
..S GMRAPA(0)=$G(^GMR(120.8,GMRAPA,0)) Q:GMRAPA(0)=""
|
||||
..S GMADT=$P(GMRAPA(0),U,4)
|
||||
..S ^TMP($J,"GMRAPU",GMALOC,GMRANAM,GMADFN,GMADT,GMRAPA)=""
|
||||
..Q
|
||||
.Q
|
||||
Q
|
||||
GMRAPU ;HIRMFO/WAA- PRINT ALLERGY LIST BY LOCATION UNVERIFIED ; 8/27/93
|
||||
;;4.0;Adverse Reaction Tracking;;Mar 29, 1996
|
||||
EN1 ; This routine will loop through the GMRA patient allergy file (120.8)
|
||||
; to find all patients with unverified reactions
|
||||
;
|
||||
S GMRAOUT=0 D PRINTER
|
||||
EXIT ; Exit of program kill cleanup
|
||||
D KILL^XUSCLEAN
|
||||
K ^TMP($J,"GMRAPU")
|
||||
Q
|
||||
PRINTER ;Select printer
|
||||
W ! K GMRAZIS D DEV^GMRAUTL I POP W !,"PLEASE TRY LATER" S GMRAOUT=1 Q
|
||||
I $D(IO("Q")) D Q
|
||||
. S ZTRTN="PRINT^GMRAPU",ZTSAVE("GMRAOUT")=""
|
||||
. S ZTDESC="List of Unverified Reactions by Ward Location" D ^%ZTLOAD
|
||||
. W !!,$S($D(ZTSK):"Request queued...",1:"Request NOT queued please try Later.")
|
||||
. Q
|
||||
U IO D PRINT U IO(0)
|
||||
Q
|
||||
PRINT ;Queue point for report
|
||||
K ^TMP($J,"GMRAPU") D FIND
|
||||
REPORT ; Print out the report
|
||||
S GMRAOUT=$G(GMRAOUT)
|
||||
S GMALOC="",GMRAPG=1,GMRADATE=$$NOW^XLFDT
|
||||
I '$D(^TMP($J,"GMRAPU")) D HEAD W !,?20,"NO DATA FOR THIS REPORT"
|
||||
F S GMALOC=$O(^TMP($J,"GMRAPU",GMALOC)) Q:GMALOC="" D HEAD Q:GMRAOUT D Q:GMRAOUT
|
||||
.S GMRANAM="" F S GMRANAM=$O(^TMP($J,"GMRAPU",GMALOC,GMRANAM)) Q:GMRANAM="" D Q:GMRAOUT
|
||||
..S GMADFN=0 F S GMADFN=$O(^TMP($J,"GMRAPU",GMALOC,GMRANAM,GMADFN)) Q:GMADFN<1 D Q:GMRAOUT
|
||||
...S GMRASSN="",GMRARB=""
|
||||
...D VAD^GMRAUTL1(GMADFN,"","","","",.GMRASSN,.GMRARB)
|
||||
...W !,GMRARB,$S(GMRARB'="":" ",1:""),GMRANAM," (",GMRASSN,")"
|
||||
...S GMADT=0 F S GMADT=$O(^TMP($J,"GMRAPU",GMALOC,GMRANAM,GMADFN,GMADT)) Q:GMADT<1 S GMRAPA=0 F S GMRAPA=$O(^TMP($J,"GMRAPU",GMALOC,GMRANAM,GMADFN,GMADT,GMRAPA)) Q:GMRAPA<1 D Q:GMRAOUT
|
||||
....S GMRAPA(0)=$G(^GMR(120.8,GMRAPA,0))
|
||||
....Q:GMRAPA(0)=""
|
||||
....W !,?3,$$FMTE^XLFDT(GMADT,"1")
|
||||
....W ?30,$S($P(GMRAPA(0),U,5)'="":$E($P($G(^VA(200,$P(GMRAPA(0),U,5),0)),U),1,24),1:"<None>")
|
||||
....W ?55,$E($P(GMRAPA(0),U,2),1,24)
|
||||
....I $Y>(IOSL-4) D HEAD
|
||||
....Q
|
||||
...Q
|
||||
..Q
|
||||
.Q
|
||||
D CLOSE^GMRAUTL
|
||||
Q
|
||||
HEAD ; Print header information
|
||||
I $E(IOST,1)="C" D Q:GMRAOUT
|
||||
.I GMRAPG=1 W @IOF Q
|
||||
.I GMRAPG'=1 D Q:GMRAOUT
|
||||
..N DIR S DIR(0)="E" D ^DIR I 'Y S GMRAOUT=1
|
||||
..K Y
|
||||
..Q
|
||||
.Q
|
||||
Q:GMRAOUT
|
||||
I GMRAPG'=1 W @IOF
|
||||
W "Report Date: ",$P($$FMTE^XLFDT(GMRADATE),"@"),?70,"Page: ",GMRAPG
|
||||
W !,?19,"List of Unverified Reactions by Ward Location"
|
||||
W !,?30,"Ward Location: ",GMALOC
|
||||
W !,?3,"Origination Date/Time",?30,"Originator",?55,"Reaction"
|
||||
W !,$$REPEAT^XLFSTR("-",78)
|
||||
S GMRAPG=GMRAPG+1
|
||||
I $D(ZTQUEUED) S:$$STPCK^GMRAUTL1 GMRAOUT=1 ; Check if stopped by user
|
||||
Q
|
||||
FIND ; This subroutines will build the data for the report.
|
||||
N GMADFN
|
||||
S GMADFN=0
|
||||
F S GMADFN=$O(^GMR(120.8,"AVER",GMADFN)) Q:GMADFN<1 D
|
||||
.N GMRALOC,GMRANAM,GMALOC,GMRAPA
|
||||
.S GMRANAM="",GMRALOC=""
|
||||
.D VAD^GMRAUTL1(GMADFN,"",.GMRALOC,.GMRANAM,"","","") I GMRALOC="" S GMALOC="OUTPATIENT"
|
||||
.E S GMALOC=$P($G(^DIC(42,GMRALOC,0)),U)
|
||||
.Q:GMALOC=""
|
||||
.S GMRAPA=0
|
||||
.F S GMRAPA=$O(^GMR(120.8,"AVER",GMADFN,GMRAPA)) Q:GMRAPA<1 D
|
||||
..N GMADT
|
||||
..S GMRAPA(0)=$G(^GMR(120.8,GMRAPA,0)) Q:GMRAPA(0)=""
|
||||
..S GMADT=$P(GMRAPA(0),U,4)
|
||||
..S ^TMP($J,"GMRAPU",GMALOC,GMRANAM,GMADFN,GMADT,GMRAPA)=""
|
||||
..Q
|
||||
.Q
|
||||
Q
|
||||
|
|
|
|||
|
|
@ -1,88 +1,74 @@
|
|||
GMRAUTL1 ;HIRMFO/WAA-ALLERGY UTILITIES ;12/04/92
|
||||
;;4.0;Adverse Reaction Tracking;**33**;Mar 29, 1996;Build 5
|
||||
;
|
||||
; Reference to $$PROD^XUPROD supported by DBIA 4440
|
||||
; Reference to $$TESTPAT^VADPT supported by DBIA 3744
|
||||
;
|
||||
Q
|
||||
STPCK() ; This is to check to see if the user wanted to stop the print
|
||||
S ZTSTOP=0
|
||||
I $$S^%ZTLOAD D
|
||||
.S ZTSTOP=1 K ZTREG W !?10,"*** OUTPUT STOPPED AT USER'S REQUEST ***"
|
||||
.Q
|
||||
Q ZTSTOP
|
||||
BR ; This is a online reference card entry point
|
||||
I '$$TEST^DDBRT D Q
|
||||
.W $C(7)
|
||||
.W !,?20,"Your Terminal cannot display this Reference Card."
|
||||
.W !,?20,"Please contact IRM Service to correct this problem."
|
||||
.Q
|
||||
N X
|
||||
S X=$O(^GMRD(120.87,"B","REFERENCE CARD",0)) Q:X<1
|
||||
D WP^DDBR(120.87,X,1)
|
||||
Q
|
||||
PR ; This is a print utility for the reference card for IRM
|
||||
W ! K GMRAZIS D DEV^GMRAUTL I POP W !,"PLEASE TRY LATER" S GMRAOUT=1 Q
|
||||
I $D(IO("Q")) D Q
|
||||
. S ZTRTN="PR1^GMRAUTL1",(ZTSAVE("GMRAOUT"),ZTSAVE("GMAST"),ZTSAVE("GMAEN"))=""
|
||||
. S ZTDESC="Print reference card" D ^%ZTLOAD
|
||||
. W !!,$S($D(ZTSK):"Request queued...",1:"Request NOT queued please try Later.")
|
||||
. Q
|
||||
U IO D PR1 U IO(0)
|
||||
Q
|
||||
PR1 ; Print out the card
|
||||
N GMRAOUT,GMRACD,GMRALN,X
|
||||
I $E(IOST,1)="C" W @IOF
|
||||
S GMRACD=$O(^GMRD(120.87,"B","REFERENCE CARD",0))
|
||||
S (GMRAOUT,GMRALN)=0
|
||||
LP1 ; Main loop
|
||||
F S GMRALN=$O(^GMRD(120.87,GMRACD,1,GMRALN)) Q:GMRALN<1 D Q:GMRAOUT
|
||||
.S X=$G(^GMRD(120.87,GMRACD,1,GMRALN,0))
|
||||
.W !,X
|
||||
.I $Y>(IOSL-4) D
|
||||
..I $E(IOST,1)="C" N DIR,DIRUT,DIROUT,DTOUT,DUOUT S DIR(0)="E" D ^DIR S:$D(DIRUT) GMRAOUT=1 W:'GMRAOUT @IOF Q
|
||||
..W @IOF
|
||||
..Q
|
||||
.Q
|
||||
D CLOSE^GMRAUTL
|
||||
Q
|
||||
PRDTST(GMRADFN) ; GMRA*4*33 - Remove Test Patients from Live Reports
|
||||
; This function will return 0 if the patient should not print on the report, and 1 if the patient
|
||||
; should appear on the report. This function will allow all patients to print on the report if the
|
||||
; report is run in a test environment.
|
||||
;
|
||||
I GMRADFN="" Q 0 ;DFN not defined. Should never be the case.
|
||||
I '$$PROD^XUPROD() Q 1 ;Not a production or legacy environment. Print all patients on report.
|
||||
I $$TESTPAT^VADPT(GMRADFN) Q 0 ;Production or legacy environment. Test patient. Do not print on report.
|
||||
Q 1 ;Production or legacy environment. Not a test patient. Print on report.
|
||||
;
|
||||
VAD(DFN,DAT,LOC,NAM,SEX,SSN,RB,PRO,PID) ; Call to VADPT
|
||||
; This call is a generic call to 1^VADPT
|
||||
; Input:
|
||||
; 1 DFN = Patient Internal entry number in the Patient File
|
||||
; 2 DAT = Date for lookup
|
||||
;
|
||||
; Output:
|
||||
; 3 LOC = Hospital Location
|
||||
; 4 NAM = Full Patient name
|
||||
; 5 SEX = Patient SEX
|
||||
; 6 SSN = Patient SSN
|
||||
; 7 RB = Patient Room Bed
|
||||
; 8 PRO = Patient Provider
|
||||
; 9 PID = Patient ID
|
||||
;
|
||||
S DFN=$G(DFN) Q:DFN=""
|
||||
S VAINDT=$G(DAT) I VAINDT="" K VAINDT
|
||||
D 1^VADPT
|
||||
S LOC=$P(VAIN(4),U),NAM=VADM(1),SEX=VADM(5)
|
||||
S SSN=$P(VADM(2),U,2),RB=VAIN(5),PID=VA("PID")
|
||||
S PRO=$P(VAIN(2),U,2)
|
||||
D KVAR^VADPT K VA,VAROOT
|
||||
Q
|
||||
DATE(DATE) ; This Ex-Function will date the date from the DATE
|
||||
; and convert it to the old DD("DD") style format
|
||||
; it returns the answer in DATE
|
||||
N Y
|
||||
S Y=$$FMTE^XLFDT(DATE,1)
|
||||
S DATE=$P(Y," ")_" "_(+$P($P(Y,",")," ",2))_","_$P(Y," ",3)
|
||||
Q DATE
|
||||
GMRAUTL1 ;HIRMFO/WAA-ALLERGY UTILITIES ; 12/04/92
|
||||
;;4.0;Adverse Reaction Tracking;;Mar 29, 1996
|
||||
Q
|
||||
STPCK() ; This is to check to see if the user wanted to stop the print
|
||||
S ZTSTOP=0
|
||||
I $$S^%ZTLOAD D
|
||||
.S ZTSTOP=1 K ZTREG W !?10,"*** OUTPUT STOPPED AT USER'S REQUEST ***"
|
||||
.Q
|
||||
Q ZTSTOP
|
||||
BR ; This is a online reference card entry point
|
||||
I '$$TEST^DDBRT D Q
|
||||
.W $C(7)
|
||||
.W !,?20,"Your Terminal cannot display this Reference Card."
|
||||
.W !,?20,"Please contact IRM Service to correct this problem."
|
||||
.Q
|
||||
N X
|
||||
S X=$O(^GMRD(120.87,"B","REFERENCE CARD",0)) Q:X<1
|
||||
D WP^DDBR(120.87,X,1)
|
||||
Q
|
||||
PR ; This is a print utility for the reference card for IRM
|
||||
W ! K GMRAZIS D DEV^GMRAUTL I POP W !,"PLEASE TRY LATER" S GMRAOUT=1 Q
|
||||
I $D(IO("Q")) D Q
|
||||
. S ZTRTN="PR1^GMRAUTL1",(ZTSAVE("GMRAOUT"),ZTSAVE("GMAST"),ZTSAVE("GMAEN"))=""
|
||||
. S ZTDESC="Print reference card" D ^%ZTLOAD
|
||||
. W !!,$S($D(ZTSK):"Request queued...",1:"Request NOT queued please try Later.")
|
||||
. Q
|
||||
U IO D PR1 U IO(0)
|
||||
Q
|
||||
PR1 ; Print out the card
|
||||
N GMRAOUT,GMRACD,GMRALN,X
|
||||
I $E(IOST,1)="C" W @IOF
|
||||
S GMRACD=$O(^GMRD(120.87,"B","REFERENCE CARD",0))
|
||||
S (GMRAOUT,GMRALN)=0
|
||||
LP1 ; Main loop
|
||||
F S GMRALN=$O(^GMRD(120.87,GMRACD,1,GMRALN)) Q:GMRALN<1 D Q:GMRAOUT
|
||||
.S X=$G(^GMRD(120.87,GMRACD,1,GMRALN,0))
|
||||
.W !,X
|
||||
.I $Y>(IOSL-4) D
|
||||
..I $E(IOST,1)="C" N DIR,DIRUT,DIROUT,DTOUT,DUOUT S DIR(0)="E" D ^DIR S:$D(DIRUT) GMRAOUT=1 W:'GMRAOUT @IOF Q
|
||||
..W @IOF
|
||||
..Q
|
||||
.Q
|
||||
D CLOSE^GMRAUTL
|
||||
Q
|
||||
VAD(DFN,DAT,LOC,NAM,SEX,SSN,RB,PRO,PID) ; Call to VADPT
|
||||
; This call is a generic call to 1^VADPT
|
||||
; Input:
|
||||
; 1 DFN = Patient Internal entry number in the Patient File
|
||||
; 2 DAT = Date for lookup
|
||||
;
|
||||
; Output:
|
||||
; 3 LOC = Hospital Location
|
||||
; 4 NAM = Full Patient name
|
||||
; 5 SEX = Patient SEX
|
||||
; 6 SSN = Patient SSN
|
||||
; 7 RB = Patient Room Bed
|
||||
; 8 PRO = Patient Provider
|
||||
; 9 PID = Patient ID
|
||||
;
|
||||
S DFN=$G(DFN) Q:DFN=""
|
||||
S VAINDT=$G(DAT) I VAINDT="" K VAINDT
|
||||
D 1^VADPT
|
||||
S LOC=$P(VAIN(4),U),NAM=VADM(1),SEX=VADM(5)
|
||||
S SSN=$P(VADM(2),U,2),RB=VAIN(5),PID=VA("PID")
|
||||
S PRO=$P(VAIN(2),U,2)
|
||||
D KVAR^VADPT K VA,VAROOT
|
||||
Q
|
||||
DATE(DATE) ; This Ex-Function will date the date from the DATE
|
||||
; and convert it to the old DD("DD") style format
|
||||
; it returns the answer in DATE
|
||||
N Y
|
||||
S Y=$$FMTE^XLFDT(DATE,1)
|
||||
S DATE=$P(Y," ")_" "_(+$P($P(Y,",")," ",2))_","_$P(Y," ",3)
|
||||
Q DATE
|
||||
|
|
|
|||
|
|
@ -1,33 +1,32 @@
|
|||
GMRAVFY ;HIRMFO/WAA,PWC-VERIFY AND SIGN OFF AN AGENT ; 5/23/07 10:32am
|
||||
;;4.0;Adverse Reaction Tracking;**2,33**;Mar 29, 1996;Build 5
|
||||
EN1 ;This is the main entry point for the verifier option.
|
||||
S GMRAVER=0,GMRADRUG=0
|
||||
I $P(GMRAPA(0),U,20)'["D" S GMRAFLAG=0 G VERIFY
|
||||
S GMRAFLAG=1,GMRADRUG=1
|
||||
I $P(GMRAPA(0),U,6)'="o" G VERIFY
|
||||
I '$D(GMRASITE) D SITE^GMRAUTL S GMRASITE(0)=$G(^GMRD(120.84,GMRASITE,0))
|
||||
I $P(^GMRD(120.84,+GMRASITE,0),U,7)'="y" G VERIFY
|
||||
I $D(^GMR(120.85,"C",GMRAPA)) G VERIFY
|
||||
W !,"Since this Causative Agent is an observed drug reaction and"
|
||||
W !,"FDA Data is required you must enter the Observer information"
|
||||
W !,"prior to verification."
|
||||
G EXIT
|
||||
VERIFY ;Verify an agent
|
||||
W !!,"Currently you have verifier access."
|
||||
F W !,"Would you like to verify this Causative Agent now" S %=1 D YN^DICN Q:%'=0 W !?4,"ANSWER YES IF YOU WOULD LIKE TO VERIFY THIS DATA, ELSE ANSWER NO."
|
||||
S:%=-1 GMRAOUT=1 G EXIT:%'=1 S GMRAVFY=1 W @IOF,! D SITE^GMRAUTL,EN2^GMRAPEV0 K GMRAVFY G:GMRAOUT EXIT
|
||||
I GMRAVER S GMRANAME=$P($G(^DPT(+GMRAPA(0),0)),U),GMRALLER=$P(GMRAPA(0),U,2) K:GMRANAME]""&(GMRALLER]"") ^TMP($J,"GMRADSP",GMRANAME,GMRALLER,GMRAPA) K ^TMP("GMRA",$J)
|
||||
I 'GMRAVER!GMRAOUT G EXIT
|
||||
S GMRAPA(0)=$G(^GMR(120.8,GMRAPA,0)) Q:GMRAPA(0)=""
|
||||
I '$P(GMRAPA(0),U,12) S DA=GMRAPA,DIE="^GMR(120.8,",DR="15////1" D ^DIE D ; Execute the event point for this reaction
|
||||
.Q:'$D(GMRAPA) S GMRAPA(0)=$G(^GMR(120.8,GMRAPA,0)) Q:GMRAPA(0)=""
|
||||
.N OROLD,DFN,GMRACNT S DFN=$P(GMRAPA(0),U)
|
||||
.D INP^VADPT S X=$O(^ORD(101,"B","GMRA SIGN-OFF ON DATA",0))_";ORD(101," D EN^XQOR:X K VAIN,X
|
||||
.Q
|
||||
S GMRAPA(0)=$G(^GMR(120.8,GMRAPA,0)),GMRATYPE=$P(GMRAPA(0),U,20)
|
||||
S DA=GMRAPA,DIE="^GMR(120.8,",DR="19////1;20///N;21////"_DUZ D ^DIE D:'GMRAVER EN1^GMRAVAB S GMRAPA(0)=$S($D(^GMR(120.8,GMRAPA,0)):^(0),1:"")
|
||||
I $G(GMRANEW) D ;send NOTIFICATION bulletin if this is new -- GMRA*4*33
|
||||
. I $P(GMRAPA(0),U,6)="o",GMRATYPE["D" D PTBUL^GMRAROBS
|
||||
I GMRAVER D EN1^GMRAPET0($P(GMRAPA(0),U),GMRAPA,"V",.GMRAOUT) I GMRAOUT S GMRAOUT=0
|
||||
Q1 D UNLOCK^GMRAUTL(120.8,GMRAPA)
|
||||
EXIT K GMRAFLAG,DA,DIE,DR,GMRADRUG Q
|
||||
GMRAVFY ;HIRMFO/WAA-VERIFY AND SIGN OFF AN AGENT ;12/1/95 16:06
|
||||
;;4.0;Adverse Reaction Tracking;**2**;Mar 29, 1996
|
||||
EN1 ;This is the main entry point for the verifier option.
|
||||
S GMRAVER=0,GMRADRUG=0
|
||||
I $P(GMRAPA(0),U,20)'["D" S GMRAFLAG=0 G VERIFY
|
||||
S GMRAFLAG=1,GMRADRUG=1
|
||||
I $P(GMRAPA(0),U,6)'="o" G VERIFY
|
||||
I '$D(GMRASITE) D SITE^GMRAUTL S GMRASITE(0)=$G(^GMRD(120.84,GMRASITE,0))
|
||||
I $P(^GMRD(120.84,+GMRASITE,0),U,7)'="y" G VERIFY
|
||||
I $D(^GMR(120.85,"C",GMRAPA)) G VERIFY
|
||||
W !,"Since this Causative Agent is an observed drug reaction and"
|
||||
W !,"FDA Data is required you must enter the Observer information"
|
||||
W !,"prior to verification."
|
||||
G EXIT
|
||||
VERIFY ;Verify an agent
|
||||
W !!,"Currently you have verifier access."
|
||||
F W !,"Would you like to verify this Causative Agent now" S %=1 D YN^DICN Q:%'=0 W !?4,"ANSWER YES IF YOU WOULD LIKE TO VERIFY THIS DATA, ELSE ANSWER NO."
|
||||
S:%=-1 GMRAOUT=1 G EXIT:%'=1 S GMRAVFY=1 W @IOF,! D SITE^GMRAUTL,EN2^GMRAPEV0 K GMRAVFY G:GMRAOUT EXIT
|
||||
I GMRAVER S GMRANAME=$P($G(^DPT(+GMRAPA(0),0)),U),GMRALLER=$P(GMRAPA(0),U,2) K:GMRANAME]""&(GMRALLER]"") ^TMP($J,"GMRADSP",GMRANAME,GMRALLER,GMRAPA) K ^TMP("GMRA",$J)
|
||||
I 'GMRAVER!GMRAOUT G EXIT
|
||||
S GMRAPA(0)=$G(^GMR(120.8,GMRAPA,0)) Q:GMRAPA(0)=""
|
||||
I '$P(GMRAPA(0),U,12) S DA=GMRAPA,DIE="^GMR(120.8,",DR="15////1" D ^DIE D ; Execute the event point for this reaction
|
||||
.Q:'$D(GMRAPA) S GMRAPA(0)=$G(^GMR(120.8,GMRAPA,0)) Q:GMRAPA(0)=""
|
||||
.N OROLD,DFN,GMRACNT S DFN=$P(GMRAPA(0),U)
|
||||
.D INP^VADPT S X=$O(^ORD(101,"B","GMRA SIGN-OFF ON DATA",0))_";ORD(101," D EN^XQOR:X K VAIN,X
|
||||
.Q
|
||||
S GMRAPA(0)=$G(^GMR(120.8,GMRAPA,0)),GMRATYPE=$P(GMRAPA(0),U,20)
|
||||
S DA=GMRAPA,DIE="^GMR(120.8,",DR="19////1;20///N;21////"_DUZ D ^DIE D:'GMRAVER EN1^GMRAVAB S GMRAPA(0)=$S($D(^GMR(120.8,GMRAPA,0)):^(0),1:"")
|
||||
I $P(GMRAPA(0),U,6)="o",GMRATYPE["D" D PTBUL^GMRAROBS
|
||||
I GMRAVER D EN1^GMRAPET0($P(GMRAPA(0),U),GMRAPA,"V",.GMRAOUT) I GMRAOUT S GMRAOUT=0
|
||||
Q1 D UNLOCK^GMRAUTL(120.8,GMRAPA)
|
||||
EXIT K GMRAFLAG,DA,DIE,DR,GMRADRUG Q
|
||||
|
|
|
|||
|
|
@ -1,216 +1,216 @@
|
|||
OOPSGUIR ;WIOFO/LLH-RPC routine for misc reports ;03/16/04
|
||||
;;2.0;ASISTS;**8,7,11,14**;Jun 03, 2002;Build 1
|
||||
;
|
||||
ENT(RESULTS,INPUT,CALL) ; get the data for the report
|
||||
; Input: INPUT - contains 3 values, the START AND END DATE,
|
||||
; STATION. The Date of Occ (fld #4) is used to
|
||||
; in/exclude claims from the report. If Station='ALL'
|
||||
; then all claims are included, if not 'All', then
|
||||
; only 1 station is included.
|
||||
; CALL - contains the report call which will invoke
|
||||
; the appropriate M call
|
||||
; Output: RESULTS - the results array passes data back to the client.
|
||||
N CAX,FI,LP,MENU,SDATE,STDT,STA,STATION,ENDDT,EDATE,TAG,X,Y,%DT
|
||||
S RESULTS(0)="Processing..."
|
||||
S STDT=$P($G(INPUT),U),ENDDT=$P($G(INPUT),U,2)
|
||||
S STA=$P($G(INPUT),U,3),TAG=CALL
|
||||
I (STDT="")!(ENDDT="")!(STA="")!(TAG="") D Q
|
||||
. S RESULTS(0)="Input parameters missing, cannot run report." Q
|
||||
K ^TMP($J,TAG)
|
||||
S (SDATE,EDATE,MENU)=""
|
||||
S X=STDT D ^%DT S SDATE=Y
|
||||
S X=ENDDT D ^%DT S EDATE=Y
|
||||
; SDATE made last time in day prior so start date correct
|
||||
I TAG="LOG300U" S TAG="LOG300",MENU="U"
|
||||
S SDATE=(SDATE-1)+.9999,EDATE=EDATE_".9999"
|
||||
D @TAG
|
||||
Q
|
||||
SERVICE ; Service/Detail Location report - patch 11
|
||||
DSPUTE ; Reason for Dispute report. Patch 11
|
||||
FLD174 ; Report compiles filing instruction result counts
|
||||
FLD332 ; Use this tag for Reason for Controvert report. Patch 11
|
||||
N ARR,CODE,CN,LP,IEN,I,GOON,P2,TX
|
||||
S LP="",IEN="",CN=0
|
||||
I TAG="FLD174" D
|
||||
.S CODE=$P($G(^DD(2260,174,0)),U,3)
|
||||
.F I=1:1 S LP=$P(CODE,";",I) Q:$G(LP)="" I $P(LP,":",2)'="" S ARR(LP)=0
|
||||
.S ARR(I_":No Data Entered")=0
|
||||
I TAG="FLD332" D
|
||||
.F I=1:1 Q:'$D(^OOPS(2262.4,I)) S ARR(I_":"_$P(^OOPS(2262.4,I,0),U))=0
|
||||
.S ARR(98_":Blk 36 also has text entered")=0
|
||||
.S ARR(99_":Controvert question checked Yes, but no Controvert Code entered")=0
|
||||
F LP=SDATE:0 S LP=$O(^OOPS(2260,"AD",LP)) Q:(LP'>0)!(LP>EDATE) D
|
||||
.F S IEN=$O(^OOPS(2260,"AD",LP,IEN)) Q:IEN'>0 D
|
||||
..I $$GET1^DIQ(2260,IEN,51,"I")>1 Q ;only allow open/closed cases
|
||||
..S CAX=$$GET1^DIQ(2260,IEN,52,"I")
|
||||
..I TAG'="SERVICE"&(CAX=2) Q ;only allow CA1's
|
||||
..S STATION=$P(^OOPS(2260,IEN,"2162A"),U,9)
|
||||
..I ($G(STA)'="A"),(STATION'=STA) Q ;get correct station
|
||||
..;patch 11 - sent to OOPSGUIF due to size this routine
|
||||
..I TAG="DSPUTE" D DSPUTE^OOPSGUIF
|
||||
..I TAG="SERVICE" D SERVICE^OOPSGUIU
|
||||
..; Filing instructions report
|
||||
..I TAG="FLD174" D
|
||||
...S FI=$$GET1^DIQ(2260,IEN,174,"I")_":"_$$GET1^DIQ(2260,IEN,174)
|
||||
...I $$GET1^DIQ(2260,IEN,174)="" S FI=I_":No Data Entered"
|
||||
...S ARR(FI)=ARR(FI)+1
|
||||
...;patch 11 - Reason for controvert report
|
||||
..I TAG="FLD332" D
|
||||
...;first Agency Controvert must = "Y" to be counted
|
||||
...S GOON=$$GET1^DIQ(2260,IEN,165.1,"I") I $G(GOON)'="Y" D Q
|
||||
....S:'$D(ARR("999:Case not controverted, no controvert code expected")) ARR("999:Case not controverted, no controvert code expected")=0
|
||||
....S ARR("999:Case not controverted, no controvert code expected")=ARR("999:Case not controverted, no controvert code expected")+1
|
||||
...S FI=$$GET1^DIQ(2260,IEN,332,"I")_":"_$$GET1^DIQ(2260,IEN,332)
|
||||
...I $$GET1^DIQ(2260,IEN,332)="" S FI=99_":Controvert question checked Yes, but no Controvert Code entered"
|
||||
...S ARR(FI)=ARR(FI)+1
|
||||
...I $G(^OOPS(2260,IEN,"CA1K",1,0))'="" D
|
||||
....;if case is diputed, don't count in Controvert rpt - quit
|
||||
....S GOON=$$GET1^DIQ(2260,IEN,165.2,"I") I $G(GOON)="Y" Q
|
||||
....S ARR(98_":Blk 36 also has text entered")=ARR(98_":Blk 36 also has text entered")+1
|
||||
I TAG'="DSPUTE",(TAG'="SERVICE") D
|
||||
.S CN=0,FI="",P2=""
|
||||
.F S FI=$O(ARR(FI)) Q:FI="" D
|
||||
..S CN=$P(FI,":"),P2=$P(FI,":",2),CODE=0
|
||||
..I TAG="FLD332" S TX=$O(^OOPS(2262.4,"B",P2,"")) I $G(TX) S CODE=$P(^OOPS(2262.4,TX,0),U,2)
|
||||
..S ^TMP($J,TAG,CN)=P2_U_CODE_U_ARR(FI)
|
||||
..; rearrange 'bogus' Controvert Codes for report formating
|
||||
..I TAG="FLD332",(CN>97) S ^TMP($J,TAG,CN)=U_P2_U_ARR(FI)
|
||||
I TAG="SERVICE" D CMPLSRV^OOPSGUIU
|
||||
I TAG="DSPUTE" D DSPUTE^OOPSGUIU
|
||||
S RESULTS=$NA(^TMP($J,TAG))
|
||||
Q
|
||||
SUM300A ; Summary of Work-related injuries and illness report
|
||||
N CN,EMP,FAC,HRS,STATE,STR
|
||||
N COLG,COLH,COLI,COLJ,COLK,COLL,COLM
|
||||
S (COLG,COLH,COLI,COLJ,COLK,COLL)=0
|
||||
S (COLM(1),COLM(2),COLM(3),COLM(4),COLM(5),COLM(6))=0
|
||||
S ^TMP($J,TAG,0)="No worksheet data for this station."
|
||||
S FAC=$$GET1^DIQ(4,STA,.01,"E")
|
||||
K ARR D STATINFO^OOPSGUI3(.ARR,STA) I $D(ARR) D
|
||||
.S STATE=$P($G(ARR(0)),U,3)
|
||||
.I $G(STATE)'="" D
|
||||
..S STATE=$O(^DIC(5,"B",STATE,""))
|
||||
..S $P(ARR(0),U,3)=$P(^DIC(5,STATE,0),U,2)
|
||||
.S ^TMP($J,TAG,0)=FAC_U_ARR(0)
|
||||
K ARR D SITEPGET^OOPSGUI6(.ARR,"OSHA300") I $D(ARR) D
|
||||
.S CN=0 F S CN=$O(ARR(CN)) Q:CN="" D
|
||||
..I $P(ARR(CN),U,11)'=STA Q
|
||||
..S STR=$P($P(ARR(CN),U,1)," = ",2)
|
||||
..S STR=$P(ARR(CN),U,3)_U_$P(ARR(CN),U,4)_U_$P(ARR(CN),U,6)_U
|
||||
..S STR=STR_$P(ARR(CN),U,7)_U_$P(ARR(CN),U,8)
|
||||
..S ^TMP($J,TAG,0)=^TMP($J,TAG,0)_U_STR
|
||||
K ARR,DATA S DATA=""
|
||||
D EMPHRS,DETAIL
|
||||
Q
|
||||
IRWSHT ; Incidence Rates Worksheet Report
|
||||
N COLHI,EMP,HRS
|
||||
S ^TMP($J,TAG,1)="No Worksheet Data for this Station"
|
||||
S COLHI=0
|
||||
K ARR,DATA S DATA=""
|
||||
D EMPHRS,DETAIL
|
||||
Q
|
||||
DETAIL ; now get employee information
|
||||
LOG300 ; entry point for the OSHA 300 LOG
|
||||
N CN,CASES,DOI,FLD,IEN,INC,STATION,TYPE
|
||||
S DOI=SDATE,CASES=0,CN=1
|
||||
F S DOI=$O(^OOPS(2260,"AF",DOI)) Q:(DOI>EDATE)!(DOI="") S IEN=0 D
|
||||
.F S IEN=$O(^OOPS(2260,"AF",DOI,"Y",IEN)) Q:IEN="" D
|
||||
..S STATION=$P(^OOPS(2260,IEN,"2162A"),U,9) I $G(STATION)'=STA Q
|
||||
..I $P(^OOPS(2260,IEN,0),U,6)>1 Q
|
||||
..S CASES=CASES+1
|
||||
..I TAG="IRWSHT" D
|
||||
...I $D(^OOPS(2260,IEN,"OUTC","AC","A","J"))!$D(^OOPS(2260,IEN,"OUTC","AC","A","A")) S COLHI=COLHI+1
|
||||
..I TAG="SUM300A" D FLD95
|
||||
..I TAG="LOG300" D FLD95 D
|
||||
...S ARR(1)=$$GET1^DIQ(2260,IEN,.01),ARR(2)=$$GET1^DIQ(2260,IEN,1)
|
||||
...I $$GET1^DIQ(2260,IEN,337,"I")="Y" S ARR(2)="Privacy Case"
|
||||
...S TYPE=$$GET1^DIQ(2260,IEN,3,"I")
|
||||
...I TYPE>10&(TYPE<15) S ARR(2)="Privacy Case"
|
||||
...I MENU="U" S ARR(2)=""
|
||||
...S INC=$$GET1^DIQ(2260,IEN,52,"I"),FLD=$S(INC=1:111,INC=2:208,1:"")
|
||||
...S ARR(3)=$$GET1^DIQ(2260,IEN,FLD)
|
||||
...S ARR(4)=$P($$FMTE^XLFDT(($$GET1^DIQ(2260,IEN,4,"I")),2),"@")
|
||||
...S ARR(5)=$$GET1^DIQ(2260,IEN,27,"E")
|
||||
...S ARR(6)=$$GET1^DIQ(2260,IEN,3)_";"_$$GET1^DIQ(2260,IEN,30)
|
||||
...S DATA=ARR(1)_U_ARR(2)_U_ARR(3)_U_ARR(4)_U_ARR(5)_U_ARR(6)_U_ARR(7)_U
|
||||
...S DATA=DATA_ARR(8)_U_ARR(9)_U_ARR(10)
|
||||
...S ^TMP($J,TAG,CN)=DATA,CN=CN+1
|
||||
I TAG="IRWSHT" S ^TMP($J,TAG,1)=CASES_U_COLHI_U_HRS
|
||||
I TAG="SUM300A" D
|
||||
.S DATA=CASES_U_EMP_U_HRS_U_COLG_U_COLH_U_COLI_U_COLJ_U_COLK_U_COLL_U
|
||||
.S DATA=DATA_COLM(1)_U_COLM(2)_U_COLM(3)_U_COLM(4)_U_COLM(5)_U_COLM(6)
|
||||
.S ^TMP($J,TAG,1)=DATA
|
||||
S RESULTS=$NA(^TMP($J,TAG))
|
||||
K ARR,DATA
|
||||
Q
|
||||
FLD95 ; use OUTC subrecord to retrieve data
|
||||
N AVAIL,ED,SD,S0,INC,ILL,DAYA,DAYJ,DAYS,IEN95,OC,OUTC,S95,TDAY
|
||||
S S0=$G(^OOPS(2260,IEN,0)),INC=$P(S0,U,7)
|
||||
S ILL=$P($G(^OOPS(2260,IEN,"2162B")),U,15)
|
||||
S TDAY=$$HTFM^XLFDT(+$H)
|
||||
; add days away & job transfer up only to 180 for log, 4 300A get all
|
||||
S (DAYA,DAYJ,TAWAY)=0,IEN95=0
|
||||
F S IEN95=$O(^OOPS(2260,IEN,"OUTC",IEN95)) Q:IEN95'>0 D
|
||||
.S S95=$G(^OOPS(2260,IEN,"OUTC",IEN95,0))
|
||||
.S SD=$P(S95,U,1),ED=$P(S95,U,2),OC=$P(S95,U,3),DAYS=0
|
||||
.I $P(S95,U,11)="D" Q ; entry is deleted
|
||||
.;patch 11 - added logic that if TAG=LOG300 include all incident days
|
||||
.; up to 180, else 300A, only include date range incidents
|
||||
.I (TAG="SUM300A"),(EDATE<SD) Q
|
||||
.I $G(OC)'="" S OUTC(OC)=""
|
||||
.I TAG="SUM300A" D
|
||||
..I $G(ED)=""!($G(ED)>EDATE) S DAYS=$$FMDIFF^XLFDT(EDATE,SD,1)+1
|
||||
.I TAG="LOG300",($G(ED)="") S DAYS=$$FMDIFF^XLFDT(TDAY,SD,1)+1
|
||||
.I '$G(DAYS) S DAYS=$S(OC="A":$P(S95,U,4),OC="J":$P(S95,U,5),1:0)
|
||||
.I DAYA+DAYJ>179 Q
|
||||
.S AVAIL=0
|
||||
.I DAYS>179 S AVAIL=(180-(DAYA+DAYJ))
|
||||
.I (DAYS<180) D
|
||||
..I (DAYS+DAYA+DAYJ)<180 S AVAIL=DAYS
|
||||
..I (DAYS+DAYA+DAYJ)>180 S AVAIL=(180-(DAYA+DAYJ))
|
||||
.I $G(OC)="A" S DAYA=DAYA+AVAIL
|
||||
.I $G(OC)="J" S DAYJ=DAYJ+AVAIL
|
||||
I TAG="SUM300A" D
|
||||
.S:$G(INC)=1 COLM(1)=COLM(1)+1
|
||||
.I INC=2 D
|
||||
..I $G(ILL) S COLM(ILL)=COLM(ILL)+1
|
||||
..I '$G(ILL) S COLM(6)=COLM(6)+1
|
||||
.S COLK=COLK+DAYA,COLL=COLL+DAYJ
|
||||
.I $D(OUTC("D")) S COLG=COLG+1 Q
|
||||
.I $D(OUTC("A")) S COLH=COLH+1 Q
|
||||
.I $D(OUTC("J")) S COLI=COLI+1 Q
|
||||
.I $D(OUTC("O")) S COLJ=COLJ+1 Q
|
||||
I TAG="LOG300" D
|
||||
.S ARR(7)="",ARR(10)="",(ARR(8),ARR(9))=0
|
||||
.I INC=1 S ARR(10)=1
|
||||
.I INC=2 S:$G(ILL) ARR(10)=ILL S:'$G(ILL) ARR(10)=6
|
||||
.S ARR(8)=DAYA,ARR(9)=DAYJ
|
||||
.I $D(OUTC("D")) S ARR(7)="D" S (ARR(8),ARR(9))=0 Q
|
||||
.I $D(OUTC("A")) S ARR(7)="A" Q
|
||||
.I $D(OUTC("J")) S ARR(7)="J" Q
|
||||
.I $D(OUTC("O")) S ARR(7)="O" Q
|
||||
Q
|
||||
EMPHRS ; get Total Num Employees and Hours worked
|
||||
N CASES,ED,LV1,LV2,MON,OK,PAR,SD,SIEN,STR,WS,X,X1,X2
|
||||
S (EMP,HRS,WS)=0
|
||||
S PAR="^OOPS(2262,0)",PAR=$Q(@PAR),PAR=$Q(@PAR)
|
||||
S LV1=$P(PAR,",",2),LV2=$P(PAR,",",3)
|
||||
S SIEN=$O(^OOPS(2262,LV1,LV2,"B",STA,-1)) Q:SIEN=""
|
||||
; get month range to make sure all emp numbers and hours are entered
|
||||
S SDATE=SDATE\1
|
||||
S SD=$E(SDATE,1,5)_"00"_$E(SDATE,8,$L(SDATE))
|
||||
S ED=$E(EDATE,1,5)_"00"_$E(EDATE,8,$L(EDATE))
|
||||
S X1=$E(ED,1,3),X2=$E(SD,1,3)
|
||||
I X1>X2 D
|
||||
.S OK=0,X=(X1-X2) S:X>1 OK=(X-1)*12
|
||||
.S OK=OK+((12-$E(SD,4,5))+1)+$E(ED,4,5)
|
||||
I X1=X2 S OK=($E(ED,4,5)-$E(SD,4,5))+1
|
||||
S MON=OK
|
||||
F S WS=$O(^OOPS(2262,LV1,LV2,SIEN,2,WS)) Q:(WS'>0) D
|
||||
.S STR=^OOPS(2262,LV1,LV2,SIEN,2,WS,0)
|
||||
.I ($P(STR,U)'<SD)&($P(STR,U)'>ED) D
|
||||
..I ($P(STR,U,2)="")!($P(STR,U,3)="") Q
|
||||
..S EMP=EMP+$P(STR,U,2),HRS=HRS+$P(STR,U,3),OK=OK-1
|
||||
I '$G(OK) S EMP=EMP/MON
|
||||
I $G(OK) S (EMP,HRS)="INCOMPLETE DATA"
|
||||
Q
|
||||
OOPSGUIR ;WIOFO/LLH-RPC routine for misc reports ;03/16/04
|
||||
;;2.0;ASISTS;**8,7,11**;Jun 03, 2002
|
||||
;
|
||||
ENT(RESULTS,INPUT,CALL) ; get the data for the report
|
||||
; Input: INPUT - contains 3 values, the START AND END DATE,
|
||||
; STATION. The Date of Occ (fld #4) is used to
|
||||
; in/exclude claims from the report. If Station='ALL'
|
||||
; then all claims are included, if not 'All', then
|
||||
; only 1 station is included.
|
||||
; CALL - contains the report call which will invoke
|
||||
; the appropriate M call
|
||||
; Output: RESULTS - the results array passes data back to the client.
|
||||
N CAX,FI,LP,MENU,SDATE,STDT,STA,STATION,ENDDT,EDATE,TAG,X,Y,%DT
|
||||
S RESULTS(0)="Processing..."
|
||||
S STDT=$P($G(INPUT),U),ENDDT=$P($G(INPUT),U,2)
|
||||
S STA=$P($G(INPUT),U,3),TAG=CALL
|
||||
I (STDT="")!(ENDDT="")!(STA="")!(TAG="") D Q
|
||||
. S RESULTS(0)="Input parameters missing, cannot run report." Q
|
||||
K ^TMP($J,TAG)
|
||||
S (SDATE,EDATE,MENU)=""
|
||||
S X=STDT D ^%DT S SDATE=Y
|
||||
S X=ENDDT D ^%DT S EDATE=Y
|
||||
; SDATE made last time in day prior so start date correct
|
||||
I TAG="LOG300U" S TAG="LOG300",MENU="U"
|
||||
S SDATE=(SDATE-1)+.9999,EDATE=EDATE_".9999"
|
||||
D @TAG
|
||||
Q
|
||||
SERVICE ; Service/Detail Location report - patch 11
|
||||
DSPUTE ; Reason for Dispute report. Patch 11
|
||||
FLD174 ; Report compiles filing instruction result counts
|
||||
FLD332 ; Use this tag for Reason for Controvert report. Patch 11
|
||||
N ARR,CODE,CN,LP,IEN,I,GOON,P2,TX
|
||||
S LP="",IEN="",CN=0
|
||||
I TAG="FLD174" D
|
||||
.S CODE=$P($G(^DD(2260,174,0)),U,3)
|
||||
.F I=1:1 S LP=$P(CODE,";",I) Q:$G(LP)="" I $P(LP,":",2)'="" S ARR(LP)=0
|
||||
.S ARR(I_":No Data Entered")=0
|
||||
I TAG="FLD332" D
|
||||
.F I=1:1 Q:'$D(^OOPS(2262.4,I)) S ARR(I_":"_$P(^OOPS(2262.4,I,0),U))=0
|
||||
.S ARR(98_":Blk 36 also has text entered")=0
|
||||
.S ARR(99_":Controvert question checked Yes, but no Controvert Code entered")=0
|
||||
F LP=SDATE:0 S LP=$O(^OOPS(2260,"AD",LP)) Q:(LP'>0)!(LP>EDATE) D
|
||||
.F S IEN=$O(^OOPS(2260,"AD",LP,IEN)) Q:IEN'>0 D
|
||||
..I $$GET1^DIQ(2260,IEN,51,"I")>1 Q ;only allow open/closed cases
|
||||
..S CAX=$$GET1^DIQ(2260,IEN,52,"I")
|
||||
..I TAG'="SERVICE"&(CAX=2) Q ;only allow CA1's
|
||||
..S STATION=$P(^OOPS(2260,IEN,"2162A"),U,9)
|
||||
..I ($G(STA)'="A"),(STATION'=STA) Q ;get correct station
|
||||
..;patch 11 - sent to OOPSGUIF due to size this routine
|
||||
..I TAG="DSPUTE" D DSPUTE^OOPSGUIF
|
||||
..I TAG="SERVICE" D SERVICE^OOPSGUIU
|
||||
..; Filing instructions report
|
||||
..I TAG="FLD174" D
|
||||
...S FI=$$GET1^DIQ(2260,IEN,174,"I")_":"_$$GET1^DIQ(2260,IEN,174)
|
||||
...I $$GET1^DIQ(2260,IEN,174)="" S FI=I_":No Data Entered"
|
||||
...S ARR(FI)=ARR(FI)+1
|
||||
...;patch 11 - Reason for controvert report
|
||||
..I TAG="FLD332" D
|
||||
...;first Agency Controvert must = "Y" to be counted
|
||||
...S GOON=$$GET1^DIQ(2260,IEN,165.1,"I") I $G(GOON)'="Y" D Q
|
||||
....S:'$D(ARR("999:Case not controverted, no controvert code expected")) ARR("999:Case not controverted, no controvert code expected")=0
|
||||
....S ARR("999:Case not controverted, no controvert code expected")=ARR("999:Case not controverted, no controvert code expected")+1
|
||||
...S FI=$$GET1^DIQ(2260,IEN,332,"I")_":"_$$GET1^DIQ(2260,IEN,332)
|
||||
...I $$GET1^DIQ(2260,IEN,332)="" S FI=99_":Controvert question checked Yes, but no Controvert Code entered"
|
||||
...S ARR(FI)=ARR(FI)+1
|
||||
...I $G(^OOPS(2260,IEN,"CA1K",1,0))'="" D
|
||||
....;if case is diputed, don't count in Controvert rpt - quit
|
||||
....S GOON=$$GET1^DIQ(2260,IEN,165.2,"I") I $G(GOON)="Y" Q
|
||||
....S ARR(98_":Blk 36 also has text entered")=ARR(98_":Blk 36 also has text entered")+1
|
||||
I TAG'="DSPUTE",(TAG'="SERVICE") D
|
||||
.S CN=0,FI="",P2=""
|
||||
.F S FI=$O(ARR(FI)) Q:FI="" D
|
||||
..S CN=$P(FI,":"),P2=$P(FI,":",2),CODE=0
|
||||
..I TAG="FLD332" S TX=$O(^OOPS(2262.4,"B",P2,"")) I $G(TX) S CODE=$P(^OOPS(2262.4,TX,0),U,2)
|
||||
..S ^TMP($J,TAG,CN)=P2_U_CODE_U_ARR(FI)
|
||||
..; rearrange 'bogus' Controvert Codes for report formating
|
||||
..I TAG="FLD332",(CN>97) S ^TMP($J,TAG,CN)=U_P2_U_ARR(FI)
|
||||
I TAG="SERVICE" D CMPLSRV^OOPSGUIU
|
||||
I TAG="DSPUTE" D DSPUTE^OOPSGUIU
|
||||
S RESULTS=$NA(^TMP($J,TAG))
|
||||
Q
|
||||
SUM300A ; Summary of Work-related injuries and illness report
|
||||
N CN,EMP,FAC,HRS,STATE,STR
|
||||
N COLG,COLH,COLI,COLJ,COLK,COLL,COLM
|
||||
S (COLG,COLH,COLI,COLJ,COLK,COLL)=0
|
||||
S (COLM(1),COLM(2),COLM(3),COLM(4),COLM(5),COLM(6))=0
|
||||
S ^TMP($J,TAG,0)="No worksheet data for this station."
|
||||
S FAC=$$GET1^DIQ(4,STA,.01,"E")
|
||||
K ARR D STATINFO^OOPSGUI3(.ARR,STA) I $D(ARR) D
|
||||
.S STATE=$P($G(ARR(0)),U,3)
|
||||
.I $G(STATE)'="" D
|
||||
..S STATE=$O(^DIC(5,"B",STATE,""))
|
||||
..S $P(ARR(0),U,3)=$P(^DIC(5,STATE,0),U,2)
|
||||
.S ^TMP($J,TAG,0)=FAC_U_ARR(0)
|
||||
K ARR D SITEPGET^OOPSGUI6(.ARR,"OSHA300") I $D(ARR) D
|
||||
.S CN=0 F S CN=$O(ARR(CN)) Q:CN="" D
|
||||
..I $P(ARR(CN),U,11)'=STA Q
|
||||
..S STR=$P($P(ARR(CN),U,1)," = ",2)
|
||||
..S STR=$P(ARR(CN),U,3)_U_$P(ARR(CN),U,4)_U_$P(ARR(CN),U,6)_U
|
||||
..S STR=STR_$P(ARR(CN),U,7)_U_$P(ARR(CN),U,8)
|
||||
..S ^TMP($J,TAG,0)=^TMP($J,TAG,0)_U_STR
|
||||
K ARR,DATA S DATA=""
|
||||
D EMPHRS,DETAIL
|
||||
Q
|
||||
IRWSHT ; Incidence Rates Worksheet Report
|
||||
N COLHI,EMP,HRS
|
||||
S ^TMP($J,TAG,1)="No Worksheet Data for this Station"
|
||||
S COLHI=0
|
||||
K ARR,DATA S DATA=""
|
||||
D EMPHRS,DETAIL
|
||||
Q
|
||||
DETAIL ; now get employee information
|
||||
LOG300 ; entry point for the OSHA 300 LOG
|
||||
N CN,CASES,DOI,FLD,IEN,INC,STATION,TYPE
|
||||
S DOI=SDATE,CASES=0,CN=1
|
||||
F S DOI=$O(^OOPS(2260,"AF",DOI)) Q:(DOI>EDATE)!(DOI="") S IEN=0 D
|
||||
.F S IEN=$O(^OOPS(2260,"AF",DOI,"Y",IEN)) Q:IEN="" D
|
||||
..S STATION=$P(^OOPS(2260,IEN,"2162A"),U,9) I $G(STATION)'=STA Q
|
||||
..I $P(^OOPS(2260,IEN,0),U,6)>1 Q
|
||||
..S CASES=CASES+1
|
||||
..I TAG="IRWSHT" D
|
||||
...I $D(^OOPS(2260,IEN,"OUTC","AC","A","J"))!$D(^OOPS(2260,IEN,"OUTC","AC","A","A")) S COLHI=COLHI+1
|
||||
..I TAG="SUM300A" D FLD95
|
||||
..I TAG="LOG300" D FLD95 D
|
||||
...S ARR(1)=$$GET1^DIQ(2260,IEN,.01),ARR(2)=$$GET1^DIQ(2260,IEN,1)
|
||||
...I $$GET1^DIQ(2260,IEN,337,"I")="Y" S ARR(2)="Privacy Case"
|
||||
...S TYPE=$$GET1^DIQ(2260,IEN,3,"I")
|
||||
...I TYPE>10&(TYPE<15) S ARR(2)="Privacy Case"
|
||||
...I MENU="U" S ARR(2)=""
|
||||
...S INC=$$GET1^DIQ(2260,IEN,52,"I"),FLD=$S(INC=1:111,INC=2:208,1:"")
|
||||
...S ARR(3)=$$GET1^DIQ(2260,IEN,FLD)
|
||||
...S ARR(4)=$P($$FMTE^XLFDT(($$GET1^DIQ(2260,IEN,4,"I")),2),"@")
|
||||
...S ARR(5)=$$GET1^DIQ(2260,IEN,27,"E")
|
||||
...S ARR(6)=$$GET1^DIQ(2260,IEN,3)_";"_$$GET1^DIQ(2260,IEN,30)
|
||||
...S DATA=ARR(1)_U_ARR(2)_U_ARR(3)_U_ARR(4)_U_ARR(5)_U_ARR(6)_U_ARR(7)_U
|
||||
...S DATA=DATA_ARR(8)_U_ARR(9)_U_ARR(10)
|
||||
...S ^TMP($J,TAG,CN)=DATA,CN=CN+1
|
||||
I TAG="IRWSHT" S ^TMP($J,TAG,1)=CASES_U_COLHI_U_HRS
|
||||
I TAG="SUM300A" D
|
||||
.S DATA=CASES_U_EMP_U_HRS_U_COLG_U_COLH_U_COLI_U_COLJ_U_COLK_U_COLL_U
|
||||
.S DATA=DATA_COLM(1)_U_COLM(2)_U_COLM(3)_U_COLM(4)_U_COLM(5)_U_COLM(6)
|
||||
.S ^TMP($J,TAG,1)=DATA
|
||||
S RESULTS=$NA(^TMP($J,TAG))
|
||||
K ARR,DATA
|
||||
Q
|
||||
FLD95 ; use OUTC subrecord to retrieve data
|
||||
N AVAIL,ED,SD,S0,INC,ILL,DAYA,DAYJ,DAYS,IEN95,OC,OUTC,S95,TDAY
|
||||
S S0=$G(^OOPS(2260,IEN,0)),INC=$P(S0,U,7)
|
||||
S ILL=$P($G(^OOPS(2260,IEN,"2162B")),U,15)
|
||||
S TDAY=$$HTFM^XLFDT(+$H)
|
||||
; add days away & job transfer up only to 180 for log, 4 300A get all
|
||||
S (DAYA,DAYJ,TAWAY)=0,IEN95=0
|
||||
F S IEN95=$O(^OOPS(2260,IEN,"OUTC",IEN95)) Q:IEN95'>0 D
|
||||
.S S95=$G(^OOPS(2260,IEN,"OUTC",IEN95,0))
|
||||
.S SD=$P(S95,U,1),ED=$P(S95,U,2),OC=$P(S95,U,3),DAYS=0
|
||||
.I $P(S95,U,11)="D" Q ; entry is deleted
|
||||
.;patch 11 - added logic that if TAG=LOG300 include all incident days
|
||||
.; up to 180, else 300A, only include date range incidents
|
||||
.I (TAG="SUM300A"),(EDATE<SD) Q
|
||||
.I $G(OC)'="" S OUTC(OC)=""
|
||||
.I TAG="SUM300A" D
|
||||
..I $G(ED)=""!($G(ED)>EDATE) S DAYS=$$FMDIFF^XLFDT(EDATE,SD,1)+1
|
||||
.I TAG="LOG300",($G(ED)="") S DAYS=$$FMDIFF^XLFDT(TDAY,SD,1)+1
|
||||
.I '$G(DAYS) S DAYS=$S(OC="A":$P(S95,U,4),OC="J":$P(S95,U,5),1:0)
|
||||
.I DAYA+DAYJ>180 Q
|
||||
.S AVAIL=0
|
||||
.I DAYS>180 S AVAIL=180
|
||||
.I (DAYS<180) D
|
||||
..I (DAYS+DAYA+DAYJ)<180 S AVAIL=DAYS
|
||||
..I (DAYS+DAYA+DAYJ)>180 S AVAIL=(180-(DAYA+DAYJ))
|
||||
.I $G(OC)="A" S DAYA=DAYA+AVAIL
|
||||
.I $G(OC)="J" S DAYJ=DAYJ+AVAIL
|
||||
I TAG="SUM300A" D
|
||||
.S:$G(INC)=1 COLM(1)=COLM(1)+1
|
||||
.I INC=2 D
|
||||
..I $G(ILL) S COLM(ILL)=COLM(ILL)+1
|
||||
..I '$G(ILL) S COLM(6)=COLM(6)+1
|
||||
.S COLK=COLK+DAYA,COLL=COLL+DAYJ
|
||||
.I $D(OUTC("D")) S COLG=COLG+1 Q
|
||||
.I $D(OUTC("A")) S COLH=COLH+1 Q
|
||||
.I $D(OUTC("J")) S COLI=COLI+1 Q
|
||||
.I $D(OUTC("O")) S COLJ=COLJ+1 Q
|
||||
I TAG="LOG300" D
|
||||
.S ARR(7)="",ARR(10)="",(ARR(8),ARR(9))=0
|
||||
.I INC=1 S ARR(10)=1
|
||||
.I INC=2 S:$G(ILL) ARR(10)=ILL S:'$G(ILL) ARR(10)=6
|
||||
.S ARR(8)=DAYA,ARR(9)=DAYJ
|
||||
.I $D(OUTC("D")) S ARR(7)="D" S (ARR(8),ARR(9))=0 Q
|
||||
.I $D(OUTC("A")) S ARR(7)="A" Q
|
||||
.I $D(OUTC("J")) S ARR(7)="J" Q
|
||||
.I $D(OUTC("O")) S ARR(7)="O" Q
|
||||
Q
|
||||
EMPHRS ; get Total Num Employees and Hours worked
|
||||
N CASES,ED,LV1,LV2,MON,OK,PAR,SD,SIEN,STR,WS,X,X1,X2
|
||||
S (EMP,HRS,WS)=0
|
||||
S PAR="^OOPS(2262,0)",PAR=$Q(@PAR),PAR=$Q(@PAR)
|
||||
S LV1=$P(PAR,",",2),LV2=$P(PAR,",",3)
|
||||
S SIEN=$O(^OOPS(2262,LV1,LV2,"B",STA,-1)) Q:SIEN=""
|
||||
; get month range to make sure all emp numbers and hours are entered
|
||||
S SDATE=SDATE\1
|
||||
S SD=$E(SDATE,1,5)_"00"_$E(SDATE,8,$L(SDATE))
|
||||
S ED=$E(EDATE,1,5)_"00"_$E(EDATE,8,$L(EDATE))
|
||||
S X1=$E(ED,1,3),X2=$E(SD,1,3)
|
||||
I X1>X2 D
|
||||
.S OK=0,X=(X1-X2) S:X>1 OK=(X-1)*12
|
||||
.S OK=OK+(($E(ED,4,5)-$E(SD,4,5))+1)+$E(SD,4,5)
|
||||
I X1=X2 S OK=($E(ED,4,5)-$E(SD,4,5))+1
|
||||
S MON=OK
|
||||
F S WS=$O(^OOPS(2262,LV1,LV2,SIEN,2,WS)) Q:(WS'>0) D
|
||||
.S STR=^OOPS(2262,LV1,LV2,SIEN,2,WS,0)
|
||||
.I ($P(STR,U)'<SD)&($P(STR,U)'>ED) D
|
||||
..I ($P(STR,U,2)="")!($P(STR,U,3)="") Q
|
||||
..S EMP=EMP+$P(STR,U,2),HRS=HRS+$P(STR,U,3),OK=OK-1
|
||||
I '$G(OK) S EMP=EMP/MON
|
||||
I $G(OK) S (EMP,HRS)="INCOMPLETE DATA"
|
||||
Q
|
||||
|
|
|
|||
|
|
@ -1,249 +1,232 @@
|
|||
LA7ADL ;DALOI/JMC - Automatic Download of Test Orders;May 30, 2008
|
||||
;;5.2;AUTOMATED LAB INSTRUMENTS;**17,25,23,57,66**;Sep 27, 1994;Build 30
|
||||
;
|
||||
; This routine will monitor the ^LA("ADL") node to check for accessions which are to have test orders automatically
|
||||
; downloaded to another computer system. All entries in the auto instrument file which are flagged for automatic downloading
|
||||
; will be checked to see if they contain any tests on the accession. If tests are found then the appropiate download message
|
||||
; is constructed and sent.
|
||||
;
|
||||
;
|
||||
EN(LA7UID) ; Set flag to check accession for downloading, start background job if needed.
|
||||
; Called by LR7OMERG, LRCONJAM, LRTSTSET, LRWLST1.
|
||||
;
|
||||
; No UID passed to routine.
|
||||
I $G(LA7UID)="" Q
|
||||
;
|
||||
; No instrument flagged for auto downloading.
|
||||
I '$D(^LAB(62.4,"AE")) Q
|
||||
;
|
||||
; Quit if "Don't Start/Collect" flag set.
|
||||
I +$G(^LA("ADL","STOP"),0)=3 Q
|
||||
;
|
||||
; Lock node in case already downloading this accession, wait until downloading finished.
|
||||
L +^LA("ADL","Q",LA7UID):60
|
||||
;
|
||||
; Set flag to check this accession for auto downloading.
|
||||
S ^LA("ADL","Q",LA7UID)=""
|
||||
;
|
||||
; Release lock.
|
||||
L -^LA("ADL","Q",LA7UID)
|
||||
;
|
||||
; Quit if "Don't Start" flag set.
|
||||
I +$G(^LA("ADL","STOP"),0)=2 Q
|
||||
;
|
||||
; Task background job to run.
|
||||
D CHKTSK
|
||||
;
|
||||
; Unlock node.
|
||||
L -^LA("ADL",0)
|
||||
;
|
||||
Q
|
||||
;
|
||||
;
|
||||
DQ ; Entry point from Taskman.
|
||||
;
|
||||
; Wait for a little while in case another job checking for background job has lock.
|
||||
L +^LA("ADL",0):10
|
||||
; Another process has lock, only want one at a time.
|
||||
I '$T S:$D(ZTQUEUED) ZTREQ="@" Q
|
||||
;
|
||||
; No instrument flagged for auto downloading.
|
||||
I '$D(^LAB(62.4,"AE")) D EXIT Q
|
||||
;
|
||||
; Quit if "Don't Start/Collect" flags set.
|
||||
I +$G(^LA("ADL","STOP"),0)>1 Q
|
||||
;
|
||||
; Update XTMP entry to let auto download know we're running for this process
|
||||
; and build table of tests to check for downloading}
|
||||
D XTMP,BUILD
|
||||
;
|
||||
F D UID Q:TOUT>60
|
||||
D EXIT
|
||||
Q
|
||||
;
|
||||
;
|
||||
UID ; Start loop to monitor for accessions to download.
|
||||
;
|
||||
S LA7UID="",(TOUT,ZTSTOP)=0
|
||||
;
|
||||
; Flag set to "Rebuild".
|
||||
I +$G(^LA("ADL","STOP"))=1,'ZTSTOP D BUILD
|
||||
;
|
||||
F S LA7UID=$O(^LA("ADL","Q",LA7UID)) Q:LA7UID=""!(ZTSTOP)!(TOUT) D
|
||||
. I +$G(^LA("ADL","STOP"))>0 S TOUT=61 Q
|
||||
. I $$S^%ZTLOAD("Processing Lab UID "_LA7UID) S ZTSTOP=1,TOUT=61 Q
|
||||
. ; Lock this UID, synch setting/deleting when another job is attempting to set node.
|
||||
. D LOCK^DILF("^LA(""ADL"",""Q"",LA7UID)")
|
||||
. ; Unable to get lock, go on to next UID, check again on next go around.
|
||||
. I '$T Q
|
||||
. ; Get accession info from ^LRO(68,"C").
|
||||
. S X=$Q(^LRO(68,"C",LA7UID))
|
||||
. ; Quit - UID does not match.
|
||||
. I $QS(X,3)'=LA7UID D CLEANUP Q
|
||||
. ; Setup accession variables for auto downloading.
|
||||
. S LRAA=+$QS(X,4),LRAD=+$QS(X,5),LRAN=+$QS(X,6)
|
||||
. D BLDTST
|
||||
. S LA7INST=0
|
||||
. F S LA7INST=$O(LA7AUTO(LA7INST)) Q:'LA7INST D
|
||||
. . D CHKTEST
|
||||
. . ; No tests on instrument list for this accession.
|
||||
. . I '$D(LA7ACC) Q
|
||||
. . S LRINST=LA7INST,LRAUTO=LA7AUTO(LA7INST)
|
||||
. . N LA7UID
|
||||
. . ; File build (entry^routine) from fields #93 and #94 in file #62.4.
|
||||
. . D @$P(LA7AUTO(LA7INST,9),"^",3,4)
|
||||
. D CLEANUP,XTMP
|
||||
;
|
||||
F D Q:$O(^LA("ADL","Q",""))'="" Q:TOUT>60
|
||||
. I $G(^LA("ADL","STOP"))>1 S TOUT=61 Q
|
||||
. ; Task has been requested to stop.
|
||||
. I $$S^%ZTLOAD("Idle - waiting for new accessions to process") S TOUT=61,ZTSTOP=1 Q
|
||||
. S TOUT=TOUT+1 H 5 D XTMP
|
||||
;
|
||||
Q
|
||||
;
|
||||
;
|
||||
BLDTST ; Build array of tests on accession to check for downloading
|
||||
;
|
||||
N X,LA760,LA7PCNT
|
||||
;
|
||||
K LA7TREE
|
||||
S LA760=0
|
||||
F S LA760=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LA760)) Q:'LA760 D
|
||||
. ; Quit if test has been removed from accession.
|
||||
. S X=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LA760,0),0) Q:'X
|
||||
. ; If test completed (#4, COMPLETE DATE entered), don't download.
|
||||
. I $P(X,"^",5) Q
|
||||
. ; Build array of atomic tests on accession with urgency.
|
||||
. S LA7PCNT=0
|
||||
. D UNWIND^LA7ADL1(LA760,$P(X,"^",2),0)
|
||||
;
|
||||
Q
|
||||
;
|
||||
;
|
||||
CHKTEST ; Check tests to determine if they should build in message.
|
||||
; Array LA7ACC returned with tests to send in message
|
||||
;
|
||||
N LA760,LA761,LA76205,LA768,LA7I,LRDPF,X
|
||||
;
|
||||
K LA7ACC
|
||||
;
|
||||
; Quit - specimen uncollected & don't download uncollected flag set.
|
||||
; controls exempted.
|
||||
S LRDPF=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,0)),"^",2)
|
||||
S X=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,3))
|
||||
I LRDPF'=62.3,'$P(X,"^",3),'$P(^TMP("LA7-INST",$J,LA7INST),"^") Q
|
||||
;
|
||||
S X=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,5,0))
|
||||
S LA761=$P(^LRO(68,LRAA,1,LRAD,1,LRAN,5,X,0),"^")
|
||||
S LA760=0
|
||||
F S LA760=$O(LA7TREE(LA760)) Q:'LA760 D
|
||||
. I '$D(^TMP("LA7-INST",$J,LA7INST,LA760)) Q
|
||||
. S LA7I=0
|
||||
. F S LA7I=$O(^TMP("LA7-INST",$J,LA7INST,LA760,LA7I)) Q:'LA7I D
|
||||
. . S LA76205=+$P(LA7TREE(LA760),"^")
|
||||
. . D CHKMASK
|
||||
;
|
||||
Q
|
||||
;
|
||||
CHKMASK ; Check pattern mask for tests that match download pattern mask
|
||||
;
|
||||
; Any accession area, specimen, urgency
|
||||
I $D(^TMP("LA7-INST",$J,LA7INST,LA760,LA7I,0,0,0)) D ADD Q
|
||||
;
|
||||
; Specific accession area, any specimen/urgency
|
||||
I $D(^TMP("LA7-INST",$J,LA7INST,LA760,LA7I,LRAA,0,0)) D ADD Q
|
||||
;
|
||||
; Specific specimen, any accession area/urgency
|
||||
I $D(^TMP("LA7-INST",$J,LA7INST,LA760,LA7I,0,LA761,0)) D ADD Q
|
||||
;
|
||||
; Specific urgency, any accession area/specimen
|
||||
I $D(^TMP("LA7-INST",$J,LA7INST,LA760,LA7I,0,0,LA76205)) D ADD Q
|
||||
;
|
||||
; Specific accession/specimen, any urgency
|
||||
I $D(^TMP("LA7-INST",$J,LA7INST,LA760,LA7I,LRAA,LA761,0)) D ADD Q
|
||||
;
|
||||
; Specific specimen/urgency, any accession area
|
||||
I $D(^TMP("LA7-INST",$J,LA7INST,LA760,LA7I,0,LA761,LA76205)) D ADD Q
|
||||
;
|
||||
; Specific accession/specimen/urgency
|
||||
I $D(^TMP("LA7-INST",$J,LA7INST,LA760,LA7I,LRAA,LA761,LA76205)) D ADD Q
|
||||
;
|
||||
Q
|
||||
;
|
||||
ADD ; Add to list of tests to download
|
||||
;
|
||||
S LA7ACC(LA7I)=LA760_"^"_LA7TREE(LA760)
|
||||
Q
|
||||
;
|
||||
;
|
||||
CLEANUP ; Delete flag after accession has been checked.
|
||||
; NOTE: Lock previously set above.
|
||||
;
|
||||
K ^LA("ADL","Q",LA7UID)
|
||||
;
|
||||
; Release lock on this UID.
|
||||
L -^LA("ADL","Q",LA7UID)
|
||||
;
|
||||
Q
|
||||
;
|
||||
;
|
||||
CHKTSK ; Check if we shoud task the auto download processing routine.
|
||||
; Check if we recently tasked the processing routine for this process by compaing values in the XTMP global.
|
||||
; Done to avoid repetitive locking attempts on each new accessione since the FileMan locking API uses a site-defined timeout which is usually 3 seconds
|
||||
; but can be more. Slows down the interface if on each accession we are waiting 3 or more seconds for the lock to find out if the processing routine
|
||||
; is already running.
|
||||
;
|
||||
N LA7X,LA7Y
|
||||
S LA7X=$H,LA7Y=$G(^XTMP("LA7ADL",1))
|
||||
I $P(LA7X,",")=$P(LA7Y,","),($P(LA7X,",",2)-$P(LA7Y,",",2))<240 Q
|
||||
;
|
||||
; Lock zeroth node.
|
||||
; Quit if another process has lock - either another job setting node or the background job.
|
||||
D LOCK^DILF("^LA(""ADL"",0)")
|
||||
I '$T Q
|
||||
;
|
||||
ZTSK ; Task background job to run.
|
||||
;
|
||||
; Call here to queue this processing routine to run in the background.
|
||||
;
|
||||
; Task background job if not running.
|
||||
N ZTDESC,ZTSAVE,ZTDTH,ZTIO,ZTRTN
|
||||
S ZTRTN="DQ^LA7ADL",ZTDESC="Lab Auto Download",ZTIO="",ZTDTH=$H
|
||||
D ^%ZTLOAD
|
||||
;
|
||||
Q
|
||||
;
|
||||
;
|
||||
BUILD ; Build TMP global with list of tests for instruments flagged for auto download.
|
||||
;
|
||||
D BUILD^LA7ADL1
|
||||
;
|
||||
; Set flag to "Running".
|
||||
D SETSTOP^LA7ADL1(0,$G(DUZ))
|
||||
;
|
||||
Q
|
||||
;
|
||||
;
|
||||
XTMP ; Set/update XTMP with current run time of this processing routine
|
||||
;
|
||||
S DT=$$DT^XLFDT
|
||||
S ^XTMP("LA7ADL",0)=DT_"^"_DT_"^LAB AUTO DOWNLOAD PROCESS TASKING"
|
||||
S ^XTMP("LA7ADL",1)=$H
|
||||
Q
|
||||
;
|
||||
;
|
||||
EXIT ; Exit and cleanup.
|
||||
;
|
||||
; Release lock on LA("ADL") global.
|
||||
L -^LA("ADL",0)
|
||||
;
|
||||
K ^TMP("LA7",$J),^TMP($J),^XTMP("LA7ADL",1)
|
||||
K LA7ADL,LA7AUTO,LA7NVAF,LRAA,LRAD,LRAN,TOUT
|
||||
;
|
||||
; Clear flag if normal shutdown, no new accessions.
|
||||
I +$G(^LA("ADL","STOP"))<2 K ^LA("ADL","STOP")
|
||||
;
|
||||
; Set flag for taskman to cleanup task.
|
||||
I $D(ZTQUEUED) S ZTREQ="@"
|
||||
Q
|
||||
LA7ADL ;DALOI/JMC - Automatic Download of Test Orders; 1/30/95 09:00
|
||||
;;5.2;AUTOMATED LAB INSTRUMENTS;**17,25,23,57**;Sep 27, 1994
|
||||
;
|
||||
; This routine will monitor the ^LA("ADL") node to check for accessions which are to have test orders automatically
|
||||
; downloaded to another computer system. All entries in the auto instrument file which are flagged for automatic downloading
|
||||
; will be checked to see if they contain any tests on the accession. If tests are found then the appropiate download message
|
||||
; is constructed and sent.
|
||||
;
|
||||
;
|
||||
EN(LA7UID) ; Set flag to check accession for downloading, start background job if needed.
|
||||
; Called by LR7OMERG, LRCONJAM, LRTSTSET, LRWLST1.
|
||||
;
|
||||
; No UID passed to routine.
|
||||
I $G(LA7UID)="" Q
|
||||
;
|
||||
; No instrument flagged for auto downloading.
|
||||
I '$D(^LAB(62.4,"AE")) Q
|
||||
;
|
||||
; Quit if "Don't Start/Collect" flag set.
|
||||
I +$G(^LA("ADL","STOP"),0)=3 Q
|
||||
;
|
||||
; Lock node in case already downloading this accession, wait until downloading finished.
|
||||
L +^LA("ADL","Q",LA7UID):60
|
||||
;
|
||||
; Set flag to check this accession for auto downloading.
|
||||
S ^LA("ADL","Q",LA7UID)=""
|
||||
;
|
||||
; Release lock.
|
||||
L -^LA("ADL","Q",LA7UID)
|
||||
;
|
||||
; Quit if "Don't Start" flag set.
|
||||
I +$G(^LA("ADL","STOP"),0)=2 Q
|
||||
;
|
||||
; Lock zeroth node.
|
||||
; Quit if another process has lock
|
||||
; - either another job setting node or the background job.
|
||||
L +^LA("ADL",0):1
|
||||
I '$T Q
|
||||
;
|
||||
; Task background job to run.
|
||||
N ZTSK
|
||||
D ZTSK
|
||||
;
|
||||
; Unlock node.
|
||||
L -^LA("ADL",0)
|
||||
;
|
||||
Q
|
||||
;
|
||||
;
|
||||
DQ ; Entry point from Taskman.
|
||||
;
|
||||
; Set flag for taskman to cleanup task.
|
||||
I $D(ZTQUEUED) S ZTREQ="@"
|
||||
;
|
||||
; Wait for a little while in case another job checking for background job has lock.
|
||||
L +^LA("ADL",0):10
|
||||
; Another process has lock, only want one at a time.
|
||||
I '$T Q
|
||||
;
|
||||
; No instrument flagged for auto downloading.
|
||||
I '$D(^LAB(62.4,"AE")) D EXIT Q
|
||||
;
|
||||
; Quit if "Don't Start/Collect" flags set.
|
||||
I +$G(^LA("ADL","STOP"),0)>1 Q
|
||||
;
|
||||
D BUILD
|
||||
;
|
||||
F D UID Q:TOUT>60
|
||||
D EXIT
|
||||
Q
|
||||
;
|
||||
;
|
||||
UID ; Start loop to monitor for accessions to download.
|
||||
;
|
||||
S LA7UID="",(TOUT,ZTSTOP)=0
|
||||
;
|
||||
; Flag set to "Rebuild".
|
||||
I +$G(^LA("ADL","STOP"))=1,'ZTSTOP D BUILD
|
||||
;
|
||||
F S LA7UID=$O(^LA("ADL","Q",LA7UID)) Q:LA7UID=""!(ZTSTOP)!(TOUT) D
|
||||
. I +$G(^LA("ADL","STOP"))>0 S TOUT=61 Q
|
||||
. I $$S^%ZTLOAD S ZTSTOP=1,TOUT=61 Q
|
||||
. ; Lock this UID, synch setting/deleting when another job is attempting to set node.
|
||||
. L +^LA("ADL","Q",LA7UID):1
|
||||
. ; Unable to get lock, go on to next UID, check again on next go around.
|
||||
. I '$T Q
|
||||
. ; Get accession info from ^LRO(68,"C").
|
||||
. S X=$Q(^LRO(68,"C",LA7UID))
|
||||
. ; Quit - UID does not match.
|
||||
. I $QS(X,3)'=LA7UID D CLEANUP Q
|
||||
. ; Setup accession variables for auto downloading.
|
||||
. S LRAA=+$QS(X,4),LRAD=+$QS(X,5),LRAN=+$QS(X,6)
|
||||
. D BLDTST
|
||||
. S LA7INST=0
|
||||
. F S LA7INST=$O(LA7AUTO(LA7INST)) Q:'LA7INST D
|
||||
. . D CHKTEST
|
||||
. . ; No tests on instrument list for this accession.
|
||||
. . I '$D(LA7ACC) Q
|
||||
. . S LRINST=LA7INST,LRAUTO=LA7AUTO(LA7INST)
|
||||
. . N LA7UID
|
||||
. . ; File build (entry^routine) from fields #93 and #94 in file #62.4.
|
||||
. . D @$P(LA7AUTO(LA7INST,9),"^",3,4)
|
||||
. D CLEANUP
|
||||
;
|
||||
F D Q:$O(^LA("ADL","Q",""))'="" Q:TOUT>60
|
||||
. I $G(^LA("ADL","STOP"))>1 S TOUT=61 Q
|
||||
. ; Task has been requested to stop.
|
||||
. I $$S^%ZTLOAD S TOUT=61,ZTSTOP=1 Q
|
||||
. S TOUT=TOUT+1 H 5
|
||||
;
|
||||
Q
|
||||
;
|
||||
;
|
||||
BLDTST ; Build array of tests on accession to check for downloading
|
||||
;
|
||||
N X,LA760,LA7PCNT
|
||||
;
|
||||
K LA7TREE
|
||||
S LA760=0
|
||||
F S LA760=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LA760)) Q:'LA760 D
|
||||
. ; Quit if test has been removed from accession.
|
||||
. S X=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LA760,0),0) Q:'X
|
||||
. ; If test completed (#4, COMPLETE DATE entered), don't download.
|
||||
. I $P(X,"^",5) Q
|
||||
. ; Build array of atomic tests on accession with urgency.
|
||||
. S LA7PCNT=0
|
||||
. D UNWIND^LA7ADL1(LA760,$P(X,"^",2),0)
|
||||
;
|
||||
Q
|
||||
;
|
||||
;
|
||||
CHKTEST ; Check tests to determine if they should build in message.
|
||||
; Array LA7ACC returned with tests to send in message
|
||||
;
|
||||
N LA760,LA761,LA76205,LA768,LA7I,LRDPF,X
|
||||
;
|
||||
K LA7ACC
|
||||
;
|
||||
; Quit - specimen uncollected & don't download uncollected flag set.
|
||||
; controls exempted.
|
||||
S LRDPF=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,0)),"^",2)
|
||||
S X=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,3))
|
||||
I LRDPF'=62.3,'$P(X,"^",3),'$P(^TMP("LA7-INST",$J,LA7INST),"^") Q
|
||||
;
|
||||
S X=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,5,0))
|
||||
S LA761=$P(^LRO(68,LRAA,1,LRAD,1,LRAN,5,X,0),"^")
|
||||
S LA760=0
|
||||
F S LA760=$O(LA7TREE(LA760)) Q:'LA760 D
|
||||
. I '$D(^TMP("LA7-INST",$J,LA7INST,LA760)) Q
|
||||
. S LA7I=0
|
||||
. F S LA7I=$O(^TMP("LA7-INST",$J,LA7INST,LA760,LA7I)) Q:'LA7I D
|
||||
. . S LA76205=+$P(LA7TREE(LA760),"^")
|
||||
. . D CHKMASK
|
||||
;
|
||||
Q
|
||||
;
|
||||
CHKMASK ; Check pattern mask for tests that match download pattern mask
|
||||
;
|
||||
; Any accession area, specimen, urgency
|
||||
I $D(^TMP("LA7-INST",$J,LA7INST,LA760,LA7I,0,0,0)) D ADD Q
|
||||
;
|
||||
; Specific accession area, any specimen/urgency
|
||||
I $D(^TMP("LA7-INST",$J,LA7INST,LA760,LA7I,LRAA,0,0)) D ADD Q
|
||||
;
|
||||
; Specific specimen, any accession area/urgency
|
||||
I $D(^TMP("LA7-INST",$J,LA7INST,LA760,LA7I,0,LA761,0)) D ADD Q
|
||||
;
|
||||
; Specific urgency, any accession area/specimen
|
||||
I $D(^TMP("LA7-INST",$J,LA7INST,LA760,LA7I,0,0,LA76205)) D ADD Q
|
||||
;
|
||||
; Specific accession/specimen, any urgency
|
||||
I $D(^TMP("LA7-INST",$J,LA7INST,LA760,LA7I,LRAA,LA761,0)) D ADD Q
|
||||
;
|
||||
; Specific specimen/urgency, any accession area
|
||||
I $D(^TMP("LA7-INST",$J,LA7INST,LA760,LA7I,0,LA761,LA76205)) D ADD Q
|
||||
;
|
||||
; Specific accession/specimen/urgency
|
||||
I $D(^TMP("LA7-INST",$J,LA7INST,LA760,LA7I,LRAA,LA761,LA76205)) D ADD Q
|
||||
;
|
||||
Q
|
||||
;
|
||||
ADD ; Add to list of tests to download
|
||||
;
|
||||
S LA7ACC(LA7I)=LA760_"^"_LA7TREE(LA760)
|
||||
Q
|
||||
;
|
||||
;
|
||||
CLEANUP ; Delete flag after accession has been checked.
|
||||
; NOTE: Lock previously set above.
|
||||
;
|
||||
K ^LA("ADL","Q",LA7UID)
|
||||
;
|
||||
; Release lock on this UID.
|
||||
L -^LA("ADL","Q",LA7UID)
|
||||
;
|
||||
Q
|
||||
;
|
||||
;
|
||||
ZTSK ; Task background job to run.
|
||||
;
|
||||
N ZTDESC,ZTSAVE,ZTDTH,ZTIO,ZTRTN
|
||||
;
|
||||
; Task background job if not running.
|
||||
S ZTRTN="DQ^LA7ADL",ZTDESC="Lab Auto Download",ZTIO="",ZTDTH=$H
|
||||
D ^%ZTLOAD
|
||||
;
|
||||
Q
|
||||
;
|
||||
;
|
||||
BUILD ; Build TMP global with list of tests for instruments flagged for auto download.
|
||||
D BUILD^LA7ADL1
|
||||
;
|
||||
; Set flag to "Running".
|
||||
D SETSTOP^LA7ADL1(0,$G(DUZ))
|
||||
;
|
||||
Q
|
||||
;
|
||||
;
|
||||
EXIT ; Exit and cleanup.
|
||||
;
|
||||
; Release lock on LA("ADL") global.
|
||||
L -^LA("ADL",0)
|
||||
;
|
||||
K ^TMP("LA7",$J),^TMP($J)
|
||||
K LA7ADL
|
||||
K LRAA,LRAD,LRAN
|
||||
K TOUT
|
||||
;
|
||||
; Clear flag if normal shutdown, no new accessions.
|
||||
I +$G(^LA("ADL","STOP"))<2 K ^LA("ADL","STOP")
|
||||
;
|
||||
Q
|
||||
|
|
|
|||
|
|
@ -1,49 +1,48 @@
|
|||
LA7UID ;DALIO/JRR - BUILD HL7 DOWNLOAD TO UI ;May 20, 2008
|
||||
;;5.2;AUTOMATED LAB INSTRUMENTS;**17,57,66**;Sep 27, 1994;Build 30
|
||||
;
|
||||
Q
|
||||
;
|
||||
EN ; This line tag is called from ^LADOWN when downloading
|
||||
; a load work list to the Auto Instrument. LADOWN1 should
|
||||
; have already built ^TMP($J with all of the atomic and
|
||||
; cosmic tests, ^TMP("LA7",$J holds all of the Instrument defined
|
||||
; tests from 62.4.
|
||||
; LRLL= IEN in 68.2 Load Worklist file, from field in 62.4
|
||||
; LRINST= IEN IN 62.4 Auto Inst file
|
||||
; LRAUTO= zero node of 62.4 entry
|
||||
;
|
||||
N LA7MODE
|
||||
S LA7INST=LRINST
|
||||
I '$G(LA7ADL) D BLDINST^LA7ADL1(LA7INST,LRLL)
|
||||
S LA76248=$P($G(^LAB(62.4,+$G(LRINST),0)),"^",8)
|
||||
I 'LA76248 D Q
|
||||
. S XQAMSG="MESSAGE CONFIGURATION not defined in AUTO INSTRUMENT file for "_$P(LRAUTO,"^")
|
||||
. D ERROR,EXIT
|
||||
. I '$D(ZTQUEUED) D ;
|
||||
. . W $C(7),!!,"You must have a MESSAGE CONFIGURATION defined in field 8 of"
|
||||
. . W !,"the AUTO INSTRUMENT file before downloading to this instrument!"
|
||||
. ;
|
||||
;
|
||||
I '$P(^LAHM(62.48,LA76248,0),"^",3) D Q
|
||||
. S XQAMSG="STATUS field in the LA7 MESSAGE PARAMETER file not turned on for "_$P(LRAUTO,"^")
|
||||
. D ERROR,EXIT
|
||||
. I '$D(ZTQUEUED) D ;
|
||||
. . W $C(7),!!,"The STATUS field in the LA7 MESSAGE PARAMETER file must be "
|
||||
. . W !,"turned on before downloading to this instrument!"
|
||||
. ;
|
||||
;
|
||||
S LA7MODE=$P(^LAHM(62.48,LA76248,0),"^",4)
|
||||
;
|
||||
; Call the routine specified in the PROCESS DOWNLOAD field in file 62.48
|
||||
; Download for one whole load list is done
|
||||
X $G(^LAHM(62.48,LA76248,2))
|
||||
;
|
||||
EXIT I '$G(LA7ADL) K ^TMP("LA7",$J),LA76248
|
||||
Q
|
||||
;
|
||||
;
|
||||
ERROR ; Send warning of error in Auto Instrument file configuration.
|
||||
S XQA("G.LAB MESSAGING")=""
|
||||
D SETUP^XQALERT
|
||||
K XQA,XQAMSG
|
||||
Q
|
||||
LA7UID ;DALOI/JMC - BUILD HL7 DOWNLOAD TO UI; 12/3/1997
|
||||
;;5.2;AUTOMATED LAB INSTRUMENTS;**17,57**;Sep 27, 1994
|
||||
Q
|
||||
;
|
||||
EN ;; This line tag is called from ^LADOWN when downloading
|
||||
; a load work list to the Auto Instrument.
|
||||
;
|
||||
; LRLL= IEN in 68.2 Load Worklist file, from field in 62.4
|
||||
; LRINST= IEN IN 62.4 Auto Inst file
|
||||
; LRAUTO= zero node of 62.4 entry
|
||||
;
|
||||
S LA7INST=LRINST
|
||||
I '$G(LA7ADL) D BLDINST^LA7ADL1(LA7INST,LRLL)
|
||||
S LA76248=$P(^LAB(62.4,LA7INST,0),"^",8)
|
||||
I 'LA76248 D Q
|
||||
. I '$D(ZTQUEUED) D
|
||||
. . W $C(7),!!,"You must have a MESSAGE CONFIGURATION defined in field 8 of"
|
||||
. . W !,"the AUTO INSTRUMENT file before downloading to this instrument!"
|
||||
. S XQAMSG="MESSAGE CONFIGURATION not defined in AUTO INSTRUMENT file for "_$P(LRAUTO,"^")
|
||||
. D ERROR
|
||||
. D EXIT
|
||||
;
|
||||
I '$P(^LAHM(62.48,LA76248,0),"^",3) D Q
|
||||
. I '$D(ZTQUEUED) D
|
||||
. . W $C(7),!!,"The STATUS field in the MESSAGE PARAMETER file must be "
|
||||
. . W !,"turned on before downloading to this instrument!"
|
||||
. S XQAMSG="STATUS field in the MESSAGE PARAMETER file not turned on for "_$P(LRAUTO,"^")
|
||||
. D ERROR
|
||||
. D EXIT
|
||||
;
|
||||
S LA7MODE=$P(^LAHM(62.48,LA76248,0),"^",4)
|
||||
;
|
||||
;
|
||||
CALL ; Call the routine specified in the PROCESS DOWNLOAD field
|
||||
; in file 62.48
|
||||
X $G(^LAHM(62.48,LA76248,2))
|
||||
;
|
||||
;
|
||||
EXIT ; Download for one whole load list is done
|
||||
I '$G(LA7ADL) K ^TMP("LA7-INST",$J),LA76248,LA7MODE
|
||||
Q
|
||||
;
|
||||
;
|
||||
ERROR ; Send warning of error in Auto Instrument file configuration.
|
||||
;
|
||||
S XQA("G.LAB MESSAGING")=""
|
||||
D SETUP^XQALERT
|
||||
Q
|
||||
|
|
|
|||
|
|
@ -1,265 +1,263 @@
|
|||
LA7VIN4 ;DALOI/JMC - Process Incoming UI Msgs, continued ; 7/27/07 11:24am
|
||||
;;5.2;AUTOMATED LAB INSTRUMENTS;**46,64,67,66**;Sep 27, 1994;Build 30
|
||||
;This routine is a continuation of LA7VIN1 and is only called from there.
|
||||
Q
|
||||
;
|
||||
OBR ; Process OBR segments
|
||||
N I,LA7CUP,LA7ENTRY,LA7IDE,LA7INST,LA7PDUZ,LA7TRAY,LA7X,LA7Y
|
||||
;
|
||||
; OBR Set ID
|
||||
S LA7SOBR=$$P^LA7VHLU(.LA7SEG,2,LA7FS)
|
||||
;
|
||||
S LA7X=$$P^LA7VHLU(.LA7SEG,19,LA7FS)
|
||||
S LA7X=$$UNESC^LA7VHLU3(LA7X,LA7FS_LA7ECH)
|
||||
S LA7624=0,LA7INST=$P(LA7X,"^") ; extracting 1st piece
|
||||
; Look up #62.4 entry from instrument name.
|
||||
I LA7INST'="" S LA7624=+$O(^LAB(62.4,"B",LA7INST,0))
|
||||
;
|
||||
; If none then use sending application name to look up #62.4 entry.
|
||||
I 'LA7624 S LA7624=+$O(^LAB(62.4,"B",LA7SAP,0))
|
||||
;
|
||||
; Instrument name not found in xref
|
||||
I 'LA7624 D Q
|
||||
. I LA7INST="" D Q
|
||||
. . S LA7ERR=10,LA7QUIT=2
|
||||
. . D CREATE^LA7LOG(LA7ERR)
|
||||
. S LA7ERR=11,LA7QUIT=2
|
||||
. D CREATE^LA7LOG(LA7ERR)
|
||||
S LA7624(0)=$G(^LAB(62.4,LA7624,0))
|
||||
S LA7ID=$P(LA7624(0),"^")_"-I-"
|
||||
;
|
||||
S LA7LWL=+$P(LA7624(0),"^",4) ; Load/Work List
|
||||
S LA7ENTRY=$P(LA7624(0),"^",6) ;LOG,LLIST,IDENT or SEQN
|
||||
S:LA7ENTRY="" LA7ENTRY="LOG"
|
||||
;
|
||||
; Placer(sender)/filler order numbers
|
||||
S LA7X=$$P^LA7VHLU(.LA7SEG,3,LA7FS)
|
||||
S LA7SID=$P(LA7X,$E(LA7ECH)) F I=2:1:4 S LA7SID(I)=$P(LA7X,$E(LA7ECH),I)
|
||||
S LA7X=$$P^LA7VHLU(.LA7SEG,4,LA7FS)
|
||||
S LA7FID=$P(LA7X,$E(LA7ECH)) F I=2:1:4 S LA7FID(I)=$P(LA7X,$E(LA7ECH),I)
|
||||
;
|
||||
; Test order code - find order NLT code
|
||||
; If POC interface then see if NLT is used for ordering code
|
||||
S LA7X=$$P^LA7VHLU(.LA7SEG,5,LA7FS),LA7ONLT=""
|
||||
F I=1,4 D Q:LA7ONLT'=""
|
||||
. I $P(LA7X,LA7CS,I)'?5N1"."4N Q
|
||||
. I $P(LA7X,LA7CS,I+2)="99VA64" S LA7ONLT=$P(LA7X,LA7CS,I),LA7ONLT(0)=$P(LA7X,LA7CS,I+1) Q
|
||||
. I LA7INTYP>19,LA7INTYP<30,$P(LA7X,LA7CS,I+2)="" S LA7ONLT=$P(LA7X,LA7CS,I),LA7ONLT(0)=$P(LA7X,LA7CS,I+1) Q
|
||||
;
|
||||
; Specimen collection date/time
|
||||
S LA7CDT=$$HL7TFM^XLFDT($P($$P^LA7VHLU(.LA7SEG,8,LA7FS),LA7CS),"L")
|
||||
;
|
||||
; Pull info from placer field #2 (OBR-19)
|
||||
S LA7X=$$P^LA7VHLU(.LA7SEG,20,LA7FS)
|
||||
S LA7X=$$UNESC^LA7VHLU3(LA7X,LA7FS_LA7ECH)
|
||||
S LA7TRAY=+$P(LA7X,"^",1) ;Tray
|
||||
S LA7CUP=+$P(LA7X,"^",2) ; Cup
|
||||
; If POC interface set cup to file #62.49 ien
|
||||
I LA7INTYP>19,LA7INTYP<30 S LA7CUP=LA76249
|
||||
S LA7AA=$P(LA7X,"^",3) ; Accession Area
|
||||
S LA7AD=$P(LA7X,"^",4) ; Accession Date
|
||||
S LA7AN=$P(LA7X,"^",5) ; Accession Entry
|
||||
S LA7ACC=$P(LA7X,"^",6) ; Accession
|
||||
S LA7UID=$P(LA7X,"^",7) ; Unique ID
|
||||
I LA7UID'?1(10UN,15UN) S LA7UID=""
|
||||
;
|
||||
; Sequence Number
|
||||
; If point of care interface (20-29) then use file #62.49 ien as IDE
|
||||
S LA7IDE=$P(LA7X,LA7CS,8)
|
||||
I LA7INTYP>19,LA7INTYP<30 S LA7IDE=LA76249
|
||||
;
|
||||
; UID might come as Sample ID
|
||||
I LA7UID="",LA7SID?1(10UN,15UN) S LA7UID=LA7SID
|
||||
;
|
||||
; Try to figure out LA7AA LA7AD LA7AN by using the unique ID (UID)
|
||||
; accession may have rolled over, use UID to get current accession info.
|
||||
I LA7UID]"" D
|
||||
. N X
|
||||
. S X=$Q(^LRO(68,"C",LA7UID))
|
||||
. I $QS(X,3)'=LA7UID S LA7UID="" Q ; UID not on file.
|
||||
. S LA7AA=+$QS(X,4),LA7AD=+$QS(X,5),LA7AN=+$QS(X,6)
|
||||
. D SETID^LA7VHLU1(LA76249,LA7ID,LA7UID)
|
||||
;
|
||||
; If still not known, compute from default accession date and area.
|
||||
; Calculate accession date based on accession transform.
|
||||
I LA7AA<1!(LA7AD<1)!(LA7AN<1) D
|
||||
. N X
|
||||
. S LA7AA=+$P(LA7624(0),"^",11)
|
||||
. S X=$P($G(^LRO(68,LA7AA,0)),U,3)
|
||||
. S LA7AD=$S(X="D":DT,X="M":$E(DT,1,5)_"00",X="Y":$E(DT,1,3)_"0000",X="Q":$E(DT,1,3)_"0000"+(($E(DT,4,5)-1)\3*300+100),1:DT)
|
||||
. S LA7AN=+LA7SID
|
||||
. I LA7AN>0 D SETID^LA7VHLU1(LA76249,LA7ID,LA7AN) Q
|
||||
. D SETID^LA7VHLU1(LA76249,LA7ID,$S($G(LA7PNM)]"":LA7PNM,$G(LA7SSN)]"":LA7SSN,1:"NO ID"))
|
||||
;
|
||||
; Zeroth node of accession area.
|
||||
S LA7AA(0)=$G(^LRO(68,+LA7AA,0))
|
||||
; Accession's subscript
|
||||
S LA7SS=$P(LA7AA(0),"^",2)
|
||||
;
|
||||
; Specimen action code
|
||||
S LA7SAC=$$P^LA7VHLU(.LA7SEG,12,LA7FS)
|
||||
;
|
||||
; Specimen(topography), collection sample, HL7 specimen source
|
||||
S (LA761,LA762,LA70070,LA7SPEC)=""
|
||||
S LA7SPTY=$$P^LA7VHLU(.LA7SEG,16,LA7FS)
|
||||
;
|
||||
; Check if using HL7 table 0070
|
||||
S LA7X=$P($P(LA7SPTY,LA7CS),$E(LA7ECH,4),3)
|
||||
I LA7X=""!(LA7X="HL70070") S LA7SPEC=$P($P(LA7SPTY,LA7CS),$E(LA7ECH,4))
|
||||
;
|
||||
I $O(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,5,0)) D
|
||||
. N X
|
||||
. S X=$O(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,5,0))
|
||||
. ; specimen^collection sample
|
||||
. S X(0)=$G(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,5,X,0))
|
||||
. S LA761=$P(X(0),"^") ; specimen
|
||||
. S LA762=$P(X(0),"^",2) ; collection sample
|
||||
. ; HL7 code
|
||||
. I LA761 S LA70070=$$GET1^DIQ(61,LA761_",","LEDI HL7:HL7 ABBR")
|
||||
;
|
||||
; Log error when specimen source does not match accession's specimen
|
||||
I LA70070'="",LA7SPEC'="",LA70070'=LA7SPEC D
|
||||
. ; Ignore if specimen related to lab control file #62.3
|
||||
. I $P($G(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,0)),"^",2)=62.3 Q
|
||||
. N LA7OBR
|
||||
. S LA7OBR(15)=LA7SPEC ; backward compatible with old code
|
||||
. S LA7ERR=22,LA7QUIT=2
|
||||
. D CREATE^LA7LOG(LA7ERR)
|
||||
;
|
||||
; Don't continue if flag set to skip this segment
|
||||
I LA7QUIT Q
|
||||
;
|
||||
; Placer's ordering provider (id^duz^last name, first name, mi [id])
|
||||
I $G(LA7POP)="" D
|
||||
. S LA7POP="",LA7X=$$P^LA7VHLU(.LA7SEG,17,LA7FS)
|
||||
. I LA7X="" Q
|
||||
. S LA7POP=$$XCNTFM^LA7VHLU4(LA7X,LA7ECH)
|
||||
. I LA7POP="^^" S LA7POP=""
|
||||
;
|
||||
; Create entry in LAH for supported subscripts.
|
||||
I LA7MTYP="ORR",$G(LA7OTYPE)'="OK","CHMI"[LA7SS D
|
||||
. D LAGEN
|
||||
. I $G(LA7ISQN)="" D CREATE^LA7LOG(14) Q
|
||||
. S LA7I=$O(^TMP("LA7 ORDER STATUS",$J,""),-1),LA7I=LA7I+1
|
||||
. I LA7ONLT="" S X=$$P^LA7VHLU(.LA7SEG,5,LA7FS),LA7X=$P(X,LA7CS),LA7X(0)=$P(X,LA7CS,2)
|
||||
. E S LA7X=LA7ONLT,LA7X(0)=LA7ONLT(0)
|
||||
. S X=LA7LWL_"^"_LA7ISQN_"^"_LA7X_"^"_LA7X(0)_"^"_LA76248_"^"_LA76249_"^"_LA7OTYPE_"^^"_$P($G(LA7SM),"^",2)
|
||||
. S ^TMP("LA7 ORDER STATUS",$J,LA7I)=X
|
||||
. I $G(LA7OCR)'="" S ^TMP("LA7 ORDER STATUS",$J,LA7I,"OCR")=$TR(LA7OCR,LA7CS,"^")
|
||||
. I $G(LA7MSATM)'="" S ^TMP("LA7 ORDER STATUS",$J,LA7I,"MSA")=LA7MSATM
|
||||
;
|
||||
I LA7MTYP="ORU","CHMI"[LA7SS D
|
||||
. D LAGEN
|
||||
. I $G(LA7ISQN)<1 D CREATE^LA7LOG(14) Q
|
||||
. I LA7INTYP=10,LA7SAC?1(1"A",1"G") D
|
||||
. . S LA7I=$O(^TMP("LA7 ORDER STATUS",$J,""),-1),LA7I=LA7I+1,LA7SAC(0)=LA7I
|
||||
. . I LA7ONLT="" S X=$$P^LA7VHLU(.LA7SEG,5,LA7FS),LA7X=$P(X,LA7CS),LA7X(0)=$P(X,LA7CS,2)
|
||||
. . E S LA7X=LA7ONLT,LA7X(0)=LA7ONLT(0)
|
||||
. . S X=LA7LWL_"^"_LA7ISQN_"^"_LA7X_"^"_LA7X(0)_"^"_LA76248_"^"_LA76249_"^"_$G(LA7OTYPE)_"^"_LA7SAC_"^"_$P($G(LA7SM),"^",2)
|
||||
. . S ^TMP("LA7 ORDER STATUS",$J,LA7I)=X
|
||||
;
|
||||
I LA7INTYP=10,$G(LA7SM)'="",$G(LA7UID)'="" D SMUPDT
|
||||
Q
|
||||
;
|
||||
;
|
||||
LAGEN ; Sets up variables for call to ^LAGEN, build entry in LAH
|
||||
; requires LA7INST,LA7TRAY,LA7CUP,LA7AA,LA7AD,LA7AN,LA7LWL
|
||||
; returns LA7ISQN=subscript to store results in ^LAH global
|
||||
;
|
||||
I LA7ENTRY="LOG" D
|
||||
. I LA7INTYP>19,LA7INTYP<30 Q
|
||||
. I '$D(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,0)) D CREATE^LA7LOG(13)
|
||||
I LA7ENTRY="LLIST" S:'LA7CUP LA7CUP=LA7IDE ;cup=sequence number
|
||||
;
|
||||
K LA7ISQN,LADT,LAGEN
|
||||
K TRAY,CUP,LWL,WL,LROVER,METH,LOG,IDENT,ISQN
|
||||
;
|
||||
S LA7ISQN=""
|
||||
S TRAY=+$G(LA7TRAY) S:'TRAY TRAY=1
|
||||
S CUP=+$G(LA7CUP) S:'CUP CUP=1
|
||||
;
|
||||
S LWL=LA7LWL
|
||||
I '$D(^LRO(68.2,+LWL,0)) D Q
|
||||
. D CREATE^LA7LOG(19)
|
||||
;
|
||||
; Set accession area to area of specimen, allow multiple areas on same instrument.
|
||||
S WL=LA7AA
|
||||
I '$D(^LRO(68,+WL,0)) D Q
|
||||
. D CREATE^LA7LOG(20)
|
||||
S LROVER=$P(LA7624(0),"^",12)
|
||||
S METH=$P(LA7624(0),"^",10)
|
||||
S LOG=LA7AN
|
||||
S IDENT=$P($G(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,0)),"^",6) ;identity field
|
||||
S IDE=+LA7IDE
|
||||
S LADT=LA7AD
|
||||
;
|
||||
; If POC interface call special entry point
|
||||
D
|
||||
. N LRDFN ; Protect LRDFN - call into LAGEN can set to 0
|
||||
. I LA7INTYP>19,LA7INTYP<30 S IDE=LA76249 D POC^LAGEN Q
|
||||
. D @(LA7ENTRY_"^LAGEN") ;this disregards the CROSS LINK field in 62.4
|
||||
S LA7ISQN=$G(ISQN)
|
||||
;
|
||||
I LA7ISQN<1 Q
|
||||
;
|
||||
; Build/store patient demographics array
|
||||
N I,J,LA7OBRA,LA7PIDA,X,Y
|
||||
S J="DFN^DOB^ICN^LOC^LRDFN^LRTDFN^PNM^SEX^SSN"
|
||||
S J(0)="DFN^LA7DOB^LA7ICN^LA7LOC^LRDFN^LRTDFN^LA7PNM^LA7SEX^LA7SSN"
|
||||
F I=1:1 S X=$P(J,"^",I) Q:X="" D
|
||||
. S Y=$P(J(0),"^",I)
|
||||
. I $G(@Y)'="" S LA7PIDA(X)=@Y
|
||||
I $D(LA7PIDA) D POI^LAGEN(LA7LWL,LA7ISQN,"PID",.LA7PIDA)
|
||||
;
|
||||
; Build/store order info array
|
||||
N LA7ONLTS
|
||||
I LA7POP'="" S LA7POP=$P(LA7POP," [")
|
||||
S X=$G(^LAH(LA7LWL,1,LA7ISQN,.1,"OBR","ORDNLT"))
|
||||
I X'="",LA7ONLT'="",X'[LA7ONLT S LA7ONLTS=X_"^"_LA7ONLT
|
||||
E S LA7ONLTS=LA7ONLT
|
||||
S J="EOL^FID^ORCDT^ORDNLT^ORDP^ORDSPEC^PON^SID^PEB^PVB"
|
||||
S J(0)="LA7EOL^LA7FID^LA7CDT^LA7ONLTS^LA7POP^LA7SPEC^LA7PON^LA7SID^LA7PEB^LA7PVB"
|
||||
F I=1:1 S X=$P(J,"^",I) Q:X="" D
|
||||
. S Y=$P(J(0),"^",I)
|
||||
. I $G(@Y)'="" S LA7OBRA(X)=@Y
|
||||
I $D(LA7OBRA) D POI^LAGEN(LA7LWL,LA7ISQN,"OBR",.LA7OBRA)
|
||||
;
|
||||
; Store interface type with results
|
||||
D LATYP^LAGEN(LA7LWL,LA7ISQN,LA7INTYP)
|
||||
;
|
||||
; Store #62.49 ien with results
|
||||
D LAMSGID^LAGEN(LA7LWL,LA7ISQN,LA76249)
|
||||
;
|
||||
; Store method name with LAH entry
|
||||
D METH^LAGEN(LA7LWL,LA7ISQN,METH)
|
||||
;
|
||||
; Set flag if POC interface to start POC processing routine when
|
||||
; finished - tasked by LA7VIN before shutdown
|
||||
I LA7INTYP>19,LA7INTYP<30 S LA7INTYP("LWL",LA7LWL)=""
|
||||
;
|
||||
Q
|
||||
;
|
||||
;
|
||||
SMUPDT ; Update shipping manifest in shipping event file #62.85
|
||||
N LA7DATA,LA7NCS,LA7TST,LA7USID
|
||||
;
|
||||
S LA7USID=$$P^LA7VHLU(.LA7SEG,5,LA7FS) ; Universal Service ID (OBR-4)
|
||||
S LA7TST=$P(LA7USID,LA7CS,1) ; Test code
|
||||
S LA7NCS=$P(LA7USID,LA7CS,3) ; Name of coding system
|
||||
S LA7TST(2)=$P(LA7USID,LA7CS,4) ; Alternate test code
|
||||
S LA7NCS(2)=$P(LA7USID,LA7CS,6) ; Alternate coding system
|
||||
;
|
||||
; Determine ordered test, check primary and alternate
|
||||
S LA7OTST=$$DOT^LA7SMU1(LA7TST,LA7NCS,LA7UID,$P(LA7SM,"^"))
|
||||
I 'LA7OTST,LA7TST(2)'="" S LA7OTST=$$DOT^LA7SMU1(LA7TST(2),LA7NCS(2),LA7UID,$P(LA7SM,"^"))
|
||||
;
|
||||
; Flag the Results Received Event in #62.85
|
||||
I LA7MTYP="ORU" D
|
||||
. S LA7DATA="SM70"_"^"_LA7MEDT_"^"_$G(LA7OTST)_"^"_$P(LA7SM,"^",2)
|
||||
. D SEUP^LA7SMU(LA7UID,"2",LA7DATA)
|
||||
;
|
||||
; Flag the Test Received Event in #62.85
|
||||
I LA7MTYP="ORR" D
|
||||
. S LA7DATA="SM55"_"^"_LA7MEDT_"^"_$G(LA7OTST)_"^"_$P(LA7SM,"^",2)
|
||||
. D SEUP^LA7SMU(LA7UID,"2",LA7DATA)
|
||||
Q
|
||||
LA7VIN4 ;DALOI/JMC - Process Incoming UI Msgs, continued ; Jan 12, 2004
|
||||
;;5.2;AUTOMATED LAB INSTRUMENTS;**46,64,67**;Sep 27, 1994
|
||||
;This routine is a continuation of LA7VIN1 and is only called from there.
|
||||
Q
|
||||
;
|
||||
OBR ; Process OBR segments
|
||||
N I,LA7CUP,LA7ENTRY,LA7IDE,LA7INST,LA7PDUZ,LA7TRAY,LA7X,LA7Y
|
||||
;
|
||||
; OBR Set ID
|
||||
S LA7SOBR=$$P^LA7VHLU(.LA7SEG,2,LA7FS)
|
||||
;
|
||||
S LA7X=$$P^LA7VHLU(.LA7SEG,19,LA7FS)
|
||||
S LA7X=$$UNESC^LA7VHLU3(LA7X,LA7FS_LA7ECH)
|
||||
S LA7624=0,LA7INST=$P(LA7X,"^") ; extracting 1st piece
|
||||
; Look up #62.4 entry from instrument name.
|
||||
I LA7INST'="" S LA7624=+$O(^LAB(62.4,"B",LA7INST,0))
|
||||
;
|
||||
; If none then use sending application name to look up #62.4 entry.
|
||||
I 'LA7624 S LA7624=+$O(^LAB(62.4,"B",LA7SAP,0))
|
||||
;
|
||||
; Instrument name not found in xref
|
||||
I 'LA7624 D Q
|
||||
. I LA7INST="" D Q
|
||||
. . S LA7ERR=10,LA7QUIT=2
|
||||
. . D CREATE^LA7LOG(LA7ERR)
|
||||
. S LA7ERR=11,LA7QUIT=2
|
||||
. D CREATE^LA7LOG(LA7ERR)
|
||||
S LA7624(0)=$G(^LAB(62.4,LA7624,0))
|
||||
S LA7ID=$P(LA7624(0),"^")_"-I-"
|
||||
;
|
||||
S LA7LWL=+$P(LA7624(0),"^",4) ; Load/Work List
|
||||
S LA7ENTRY=$P(LA7624(0),"^",6) ;LOG,LLIST,IDENT or SEQN
|
||||
S:LA7ENTRY="" LA7ENTRY="LOG"
|
||||
;
|
||||
; Placer(sender)/filler order numbers
|
||||
S LA7X=$$P^LA7VHLU(.LA7SEG,3,LA7FS)
|
||||
S LA7SID=$P(LA7X,$E(LA7ECH)) F I=2:1:4 S LA7SID(I)=$P(LA7X,$E(LA7ECH),I)
|
||||
S LA7X=$$P^LA7VHLU(.LA7SEG,4,LA7FS)
|
||||
S LA7FID=$P(LA7X,$E(LA7ECH)) F I=2:1:4 S LA7FID(I)=$P(LA7X,$E(LA7ECH),I)
|
||||
;
|
||||
; Test order code - find order NLT code
|
||||
; If POC interface then see if NLT is used for ordering code
|
||||
S LA7X=$$P^LA7VHLU(.LA7SEG,5,LA7FS),LA7ONLT=""
|
||||
F I=1,4 D Q:LA7ONLT'=""
|
||||
. I $P(LA7X,LA7CS,I)'?5N1"."4N Q
|
||||
. I $P(LA7X,LA7CS,I+2)="99VA64" S LA7ONLT=$P(LA7X,LA7CS,I),LA7ONLT(0)=$P(LA7X,LA7CS,I+1) Q
|
||||
. I LA7INTYP>19,LA7INTYP<30,$P(LA7X,LA7CS,I+2)="" S LA7ONLT=$P(LA7X,LA7CS,I),LA7ONLT(0)=$P(LA7X,LA7CS,I+1) Q
|
||||
;
|
||||
; Specimen collection date/time
|
||||
S LA7CDT=$$HL7TFM^XLFDT($P($$P^LA7VHLU(.LA7SEG,8,LA7FS),LA7CS),"L")
|
||||
;
|
||||
; Pull info from placer field #2 (OBR-19)
|
||||
S LA7X=$$P^LA7VHLU(.LA7SEG,20,LA7FS)
|
||||
S LA7X=$$UNESC^LA7VHLU3(LA7X,LA7FS_LA7ECH)
|
||||
S LA7TRAY=+$P(LA7X,"^",1) ;Tray
|
||||
S LA7CUP=+$P(LA7X,"^",2) ; Cup
|
||||
; If POC interface set cup to file #62.49 ien
|
||||
I LA7INTYP>19,LA7INTYP<30 S LA7CUP=LA76249
|
||||
S LA7AA=$P(LA7X,"^",3) ; Accession Area
|
||||
S LA7AD=$P(LA7X,"^",4) ; Accession Date
|
||||
S LA7AN=$P(LA7X,"^",5) ; Accession Entry
|
||||
S LA7ACC=$P(LA7X,"^",6) ; Accession
|
||||
S LA7UID=$P(LA7X,"^",7) ; Unique ID
|
||||
I LA7UID'?1(10UN,15UN) S LA7UID=""
|
||||
;
|
||||
; Sequence Number
|
||||
; If point of care interface (20-29) then use file #62.49 ien as IDE
|
||||
S LA7IDE=$P(LA7X,LA7CS,8)
|
||||
I LA7INTYP>19,LA7INTYP<30 S LA7IDE=LA76249
|
||||
;
|
||||
; UID might come as Sample ID
|
||||
I LA7UID="",LA7SID?1(10UN,15UN) S LA7UID=LA7SID
|
||||
;
|
||||
; Try to figure out LA7AA LA7AD LA7AN by using the unique ID (UID)
|
||||
; accession may have rolled over, use UID to get current accession info.
|
||||
I LA7UID]"" D
|
||||
. N X
|
||||
. S X=$Q(^LRO(68,"C",LA7UID))
|
||||
. I $QS(X,3)'=LA7UID S LA7UID="" Q ; UID not on file.
|
||||
. S LA7AA=+$QS(X,4),LA7AD=+$QS(X,5),LA7AN=+$QS(X,6)
|
||||
. D SETID^LA7VHLU1(LA76249,LA7ID,LA7UID)
|
||||
;
|
||||
; If still not known, compute from default accession date and area.
|
||||
; Calculate accession date based on accession transform.
|
||||
I LA7AA<1!(LA7AD<1)!(LA7AN<1) D
|
||||
. N X
|
||||
. S LA7AA=+$P(LA7624(0),"^",11)
|
||||
. S X=$P($G(^LRO(68,LA7AA,0)),U,3)
|
||||
. S LA7AD=$S(X="D":DT,X="M":$E(DT,1,5)_"00",X="Y":$E(DT,1,3)_"0000",X="Q":$E(DT,1,3)_"0000"+(($E(DT,4,5)-1)\3*300+100),1:DT)
|
||||
. S LA7AN=+LA7SID
|
||||
. I LA7AN>0 D SETID^LA7VHLU1(LA76249,LA7ID,LA7AN)
|
||||
. E D SETID^LA7VHLU1(LA76249,LA7ID,$S(LA7PNM]"":LA7PNM,LA7SSN]"":LA7SSN,1:"NO ID"))
|
||||
;
|
||||
; Zeroth node of acession area.
|
||||
S LA7AA(0)=$G(^LRO(68,+LA7AA,0))
|
||||
; Accession's subscript
|
||||
S LA7SS=$P(LA7AA(0),"^",2)
|
||||
;
|
||||
; Specimen action code
|
||||
S LA7SAC=$$P^LA7VHLU(.LA7SEG,12,LA7FS)
|
||||
;
|
||||
; Specimen(topography), collection sample, HL7 specimen source
|
||||
S (LA761,LA762,LA70070,LA7SPEC)=""
|
||||
S LA7SPTY=$$P^LA7VHLU(.LA7SEG,16,LA7FS)
|
||||
;
|
||||
; Check if using HL7 table 0070
|
||||
S LA7X=$P($P(LA7SPTY,LA7CS),$E(LA7ECH,4),3)
|
||||
I LA7X=""!(LA7X="HL70070") S LA7SPEC=$P($P(LA7SPTY,LA7CS),$E(LA7ECH,4))
|
||||
;
|
||||
I $O(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,5,0)) D
|
||||
. N X
|
||||
. S X=$O(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,5,0))
|
||||
. ; specimen^collection sample
|
||||
. S X(0)=$G(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,5,X,0))
|
||||
. S LA761=$P(X(0),"^") ; specimen
|
||||
. S LA762=$P(X(0),"^",2) ; collection sample
|
||||
. ; HL7 code
|
||||
. I LA761 S LA70070=$$GET1^DIQ(61,LA761_",","LEDI HL7:HL7 ABBR")
|
||||
;
|
||||
; Log error when specimen source does not match accession's specimen
|
||||
I LA70070'="",LA7SPEC'="",LA70070'=LA7SPEC D
|
||||
. N LA7OBR
|
||||
. S LA7OBR(15)=LA7SPEC ; backward compatible with old code
|
||||
. S LA7ERR=22,LA7QUIT=2
|
||||
. D CREATE^LA7LOG(LA7ERR)
|
||||
;
|
||||
; Don't continue if flag set to skip this segment
|
||||
I LA7QUIT Q
|
||||
;
|
||||
; Placer's ordering provider (id^duz^last name, first name, mi [id])
|
||||
I $G(LA7POP)="" D
|
||||
. S LA7POP="",LA7X=$$P^LA7VHLU(.LA7SEG,17,LA7FS)
|
||||
. I LA7X="" Q
|
||||
. S LA7POP=$$XCNTFM^LA7VHLU4(LA7X,LA7ECH)
|
||||
. I LA7POP="^^" S LA7POP=""
|
||||
;
|
||||
; Create entry in LAH for supported subscripts.
|
||||
I LA7MTYP="ORR",$G(LA7OTYPE)'="OK","CHMI"[LA7SS D
|
||||
. D LAGEN
|
||||
. I $G(LA7ISQN)="" D CREATE^LA7LOG(14) Q
|
||||
. S LA7I=$O(^TMP("LA7 ORDER STATUS",$J,""),-1),LA7I=LA7I+1
|
||||
. I LA7ONLT="" S X=$$P^LA7VHLU(.LA7SEG,5,LA7FS),LA7X=$P(X,LA7CS),LA7X(0)=$P(X,LA7CS,2)
|
||||
. E S LA7X=LA7ONLT,LA7X(0)=LA7ONLT(0)
|
||||
. S X=LA7LWL_"^"_LA7ISQN_"^"_LA7X_"^"_LA7X(0)_"^"_LA76248_"^"_LA76249_"^"_LA7OTYPE_"^^"_$P($G(LA7SM),"^",2)
|
||||
. S ^TMP("LA7 ORDER STATUS",$J,LA7I)=X
|
||||
. I $G(LA7OCR)'="" S ^TMP("LA7 ORDER STATUS",$J,LA7I,"OCR")=$TR(LA7OCR,LA7CS,"^")
|
||||
. I $G(LA7MSATM)'="" S ^TMP("LA7 ORDER STATUS",$J,LA7I,"MSA")=LA7MSATM
|
||||
;
|
||||
I LA7MTYP="ORU","CHMI"[LA7SS D
|
||||
. D LAGEN
|
||||
. I $G(LA7ISQN)<1 D CREATE^LA7LOG(14) Q
|
||||
. I LA7INTYP=10,LA7SAC?1(1"A",1"G") D
|
||||
. . S LA7I=$O(^TMP("LA7 ORDER STATUS",$J,""),-1),LA7I=LA7I+1,LA7SAC(0)=LA7I
|
||||
. . I LA7ONLT="" S X=$$P^LA7VHLU(.LA7SEG,5,LA7FS),LA7X=$P(X,LA7CS),LA7X(0)=$P(X,LA7CS,2)
|
||||
. . E S LA7X=LA7ONLT,LA7X(0)=LA7ONLT(0)
|
||||
. . S X=LA7LWL_"^"_LA7ISQN_"^"_LA7X_"^"_LA7X(0)_"^"_LA76248_"^"_LA76249_"^"_$G(LA7OTYPE)_"^"_LA7SAC_"^"_$P($G(LA7SM),"^",2)
|
||||
. . S ^TMP("LA7 ORDER STATUS",$J,LA7I)=X
|
||||
;
|
||||
I LA7INTYP=10,$G(LA7SM)'="",$G(LA7UID)'="" D SMUPDT
|
||||
Q
|
||||
;
|
||||
;
|
||||
LAGEN ; Sets up variables for call to ^LAGEN, build entry in LAH
|
||||
; requires LA7INST,LA7TRAY,LA7CUP,LA7AA,LA7AD,LA7AN,LA7LWL
|
||||
; returns LA7ISQN=subscript to store results in ^LAH global
|
||||
;
|
||||
I LA7ENTRY="LOG" D
|
||||
. I LA7INTYP>19,LA7INTYP<30 Q
|
||||
. I '$D(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,0)) D CREATE^LA7LOG(13)
|
||||
I LA7ENTRY="LLIST" S:'LA7CUP LA7CUP=LA7IDE ;cup=sequence number
|
||||
;
|
||||
K LA7ISQN,LADT,LAGEN
|
||||
K TRAY,CUP,LWL,WL,LROVER,METH,LOG,IDENT,ISQN
|
||||
;
|
||||
S LA7ISQN=""
|
||||
S TRAY=+$G(LA7TRAY) S:'TRAY TRAY=1
|
||||
S CUP=+$G(LA7CUP) S:'CUP CUP=1
|
||||
;
|
||||
S LWL=LA7LWL
|
||||
I '$D(^LRO(68.2,+LWL,0)) D Q
|
||||
. D CREATE^LA7LOG(19)
|
||||
;
|
||||
; Set accession area to area of specimen, allow multiple areas on same instrument.
|
||||
S WL=LA7AA
|
||||
I '$D(^LRO(68,+WL,0)) D Q
|
||||
. D CREATE^LA7LOG(20)
|
||||
S LROVER=$P(LA7624(0),"^",12)
|
||||
S METH=$P(LA7624(0),"^",10)
|
||||
S LOG=LA7AN
|
||||
S IDENT=$P($G(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,0)),"^",6) ;identity field
|
||||
S IDE=+LA7IDE
|
||||
S LADT=LA7AD
|
||||
;
|
||||
; If POC interface call special entry point
|
||||
D
|
||||
. N LRDFN ; Protect LRDFN - call into LAGEN can set to 0
|
||||
. I LA7INTYP>19,LA7INTYP<30 S IDE=LA76249 D POC^LAGEN Q
|
||||
. D @(LA7ENTRY_"^LAGEN") ;this disregards the CROSS LINK field in 62.4
|
||||
S LA7ISQN=$G(ISQN)
|
||||
;
|
||||
I LA7ISQN<1 Q
|
||||
;
|
||||
; Build/store patient demographics array
|
||||
N I,J,LA7OBRA,LA7PIDA,X,Y
|
||||
S J="DFN^DOB^ICN^LOC^LRDFN^LRTDFN^PNM^SEX^SSN"
|
||||
S J(0)="DFN^LA7DOB^LA7ICN^LA7LOC^LRDFN^LRTDFN^LA7PNM^LA7SEX^LA7SSN"
|
||||
F I=1:1 S X=$P(J,"^",I) Q:X="" D
|
||||
. S Y=$P(J(0),"^",I)
|
||||
. I $G(@Y)'="" S LA7PIDA(X)=@Y
|
||||
I $D(LA7PIDA) D POI^LAGEN(LA7LWL,LA7ISQN,"PID",.LA7PIDA)
|
||||
;
|
||||
; Build/store order info array
|
||||
N LA7ONLTS
|
||||
I LA7POP'="" S LA7POP=$P(LA7POP," [")
|
||||
S X=$G(^LAH(LA7LWL,1,LA7ISQN,.1,"OBR","ORDNLT"))
|
||||
I X'="",LA7ONLT'="",X'[LA7ONLT S LA7ONLTS=X_"^"_LA7ONLT
|
||||
E S LA7ONLTS=LA7ONLT
|
||||
S J="EOL^FID^ORCDT^ORDNLT^ORDP^ORDSPEC^PON^SID^PEB^PVB"
|
||||
S J(0)="LA7EOL^LA7FID^LA7CDT^LA7ONLTS^LA7POP^LA7SPEC^LA7PON^LA7SID^LA7PEB^LA7PVB"
|
||||
F I=1:1 S X=$P(J,"^",I) Q:X="" D
|
||||
. S Y=$P(J(0),"^",I)
|
||||
. I $G(@Y)'="" S LA7OBRA(X)=@Y
|
||||
I $D(LA7OBRA) D POI^LAGEN(LA7LWL,LA7ISQN,"OBR",.LA7OBRA)
|
||||
;
|
||||
; Store interface type with results
|
||||
D LATYP^LAGEN(LA7LWL,LA7ISQN,LA7INTYP)
|
||||
;
|
||||
; Store #62.49 ien with results
|
||||
D LAMSGID^LAGEN(LA7LWL,LA7ISQN,LA76249)
|
||||
;
|
||||
; Store method name with LAH entry
|
||||
D METH^LAGEN(LA7LWL,LA7ISQN,METH)
|
||||
;
|
||||
; Set flag if POC interface to start POC processing routine when
|
||||
; finished - tasked by LA7VIN before shutdown
|
||||
I LA7INTYP>19,LA7INTYP<30 S LA7INTYP("LWL",LA7LWL)=""
|
||||
;
|
||||
Q
|
||||
;
|
||||
;
|
||||
SMUPDT ; Update shipping manifest in shipping event file #62.85
|
||||
N LA7DATA,LA7NCS,LA7TST,LA7USID
|
||||
;
|
||||
S LA7USID=$$P^LA7VHLU(.LA7SEG,5,LA7FS) ; Universal Service ID (OBR-4)
|
||||
S LA7TST=$P(LA7USID,LA7CS,1) ; Test code
|
||||
S LA7NCS=$P(LA7USID,LA7CS,3) ; Name of coding system
|
||||
S LA7TST(2)=$P(LA7USID,LA7CS,4) ; Alternate test code
|
||||
S LA7NCS(2)=$P(LA7USID,LA7CS,6) ; Alternate coding system
|
||||
;
|
||||
; Determine ordered test, check primary and alternate
|
||||
S LA7OTST=$$DOT^LA7SMU1(LA7TST,LA7NCS,LA7UID,$P(LA7SM,"^"))
|
||||
I 'LA7OTST,LA7TST(2)'="" S LA7OTST=$$DOT^LA7SMU1(LA7TST(2),LA7NCS(2),LA7UID,$P(LA7SM,"^"))
|
||||
;
|
||||
; Flag the Results Received Event in #62.85
|
||||
I LA7MTYP="ORU" D
|
||||
. S LA7DATA="SM70"_"^"_LA7MEDT_"^"_$G(LA7OTST)_"^"_$P(LA7SM,"^",2)
|
||||
. D SEUP^LA7SMU(LA7UID,"2",LA7DATA)
|
||||
;
|
||||
; Flag the Test Received Event in #62.85
|
||||
I LA7MTYP="ORR" D
|
||||
. S LA7DATA="SM55"_"^"_LA7MEDT_"^"_$G(LA7OTST)_"^"_$P(LA7SM,"^",2)
|
||||
. D SEUP^LA7SMU(LA7UID,"2",LA7DATA)
|
||||
Q
|
||||
|
|
|
|||
|
|
@ -1,279 +1,272 @@
|
|||
LA7VIN5A ;DALOI/JMC - Process Incoming UI Msgs, continued ;May 29, 2008
|
||||
;;5.2;AUTOMATED LAB INSTRUMENTS;**46,64,67,72,66**;Sep 27, 1994;Build 30
|
||||
; This routine is a continuation of LA7VIN5.
|
||||
; It is performs processing of fields in OBX segments.
|
||||
Q
|
||||
;
|
||||
XFORM ; Transform the result based on fields 12,13,14,16,17 in the Chem Test
|
||||
; multiple in the Auto Instrument file (62.4), or set on the fly
|
||||
; from PARAM 1
|
||||
N LA7I
|
||||
S LA7XFORM=LA76241(2)
|
||||
;
|
||||
; get PARAM 1 overrides
|
||||
I $D(LA7XFORM(1)),LA7XFORM(1)?1.N S $P(LA7XFORM,"^")=LA7XFORM(1)
|
||||
F LA7I=2,3,5,6 I $D(LA7XFORM(LA7I)) S $P(LA7XFORM,"^",LA7I)=LA7XFORM(LA7I)
|
||||
; set up defaults if field was not answered
|
||||
; accept results,yes
|
||||
I $P(LA7XFORM,"^",3)="" S $P(LA7XFORM,"^",3)=1
|
||||
; strip spaces,no
|
||||
I $P(LA7XFORM,"^",6)="" S $P(LA7XFORM,"^",6)=0
|
||||
; now transform
|
||||
;
|
||||
; Don't accept results
|
||||
I '$P(LA7XFORM,"^",3) S LA7VAL="" Q
|
||||
;
|
||||
; Only accept "FINAL" type results
|
||||
I $P(LA7XFORM,"^",3)=2,"CFUX"'[LA7ORS S LA7VAL="" Q
|
||||
;
|
||||
; Accept ordered tests only
|
||||
; If LEDI interface (10) and message indicates a reflex ("G") or add-on
|
||||
; test ("A") then process anyway in case it has not been added to
|
||||
; accession.
|
||||
I $P(LA7XFORM,"^",5) D
|
||||
. I LA7INTYP=10,LA7SAC?1(1"A",1"G") Q
|
||||
. S LA7LIMIT=1
|
||||
;
|
||||
; Decimal places if number of places defined
|
||||
I $P(LA7XFORM,"^")?1.N D JUSTDEC
|
||||
;
|
||||
; Strip spaces
|
||||
I $P(LA7XFORM,"^",6) S LA7VAL=$TR(LA7VAL," ","")
|
||||
;
|
||||
; Make result a comment
|
||||
; Set value to null after making into remark, don't store twice.
|
||||
I $P(LA7XFORM,"^",2) D
|
||||
. N LA7Y
|
||||
. ; Store comment in ^LAH global
|
||||
. S LA7Y=$P(LA7RMK(0,+LA76241(0)),"^",2)
|
||||
. D RMKSET^LASET(LA7LWL,LA7ISQN,LA7VAL,LA7Y)
|
||||
. S LA7VAL=""
|
||||
Q
|
||||
;
|
||||
;
|
||||
CHKDIE ; Check if value to be stored passes input transform of field in DD
|
||||
N LA7ERR,LA7Y
|
||||
;
|
||||
; If result is on a LEDI interface (type=10) then don't check result
|
||||
; against FileMan input transform.
|
||||
; VistA sends "canc" as test result when test is cancelled.
|
||||
; DoD sends "PL Canceled" --> change to "canc" for VistA storage.
|
||||
I LA7INTYP=10 D Q
|
||||
. I LA7VAL="PL Cancelled" S LA7VAL="canc"
|
||||
. I LA7VAL="PL Canceled" S LA7VAL="canc"
|
||||
. I LA7VAL="PLCanceled" S LA7VAL="canc"
|
||||
;
|
||||
; If value fails data checker then log error and suppress result.
|
||||
D CHK^DIE(LA7SUBFL,LA76304,"H",LA7VAL,.LA7Y,"LA7ERR")
|
||||
I LA7Y="^" D
|
||||
. N LA7X
|
||||
. S LA7X=$G(LA7ERR("DIERR",1,"TEXT",1))
|
||||
. D CREATE^LA7LOG(37)
|
||||
. S LA7VAL=""
|
||||
Q
|
||||
;
|
||||
;
|
||||
JUSTDEC ; Justify to number of places specified
|
||||
;
|
||||
N LA7DDTYP,LA7FMT,LA7I,LA7PRFIX,LA7X
|
||||
;
|
||||
; If LEDI interface (type=10) then skip decimal adjustment
|
||||
I LA7INTYP=10 Q
|
||||
;
|
||||
; Get data name field type from DD
|
||||
; Only justify if Vista field is numeric or free text.
|
||||
S LA7DDTYP=$$GET1^DID(LA7SUBFL,LA76304,"","TYPE")
|
||||
I "NUMERIC^FREE TEXT"'[LA7DDTYP D Q
|
||||
. N LA7FLDNM
|
||||
. S LA7FLDNM=$$GET1^DID(63.04,LA76304,"","LABEL")
|
||||
. D CREATE^LA7LOG(38)
|
||||
;
|
||||
S LA7X=LA7VAL,(LA7FMT,LA7PRFIX)=""
|
||||
;
|
||||
; If comma formatted, strip comma and set flag to add back in.
|
||||
S LA7X=$TR(LA7X,",","")
|
||||
I LA7X'=LA7VAL S LA7FMT="P"
|
||||
;
|
||||
; If "<>=" formatted, strip and save to add back in.
|
||||
F LA7I=1:1:$L(LA7X) Q:$E(LA7X,LA7I)'?1(1"<",1">",1"=")
|
||||
I LA7I>1 D
|
||||
. S LA7PRFIX=$E(LA7X,1,LA7I-1)
|
||||
. S LA7X=$E(LA7X,LA7I,$L(LA7X))
|
||||
;
|
||||
; Format if starts with number or decimal point, skip other results.
|
||||
I LA7X?1(1.N,.N1"."1.N) D
|
||||
. S LA7X=$FN(LA7X,LA7FMT,+LA7XFORM)
|
||||
. S LA7VAL=LA7PRFIX_LA7X
|
||||
Q
|
||||
;
|
||||
;
|
||||
PRDID(LA7PRDID,LA7SFAC,LA7CS) ; Process/Store Producer's ID
|
||||
; Store where test was performed.
|
||||
; Call with LA7PRDID = Producer's ID field
|
||||
; LA7SFAC = sending facility
|
||||
; LA7CS = component encoding character
|
||||
;
|
||||
; Remove units/reference ranges when Lab UI interface
|
||||
; so file #60 settings always used
|
||||
I $G(LA7INTYP)=1 S $P(^LAH(LA7LWL,1,LA7ISQN,LA76304),"^",5)="" Q
|
||||
;
|
||||
N LA74,LA7I,LA7X,LA7Y
|
||||
;
|
||||
S LA7X=$P(LA7PRDID,LA7CS,2),LA74=""
|
||||
;
|
||||
F LA7I=1,4 D Q:LA74
|
||||
. I $P(LA7PRDID,LA7CS,LA7I+2)="99VA4" S LA74=$$LKUP^XUAF4($P(LA7PRDID,LA7CS,LA7I))
|
||||
. I 'LA74,$P(LA7PRDID,LA7CS,LA7I+2)?1(1"L-CL",1"CLIA",1"99VACLIA") S LA74=$$IDX^XUAF4("CLIA",$P(LA7PRDID,LA7CS,LA7I))
|
||||
. I 'LA74 S LA74=$$LKUP^XUAF4($P(LA7PRDID,LA7CS,LA7I+1))
|
||||
. I 'LA74 S LA74=$$FINDSITE^LA7VHLU2($P(LA7PRDID,LA7CS),1,1)
|
||||
. I 'LA74 S LA74=$$FINDSITE^LA7VHLU2($P(LA7SFAC,LA7CS),1,1)
|
||||
;
|
||||
; Store producer's id in LAH global with results.
|
||||
I LA74 S $P(^LAH(LA7LWL,1,LA7ISQN,LA76304),"^",9)=LA74 Q
|
||||
;
|
||||
; Don't store producer's id as comment.
|
||||
I '$P(LA76241(2),"^",9) Q
|
||||
; If unable to identify producer in file #4
|
||||
; then store as comment if field STORE PRODUCER'S ID (#20) enabled.
|
||||
I LA7X="" Q
|
||||
S LA7Y=$P(LA7RMK(0,+LA76241(0)),"^",2)
|
||||
S LA7X=$S(LA7Y="":"P",1:"p")_"erformed by "_LA7X
|
||||
D RMKSET^LASET(LA7LWL,LA7ISQN,LA7X,LA7Y)
|
||||
;
|
||||
Q
|
||||
;
|
||||
;
|
||||
REFRNG(LA7X) ; Process/Store References Range.
|
||||
; Call with LA7X = reference range to store.
|
||||
;
|
||||
Q:$G(LA7INTYP)=1
|
||||
N LA7Y,X,Y
|
||||
;
|
||||
; Check if site does not want to store reference ranges on POC test.
|
||||
I LA7INTYP>19,LA7INTYP<30,+$P(LA76241(2),"^",10)=0 Q
|
||||
;
|
||||
; Remove leading and trailing quotes from reference range.
|
||||
S LA7X=$$TRIM^XLFSTR($G(LA7X),"RL","""")
|
||||
I LA7X="" Q
|
||||
;
|
||||
S X=$P($G(^LAH(LA7LWL,1,LA7ISQN,LA76304)),"^",5)
|
||||
;
|
||||
; >lower limit (no upper limit e.g. >10) - store as low value
|
||||
I LA7X?1">".N.1".".N S $P(X,"!",2)=$TR(LA7X,">",""),LA7X=""
|
||||
;
|
||||
; <upper limit (no lower limit e.g. <15) - store as high value
|
||||
I LA7X?1"<".N.1".".N S $P(X,"!",3)=$TR(LA7X,"<",""),LA7X=""
|
||||
;
|
||||
; Alphabetic reference with hyphen
|
||||
I LA7X?1.A1"-"1.A S $P(X,"!",2)=$C(34)_LA7X_$C(34),LA7X=""
|
||||
;
|
||||
; Lower limit value
|
||||
S Y=$P(LA7X,"-")
|
||||
I Y'="" D
|
||||
. I Y?.N.1".".N S $P(X,"!",2)=Y
|
||||
. E S $P(X,"!",2)=$C(34)_$$UNESC^LA7VHLU3(Y,LA7FS_LA7ECH)_$C(34)
|
||||
;
|
||||
; Upper limit value
|
||||
S Y=$P(LA7X,"-",2)
|
||||
I Y'="" D
|
||||
. I Y?.N.1".".N S $P(X,"!",3)=Y
|
||||
. E S $P(X,"!",3)=$C(34)_$$UNESC^LA7VHLU3(Y,LA7FS_LA7ECH)_$C(34)
|
||||
;
|
||||
; Store reference range in LAH global with results.
|
||||
S $P(^LAH(LA7LWL,1,LA7ISQN,LA76304),"^",5)=X
|
||||
;
|
||||
Q
|
||||
;
|
||||
;
|
||||
ABFLAG(LA7X) ; Process/Store Abnormal Flags.
|
||||
; Call with LA7X = abnormal flags to store.
|
||||
; Converts flag to interpretation based on HL7 Table 0078.
|
||||
; If no match store code instead of interpretation
|
||||
;
|
||||
Q:LA7INTYP=1
|
||||
N I,LA7I,LA7Y,X
|
||||
;
|
||||
; Store abnormal flags in LAH global with results.
|
||||
; Currently only storing high/low and critical flags
|
||||
S LA7Y=$S(LA7X="L":"L",LA7X="H":"H",LA7X="LL":"L*",LA7X="HH":"H*",1:"")
|
||||
S $P(^LAH(LA7LWL,1,LA7ISQN,LA76304),"^",2)=LA7Y
|
||||
;
|
||||
; Critical or designated abnormal tests generate bulletin/alert
|
||||
; on LEDI (type=10) interfaces.
|
||||
I LA7INTYP=10,LA7Y'="" D
|
||||
. I $E(LA7Y,2)'="*",'$P(LA76241(2),"^",11) Q
|
||||
. S LA7I=$O(^TMP("LA7 ABNORMAL RESULTS",$J,""),-1),LA7I=LA7I+1
|
||||
. S X=LA7LWL_"^"_LA7ISQN_"^"_LA76304_"^"_LA76248_"^"_LA76249_"^"_LA7ORS_"^"_LA7TEST_"^"_$S(LA7TEST(0)'="":LA7TEST(0),1:LA7TEST(2,0))_"^"_$$P^LA7VHLU(.LA7SEG,9,LA7FS)
|
||||
. S ^TMP("LA7 ABNORMAL RESULTS",$J,LA7I)=X
|
||||
;
|
||||
; If POC interface and abnormal flag is not handled by VistA above
|
||||
; then store as comment.
|
||||
I LA7INTYP>19,LA7INTYP<30,LA7Y="",LA7X'="" D
|
||||
. S X=" L^ H^LL^HH^ <^ >^ N^ A^AA^ U^ D^ B^ W^ S^ R^ I^MS^VS"
|
||||
. S I=$F(X,LA7X)\3
|
||||
. S LA7Y="normalcy status - "_$P($T(ABFLAGS+I^LA7VHLU1),";;",2)
|
||||
. D RMKSET^LASET(LA7LWL,LA7ISQN,LA7Y,$P(LA7RMK(0,+LA76241(0)),"^",2))
|
||||
;
|
||||
Q
|
||||
;
|
||||
;
|
||||
EII ; Store equipment instance identifier in LAH global with results.
|
||||
;
|
||||
N I,LA7X,X
|
||||
;
|
||||
S LA7X=""
|
||||
F I=1:1:4 D
|
||||
. S X=$P(LA7EII,LA7CS,I)
|
||||
. I X="" Q
|
||||
. S $P(LA7X,"!",I)=$TR(X,"!","~")
|
||||
I LA7X'="" S $P(^LAH(LA7LWL,1,LA7ISQN,LA76304),"^",11)=LA7X
|
||||
Q
|
||||
;
|
||||
;
|
||||
ORESULTS ; Process results that accompany order (ORM) messages
|
||||
;
|
||||
N I,LA764,LA7DIE,LA7ERR,LA7I,LA7WP,LA7X,LA7Y,X
|
||||
S LA7WP(1,0)=" ",LA7I=2,X=""
|
||||
I LA7RLNC S X="[LOINC "_$$GET1^DIQ(95.3,LA7RLNC_",",.01)_"] "_$$GET1^DIQ(95.3,LA7RLNC_",",80)
|
||||
I 'LA7RLNC,LA7RNLT D
|
||||
. S LA764=$$FIND1^DIC(64,"","X",LA7RNLT,"E","","LA7ERR")
|
||||
. I 'LA764 S LA7RNLT="" Q
|
||||
. S X="[NLT "_$$GET1^DIQ(64,LA764_",",1)_"] "_$$GET1^DIQ(64,LA764_",",.01,"I")
|
||||
I 'LA7RLNC,'LA7RNLT D
|
||||
. I LA7TEST(0)]""!(LA7TEST]"") S X="["_LA7TEST(0,1)_" "_LA7TEST_"] "_LA7TEST(0) Q
|
||||
. S X="["_LA7TEST(2,1)_" "_LA7TEST(2)_"] "_LA7TEST(2,0)
|
||||
S LA7WP(LA7I,0)="Test result: "_X
|
||||
; Date value
|
||||
I LA7VTYP="DT" D
|
||||
. S LA7X=$$P^LA7VHLU(.LA7SEG,6,LA7FS)
|
||||
. S LA7X=$$HL7TFM^XLFDT(LA7X,"L")
|
||||
. S LA7I=LA7I+1,LA7WP(LA7I,0)=" Test value: "_LA7X
|
||||
; Coded entry
|
||||
I "CECM"[LA7VTYP D
|
||||
. S LA7X=$P($$P^LA7VHLU(.LA7SEG,6,LA7FS),LA7CS,2)
|
||||
. S LA7X=$$UNESC^LA7VHLU3(LA7X,LA7FS_LA7ECH)
|
||||
. S LA7I=LA7I+1,LA7WP(LA7I,0)=" Test value: "_LA7X_$S(LA7UNITS]"":" "_LA7UNITS,1:"")
|
||||
; Numeric/ Structured Numeric value
|
||||
I "NMSN"[LA7VTYP D
|
||||
. S LA7X=$$P^LA7VHLU(.LA7SEG,6,LA7FS)
|
||||
. S LA7X=$$UNESC^LA7VHLU3(LA7X,LA7FS_LA7ECH)
|
||||
. S LA7I=LA7I+1,LA7WP(LA7I,0)=" Test value: "_LA7X_$S(LA7UNITS]"":" "_LA7UNITS,1:"")
|
||||
; String Data/ Formatted Text/ Text Data
|
||||
I "FTSTX"[LA7VTYP D
|
||||
. D PA^LA7VHLU(.LA7SEG,6,LA7FS,.LA7X)
|
||||
. D UNESCFT^LA7VHLU3(.LA7X,LA7FS_LA7ECH,.LA7Y)
|
||||
. I LA7Y=1,(($L(LA7Y(1,0))+$L(LA7UNITS))<225) S LA7I=LA7I+1,LA7WP(LA7I,0)=" Test value: "_LA7Y(1,0)_$S(LA7UNITS]"":" "_LA7UNITS,1:"") Q
|
||||
. S LA7I=LA7I+1,LA7WP(LA7I,0)=" Test value:"
|
||||
. F I=1:1:LA7Y S LA7I=LA7I+1,LA7WP(LA7I,0)=LA7Y(I,0)
|
||||
. I LA7UNITS'="" S LA7I=LA7I+1,LA7WP(LA7I,0)=" Test units: "_LA7UNITS
|
||||
; Normals/ Reference range
|
||||
S LA7X=$$P^LA7VHLU(.LA7SEG,8,LA7FS)
|
||||
I LA7X'="" S LA7I=LA7I+1,LA7WP(LA7I,0)=" Test normals: "_LA7X
|
||||
; Normalcy status
|
||||
S LA7X=$$P^LA7VHLU(.LA7SEG,9,LA7FS)
|
||||
I LA7X'="" D
|
||||
. S X=" L^ H^LL^HH^ <^ >^ N^ A^AA^ U^ D^ B^ W^ S^ R^ I^MS^VS"
|
||||
. S I=$F(X,LA7X)\3,LA7X=$P($T(ABFLAGS+I^LA7VHLU1),";;",2)
|
||||
. I LA7X'="" S LA7I=LA7I+1,LA7WP(LA7I,0)=" Test normalcy status: "_LA7X
|
||||
I $D(LA7WP) D WP^DIE(69.6,LA7696_",",99,"A","LA7WP","LA7DIE(99)")
|
||||
Q
|
||||
LA7VIN5A ;DALOI/JMC - Process Incoming UI Msgs, continued ; Jan 12, 2004
|
||||
;;5.2;AUTOMATED LAB INSTRUMENTS;**46,64,67,72**;Sep 27, 1994
|
||||
; This routine is a continuation of LA7VIN5.
|
||||
; It is performs processing of fields in OBX segments.
|
||||
Q
|
||||
;
|
||||
XFORM ; Transform the result based on fields 12,13,14,16,17 in the Chem Test
|
||||
; multiple in the Auto Instrument file (62.4), or set on the fly
|
||||
; from PARAM 1
|
||||
N LA7I
|
||||
S LA7XFORM=LA76241(2)
|
||||
;
|
||||
; get PARAM 1 overides
|
||||
I $D(LA7XFORM(1)),LA7XFORM(1)?1.N S $P(LA7XFORM,"^")=LA7XFORM(1)
|
||||
F LA7I=2,3,5,6 I $D(LA7XFORM(LA7I)) S $P(LA7XFORM,"^",LA7I)=LA7XFORM(LA7I)
|
||||
; set up defaults if field was not answered
|
||||
; accept results,yes
|
||||
I $P(LA7XFORM,"^",3)="" S $P(LA7XFORM,"^",3)=1
|
||||
; strip spaces,no
|
||||
I $P(LA7XFORM,"^",6)="" S $P(LA7XFORM,"^",6)=0
|
||||
; now transform
|
||||
;
|
||||
; Don't accept results
|
||||
I '$P(LA7XFORM,"^",3) S LA7VAL="" Q
|
||||
;
|
||||
; Only accept "FINAL" type results
|
||||
I $P(LA7XFORM,"^",3)=2,"CFUX"'[LA7ORS S LA7VAL="" Q
|
||||
;
|
||||
; Accept ordered tests only
|
||||
; If LEDI interface (10) and message indicates a reflex ("G") or add-on
|
||||
; test ("A") then process anyway in case it has not been added to
|
||||
; accession.
|
||||
I $P(LA7XFORM,"^",5) D
|
||||
. I LA7INTYP=10,LA7SAC?1(1"A",1"G") Q
|
||||
. S LA7LIMIT=1
|
||||
;
|
||||
; Decimal places if number of places defined
|
||||
I $P(LA7XFORM,"^")?1.N D JUSTDEC
|
||||
;
|
||||
; Strip spaces
|
||||
I $P(LA7XFORM,"^",6) S LA7VAL=$TR(LA7VAL," ","")
|
||||
;
|
||||
; Make result a comment
|
||||
; Set value to null after making into remark, don't store twice.
|
||||
I $P(LA7XFORM,"^",2) D
|
||||
. N LA7Y
|
||||
. ; Store comment in ^LAH global
|
||||
. S LA7Y=$P(LA7RMK(0,+LA76241(0)),"^",2)
|
||||
. D RMKSET^LASET(LA7LWL,LA7ISQN,LA7VAL,LA7Y)
|
||||
. S LA7VAL=""
|
||||
Q
|
||||
;
|
||||
;
|
||||
CHKDIE ; Check if value to be stored passes input transform of field in DD
|
||||
N LA7ERR,LA7Y
|
||||
;
|
||||
; If result is on a LEDI interface (type=10) then don't check result
|
||||
; against FileMan input tranform.
|
||||
; VistA sends "canc" as test result when test is cancelled.
|
||||
; DoD sends "PL Canceled" --> change to "canc" for VistA storage.
|
||||
I LA7INTYP=10 D Q
|
||||
. I LA7VAL="PL Cancelled" S LA7VAL="canc"
|
||||
. I LA7VAL="PL Canceled" S LA7VAL="canc"
|
||||
. I LA7VAL="PLCanceled" S LA7VAL="canc"
|
||||
;
|
||||
; If value fails data checker then log error and suppress result.
|
||||
D CHK^DIE(LA7SUBFL,LA76304,"H",LA7VAL,.LA7Y,"LA7ERR")
|
||||
I LA7Y="^" D
|
||||
. N LA7X
|
||||
. S LA7X=$G(LA7ERR("DIERR",1,"TEXT",1))
|
||||
. D CREATE^LA7LOG(37)
|
||||
. S LA7VAL=""
|
||||
Q
|
||||
;
|
||||
;
|
||||
JUSTDEC ; Justify to number of places specified
|
||||
;
|
||||
N LA7DDTYP,LA7FMT,LA7I,LA7PRFIX,LA7X
|
||||
;
|
||||
; If LEDI interface (type=10) then skip decimal adjustment
|
||||
I LA7INTYP=10 Q
|
||||
;
|
||||
; Get data name field type from DD
|
||||
; Only justify if Vista field is numeric or free text.
|
||||
S LA7DDTYP=$$GET1^DID(LA7SUBFL,LA76304,"","TYPE")
|
||||
I "NUMERIC^FREE TEXT"'[LA7DDTYP D Q
|
||||
. N LA7FLDNM
|
||||
. S LA7FLDNM=$$GET1^DID(63.04,LA76304,"","LABEL")
|
||||
. D CREATE^LA7LOG(38)
|
||||
;
|
||||
S LA7X=LA7VAL,(LA7FMT,LA7PRFIX)=""
|
||||
;
|
||||
; If comma formatted, strip comma and set flag to add back in.
|
||||
S LA7X=$TR(LA7X,",","")
|
||||
I LA7X'=LA7VAL S LA7FMT="P"
|
||||
;
|
||||
; If "<>=" formatted, strip and save to add back in.
|
||||
F LA7I=1:1:$L(LA7X) Q:$E(LA7X,LA7I)'?1(1"<",1">",1"=")
|
||||
I LA7I>1 D
|
||||
. S LA7PRFIX=$E(LA7X,1,LA7I-1)
|
||||
. S LA7X=$E(LA7X,LA7I,$L(LA7X))
|
||||
;
|
||||
; Format if starts with number or decimal point, skip other results.
|
||||
I LA7X?1(1.N,.N1"."1.N) D
|
||||
. S LA7X=$FN(LA7X,LA7FMT,+LA7XFORM)
|
||||
. S LA7VAL=LA7PRFIX_LA7X
|
||||
Q
|
||||
;
|
||||
;
|
||||
PRDID(LA7PRDID,LA7SFAC,LA7CS) ; Process/Store Producer's ID
|
||||
; Store where test was performed.
|
||||
; Call with LA7PRDID = Producer's ID field
|
||||
; LA7SFAC = sending facility
|
||||
; LA7CS = component encoding character
|
||||
;
|
||||
N LA74,LA7I,LA7X,LA7Y
|
||||
;
|
||||
S LA7X=$P(LA7PRDID,LA7CS,2),LA74=""
|
||||
;
|
||||
F LA7I=1,4 D Q:LA74
|
||||
. I $P(LA7PRDID,LA7CS,LA7I+2)="99VA4" S LA74=$$LKUP^XUAF4($P(LA7PRDID,LA7CS,LA7I))
|
||||
. I 'LA74 S LA74=$$LKUP^XUAF4($P(LA7PRDID,LA7CS,LA7I+1))
|
||||
. I 'LA74 S LA74=$$FINDSITE^LA7VHLU2($P(LA7PRDID,LA7CS),1,1)
|
||||
. I 'LA74 S LA74=$$FINDSITE^LA7VHLU2($P(LA7SFAC,LA7CS),1,1)
|
||||
;
|
||||
; Store producer's id in LAH global with results.
|
||||
I LA74 S $P(^LAH(LA7LWL,1,LA7ISQN,LA76304),"^",9)=LA74 Q
|
||||
;
|
||||
; Don't store producer's id as comment.
|
||||
I '$P(LA76241(2),"^",9) Q
|
||||
; If unable to identify producer in file #4
|
||||
; then store as comment if field STORE PRODUCER'S ID (#20) enabled.
|
||||
I LA7X="" Q
|
||||
S LA7Y=$P(LA7RMK(0,+LA76241(0)),"^",2)
|
||||
S LA7X=$S(LA7Y="":"P",1:"p")_"erformed by "_LA7X
|
||||
D RMKSET^LASET(LA7LWL,LA7ISQN,LA7X,LA7Y)
|
||||
;
|
||||
Q
|
||||
;
|
||||
;
|
||||
REFRNG(LA7X) ; Process/Store References Range.
|
||||
; Call with LA7X = reference range to store.
|
||||
;
|
||||
N LA7Y,X,Y
|
||||
;
|
||||
; Check if site does not want to store reference ranges on POC test.
|
||||
I LA7INTYP>19,LA7INTYP<30,+$P(LA76241(2),"^",10)=0 Q
|
||||
;
|
||||
; Remove leading and trailing quotes from reference range.
|
||||
S LA7X=$$TRIM^XLFSTR($G(LA7X),"RL","""")
|
||||
I LA7X="" Q
|
||||
;
|
||||
S X=$P($G(^LAH(LA7LWL,1,LA7ISQN,LA76304)),"^",5)
|
||||
;
|
||||
; >lower limit (no upper limit e.g. >10) - store as low value
|
||||
I LA7X?1">".N.1".".N S $P(X,"!",2)=$TR(LA7X,">",""),LA7X=""
|
||||
;
|
||||
; <upper limit (no lower limit e.g. <15) - store as high value
|
||||
I LA7X?1"<".N.1".".N S $P(X,"!",3)=$TR(LA7X,"<",""),LA7X=""
|
||||
;
|
||||
; Alphabetic reference with hyphen
|
||||
I LA7X?1.A1"-"1.A S $P(X,"!",2)=$C(34)_LA7X_$C(34),LA7X=""
|
||||
;
|
||||
; Lower limit value
|
||||
S Y=$P(LA7X,"-")
|
||||
I Y'="" D
|
||||
. I Y?.N.1".".N S $P(X,"!",2)=Y
|
||||
. E S $P(X,"!",2)=$C(34)_$$UNESC^LA7VHLU3(Y,LA7FS_LA7ECH)_$C(34)
|
||||
;
|
||||
; Upper limit value
|
||||
S Y=$P(LA7X,"-",2)
|
||||
I Y'="" D
|
||||
. I Y?.N.1".".N S $P(X,"!",3)=Y
|
||||
. E S $P(X,"!",3)=$C(34)_$$UNESC^LA7VHLU3(Y,LA7FS_LA7ECH)_$C(34)
|
||||
;
|
||||
; Store reference range in LAH global with results.
|
||||
S $P(^LAH(LA7LWL,1,LA7ISQN,LA76304),"^",5)=X
|
||||
;
|
||||
Q
|
||||
;
|
||||
;
|
||||
ABFLAG(LA7X) ; Process/Store Abnormal Flags.
|
||||
; Call with LA7X = abnormal flags to store.
|
||||
; Converts flag to interpretation based on HL7 Table 0078.
|
||||
; If no match store code instead of interpretation
|
||||
;
|
||||
N I,LA7I,LA7Y,X
|
||||
;
|
||||
; Store abnormal flags in LAH global with results.
|
||||
; Currently only storing high/low and critical flags
|
||||
S LA7Y=$S(LA7X="L":"L",LA7X="H":"H",LA7X="LL":"L*",LA7X="HH":"H*",1:"")
|
||||
S $P(^LAH(LA7LWL,1,LA7ISQN,LA76304),"^",2)=LA7Y
|
||||
;
|
||||
; Critical or designated abnormal tests generate bulletin/alert
|
||||
; on LEDI (type=10) interfaces.
|
||||
I LA7INTYP=10,LA7Y'="" D
|
||||
. I $E(LA7Y,2)'="*",'$P(LA76241(2),"^",11) Q
|
||||
. S LA7I=$O(^TMP("LA7 ABNORMAL RESULTS",$J,""),-1),LA7I=LA7I+1
|
||||
. S X=LA7LWL_"^"_LA7ISQN_"^"_LA76304_"^"_LA76248_"^"_LA76249_"^"_LA7ORS_"^"_LA7TEST_"^"_$S(LA7TEST(0)'="":LA7TEST(0),1:LA7TEST(2,0))_"^"_$$P^LA7VHLU(.LA7SEG,9,LA7FS)
|
||||
. S ^TMP("LA7 ABNORMAL RESULTS",$J,LA7I)=X
|
||||
;
|
||||
; If POC interface and abnormal flag is not handled by VistA above
|
||||
; then store as comment.
|
||||
I LA7INTYP>19,LA7INTYP<30,LA7Y="",LA7X'="" D
|
||||
. S X=" L^ H^LL^HH^ <^ >^ N^ A^AA^ U^ D^ B^ W^ S^ R^ I^MS^VS"
|
||||
. S I=$F(X,LA7X)\3
|
||||
. S LA7Y="normalcy status - "_$P($T(ABFLAGS+I^LA7VHLU1),";;",2)
|
||||
. D RMKSET^LASET(LA7LWL,LA7ISQN,LA7Y,$P(LA7RMK(0,+LA76241(0)),"^",2))
|
||||
;
|
||||
Q
|
||||
;
|
||||
;
|
||||
EII ; Store equipment instance identifier in LAH global with results.
|
||||
;
|
||||
N I,LA7X,X
|
||||
;
|
||||
S LA7X=""
|
||||
F I=1:1:4 D
|
||||
. S X=$P(LA7EII,LA7CS,I)
|
||||
. I X="" Q
|
||||
. S $P(LA7X,"!",I)=$TR(X,"!","~")
|
||||
I LA7X'="" S $P(^LAH(LA7LWL,1,LA7ISQN,LA76304),"^",11)=LA7X
|
||||
Q
|
||||
;
|
||||
;
|
||||
ORESULTS ; Process results that accompany order (ORM) messages
|
||||
;
|
||||
N I,LA764,LA7DIE,LA7ERR,LA7I,LA7WP,LA7X,LA7Y,X
|
||||
S LA7WP(1,0)=" ",LA7I=2,X=""
|
||||
I LA7RLNC S X="[LOINC "_$$GET1^DIQ(95.3,LA7RLNC_",",.01)_"] "_$$GET1^DIQ(95.3,LA7RLNC_",",80)
|
||||
I 'LA7RLNC,LA7RNLT D
|
||||
. S LA764=$$FIND1^DIC(64,"","X",LA7RNLT,"E","","LA7ERR")
|
||||
. I 'LA764 S LA7RNLT="" Q
|
||||
. S X="[NLT "_$$GET1^DIQ(64,LA764_",",1)_"] "_$$GET1^DIQ(64,LA764_",",.01,"I")
|
||||
I 'LA7RLNC,'LA7RNLT D
|
||||
. I LA7TEST(0)]""!(LA7TEST]"") S X="["_LA7TEST(0,1)_" "_LA7TEST_"] "_LA7TEST(0) Q
|
||||
. S X="["_LA7TEST(2,1)_" "_LA7TEST(2)_"] "_LA7TEST(2,0)
|
||||
S LA7WP(LA7I,0)="Test result: "_X
|
||||
; Date value
|
||||
I LA7VTYP="DT" D
|
||||
. S LA7X=$$P^LA7VHLU(.LA7SEG,6,LA7FS)
|
||||
. S LA7X=$$HL7TFM^XLFDT(LA7X,"L")
|
||||
. S LA7I=LA7I+1,LA7WP(LA7I,0)=" Test value: "_LA7X
|
||||
; Coded entry
|
||||
I "CECM"[LA7VTYP D
|
||||
. S LA7X=$P($$P^LA7VHLU(.LA7SEG,6,LA7FS),LA7CS,2)
|
||||
. S LA7X=$$UNESC^LA7VHLU3(LA7X,LA7FS_LA7ECH)
|
||||
. S LA7I=LA7I+1,LA7WP(LA7I,0)=" Test value: "_LA7X_$S(LA7UNITS]"":" "_LA7UNITS,1:"")
|
||||
; Numeric/ Structured Numeric value
|
||||
I "NMSN"[LA7VTYP D
|
||||
. S LA7X=$$P^LA7VHLU(.LA7SEG,6,LA7FS)
|
||||
. S LA7X=$$UNESC^LA7VHLU3(LA7X,LA7FS_LA7ECH)
|
||||
. S LA7I=LA7I+1,LA7WP(LA7I,0)=" Test value: "_LA7X_$S(LA7UNITS]"":" "_LA7UNITS,1:"")
|
||||
; String Data/ Formatted Text/ Text Data
|
||||
I "FTSTX"[LA7VTYP D
|
||||
. D PA^LA7VHLU(.LA7SEG,6,LA7FS,.LA7X)
|
||||
. D UNESCFT^LA7VHLU3(.LA7X,LA7FS_LA7ECH,.LA7Y)
|
||||
. I LA7Y=1,(($L(LA7Y(1,0))+$L(LA7UNITS))<225) S LA7I=LA7I+1,LA7WP(LA7I,0)=" Test value: "_LA7Y(1,0)_$S(LA7UNITS]"":" "_LA7UNITS,1:"") Q
|
||||
. S LA7I=LA7I+1,LA7WP(LA7I,0)=" Test value:"
|
||||
. F I=1:1:LA7Y S LA7I=LA7I+1,LA7WP(LA7I,0)=LA7Y(I,0)
|
||||
. I LA7UNITS'="" S LA7I=LA7I+1,LA7WP(LA7I,0)=" Test units: "_LA7UNITS
|
||||
; Normals/ Reference range
|
||||
S LA7X=$$P^LA7VHLU(.LA7SEG,8,LA7FS)
|
||||
I LA7X'="" S LA7I=LA7I+1,LA7WP(LA7I,0)=" Test normals: "_LA7X
|
||||
; Normalcy status
|
||||
S LA7X=$$P^LA7VHLU(.LA7SEG,9,LA7FS)
|
||||
I LA7X'="" D
|
||||
. S X=" L^ H^LL^HH^ <^ >^ N^ A^AA^ U^ D^ B^ W^ S^ R^ I^MS^VS"
|
||||
. S I=$F(X,LA7X)\3,LA7X=$P($T(ABFLAGS+I^LA7VHLU1),";;",2)
|
||||
. I LA7X'="" S LA7I=LA7I+1,LA7WP(LA7I,0)=" Test normalcy status: "_LA7X
|
||||
I $D(LA7WP) D WP^DIE(69.6,LA7696_",",99,"A","LA7WP","LA7DIE(99)")
|
||||
Q
|
||||
|
|
|
|||
|
|
@ -1,65 +1,58 @@
|
|||
DVBCREQ1 ;ALB/GTS-557/THM-NEW 2507 REQUEST PRINTING ; 5/25/91 11:36 AM
|
||||
;;2.7;AMIE;**19,29,126**;Apr 10, 1995;Build 8
|
||||
;
|
||||
START S PGHD="COMPENSATION AND PENSION EXAM REQUEST",ROHD="Requested by "_RONAME,PG=0
|
||||
D HDR
|
||||
D SSNOUT^DVBCUTIL ;** Set the value of DVBCSSNO
|
||||
W !?2,"Name: ",PNAM,?56,"SSN: ",DVBCSSNO,!?51,"C-Number: ",CNUM,!?56,"DOB: " S Y=DOB X ^DD("DD") W Y,!?2,"Address: ",ADR1,! W:ADR2]"" ?11,ADR2,! W:ADR3]"" ?11,ADR3,!!
|
||||
W ?2,"City,State,Zip+4: ",?48,"Res Phone: ",HOMPHON,!?5,CITY," ",STATE," ",ZIP,?48,"Bus Phone: ",BUSPHON,! ;I IOST?1"C-".E D CRTBOT G:$D(GETOUT) EXIT ;DVBA/126 comment off this code
|
||||
I $D(^DPT(DFN,.121)) I $D(DTT) D ;DVBA/126
|
||||
.Q:$P(DTT,U,9)=""!($P(DTT,U,9)="N")
|
||||
.I $P(DTT,U,7)'="" Q:$P(DTT,U,7)>DT
|
||||
.I $P(DTT,U,8)'="" Q:$P(DTT,U,8)<DT
|
||||
.W !?2,"Temporary Address: ",TAD1,! W:TAD2]"" ?21,TAD2,! W:TAD3]"" ?21,TAD3,!
|
||||
.W ?2,"City,State,Zip+4: ",?48,"Temporary Phone: ",!?5,TCITY," ",TST," ",TZIP,?51,TPHONE,!
|
||||
I IOST?1"C-".E D CRTBOT G:$D(GETOUT) EXIT ;DVBA/126
|
||||
W !,"Entered active service: " S Y=EOD X ^DD("DD") S:Y="" Y="Not specified" W Y,?40,"Last rating exam date: ",LREXMDT,! S Y=RAD X ^DD("DD") S:Y="" Y="Not specified" W "Released active service: " W Y,!
|
||||
F LINE=1:1:80 W "="
|
||||
S TVAR(1,0)="0,0,0,2:1,0^** Priority of exam: "_PRIO
|
||||
D WR^DVBAUTL4("TVAR")
|
||||
K TVAR
|
||||
I $D(^DVB(396.3,DA(1),5)),(+$P(^DVB(396.3,DA(1),5),U,1)>0) DO
|
||||
.I $D(DVBAINSF),($D(^DVB(396.3,$P(^DVB(396.3,DA(1),5),U,1),0))) DO
|
||||
..S Y=$P(^DVB(396.3,$P(^DVB(396.3,DA(1),5),U,1),0),U,5) X ^DD("DD")
|
||||
..S TVAR(1,0)="0,0,0,0,0^Date original 2507 Reported to MAS: "_Y K Y
|
||||
..D WR^DVBAUTL4("TVAR")
|
||||
..K TVAR
|
||||
S TVAR(1,0)="0,0,0,3:2,0^Selected exams: "
|
||||
D WR^DVBAUTL4("TVAR")
|
||||
K TVAR
|
||||
D TST^DVBCUTL3 G:($D(GETOUT)) EXIT
|
||||
W !!!!! I IOST?1"C-".E D CRTBOT G:$D(GETOUT) EXIT
|
||||
W "Current Rated disabilities:",!! D DDIS^DVBCUTL3 G:($D(GETOUT)) EXIT
|
||||
W "Other Disabilities:",!!?2,OTHDIS,!?2,OTHDIS1,!?2,OTHDIS2,!!,"General remarks:",!!
|
||||
K ^UTILITY($J,"W")
|
||||
I IOST?1"C-".E D CRTBOT G:$D(GETOUT) EXIT
|
||||
F LINE=0:0 S LINE=$O(^DVB(396.3,DA(1),2,LINE)) Q:(LINE="")!($D(GETOUT)) S X=^(LINE,0),DIWL=1,DIWF="NW" D ^DIWP I $Y>(IOSL-7),$O(^DVB(396.3,DA(1),2,LINE))]"" D BOT D:'$D(GETOUT) HDR,RMRK
|
||||
D:('$D(GETOUT)) ^DIWW
|
||||
; ** Exit TAG **
|
||||
EXIT D:('$D(GETOUT)) BOT K GETOUT,LPCNT,DVBCDX,DVBCSC,DVBCSSNO,DTT,TAD1,TAD2,TAD3,TCITY,TST,TZIP,TPHONE Q
|
||||
;
|
||||
HDR S PG=PG+1 I '$D(ONE)!(($D(ONE))&(PG>1))!(IOST?1"C-".E) W @IOF
|
||||
W !,"Date: ",DVBCDT(0),?(80-$L(PGHD)\2),PGHD,?71,"Page: ",PG,! S PRTDIV=$S($D(^DG(40.8,XDIV,0)):$P(^(0),U,1),1:"Unknown division") S PRTDIV="For "_PRTDIV_" Medical Center Division at "_$$SITE^DVBCUTL4
|
||||
W ?(80-$L(PRTDIV)\2),PRTDIV
|
||||
W !! S Y=$P(^DVB(396.3,DA(1),0),U,22) I Y]"" S Z="*** Transferred from ",Z=Z_$S($D(^DIC(4.2,+Y,0)):$P(^(0),U,1),1:"unknown site")_" ***" W ?(80-$L(Z)\2),Z,!
|
||||
W ?(80-$L(ROHD)\2),ROHD,! S RQ="Date Requested: ",Y=DTRQ X ^DD("DD") S RQ=RQ_Y W ?(80-$L(RQ)\2),RQ,! F XLN=1:1:80 W "="
|
||||
K XLN Q
|
||||
;
|
||||
CRTBOT ; ** Write form number at bottom of CRT **
|
||||
I $P(^DVB(396.3,DA(1),0),U,23)="Y" W !?20,"** Claim folder review will be required **",!
|
||||
F LPCNT=$Y:1:(IOSL-7) W !
|
||||
W !,"VA Form 21-2507"
|
||||
D TERM^DVBCUTL3
|
||||
Q
|
||||
;
|
||||
BOT I $P(^DVB(396.3,DA(1),0),U,23)="Y" W !?20,"** Claim folder review will be required **",!
|
||||
I IOST?1"C-".E F LPCNT=$Y:1:(IOSL-6) W !
|
||||
I IOST'?1"C-".E F LPCNT=$Y:1:(IOSL-4) W !
|
||||
W !,"VA Form 21-2507"
|
||||
I IOST?1"C-".E D TERM^DVBCUTL3
|
||||
Q
|
||||
;
|
||||
RMRK W !?2,"Name: ",PNAM,?56,"SSN: ",DVBCSSNO
|
||||
W ! F XLN=1:1:80 W "="
|
||||
W !!,"General remarks (continued):",!!
|
||||
Q
|
||||
DVBCREQ1 ;ALB/GTS-557/THM-NEW 2507 REQUEST PRINTING ; 5/25/91 11:36 AM
|
||||
;;2.7;AMIE;**19,29**;Apr 10, 1995
|
||||
;
|
||||
START S PGHD="COMPENSATION AND PENSION EXAM REQUEST",ROHD="Requested by "_RONAME,PG=0
|
||||
D HDR
|
||||
D SSNOUT^DVBCUTIL ;** Set the value of DVBCSSNO
|
||||
W !?2,"Name: ",PNAM,?56,"SSN: ",DVBCSSNO,!?51,"C-Number: ",CNUM,!?56,"DOB: " S Y=DOB X ^DD("DD") W Y,!?2,"Address: ",ADR1,! W:ADR2]"" ?11,ADR2,! W:ADR3]"" ?11,ADR3,!!
|
||||
W !?2,"City,State,Zip+4: ",?48,"Res Phone: ",HOMPHON,!?5,CITY," ",STATE," ",ZIP,?48,"Bus Phone: ",BUSPHON,! I IOST?1"C-".E D CRTBOT G:$D(GETOUT) EXIT
|
||||
W !,"Entered active service: " S Y=EOD X ^DD("DD") S:Y="" Y="Not specified" W Y,?40,"Last rating exam date: ",LREXMDT,! S Y=RAD X ^DD("DD") S:Y="" Y="Not specified" W "Released active service: " W Y,!
|
||||
F LINE=1:1:80 W "="
|
||||
S TVAR(1,0)="0,0,0,2:1,0^** Priority of exam: "_PRIO
|
||||
D WR^DVBAUTL4("TVAR")
|
||||
K TVAR
|
||||
I $D(^DVB(396.3,DA(1),5)),(+$P(^DVB(396.3,DA(1),5),U,1)>0) DO
|
||||
.I $D(DVBAINSF),($D(^DVB(396.3,$P(^DVB(396.3,DA(1),5),U,1),0))) DO
|
||||
..S Y=$P(^DVB(396.3,$P(^DVB(396.3,DA(1),5),U,1),0),U,5) X ^DD("DD")
|
||||
..S TVAR(1,0)="0,0,0,0,0^Date original 2507 Reported to MAS: "_Y K Y
|
||||
..D WR^DVBAUTL4("TVAR")
|
||||
..K TVAR
|
||||
S TVAR(1,0)="0,0,0,3:2,0^Selected exams: "
|
||||
D WR^DVBAUTL4("TVAR")
|
||||
K TVAR
|
||||
D TST^DVBCUTL3 G:($D(GETOUT)) EXIT
|
||||
W !!!!! I IOST?1"C-".E D CRTBOT G:$D(GETOUT) EXIT
|
||||
W "Current Rated disabilities:",!! D DDIS^DVBCUTL3 G:($D(GETOUT)) EXIT
|
||||
W "Other Disabilities:",!!?2,OTHDIS,!?2,OTHDIS1,!?2,OTHDIS2,!!,"General remarks:",!!
|
||||
K ^UTILITY($J,"W")
|
||||
I IOST?1"C-".E D CRTBOT G:$D(GETOUT) EXIT
|
||||
F LINE=0:0 S LINE=$O(^DVB(396.3,DA(1),2,LINE)) Q:(LINE="")!($D(GETOUT)) S X=^(LINE,0),DIWL=1,DIWF="NW" D ^DIWP I $Y>(IOSL-7),$O(^DVB(396.3,DA(1),2,LINE))]"" D BOT D:'$D(GETOUT) HDR,RMRK
|
||||
D:('$D(GETOUT)) ^DIWW
|
||||
; ** Exit TAG **
|
||||
EXIT D:('$D(GETOUT)) BOT K GETOUT,LPCNT,DVBCDX,DVBCSC,DVBCSSNO Q
|
||||
;
|
||||
HDR S PG=PG+1 I '$D(ONE)!(($D(ONE))&(PG>1))!(IOST?1"C-".E) W @IOF
|
||||
W !,"Date: ",DVBCDT(0),?(80-$L(PGHD)\2),PGHD,?71,"Page: ",PG,! S PRTDIV=$S($D(^DG(40.8,XDIV,0)):$P(^(0),U,1),1:"Unknown division") S PRTDIV="For "_PRTDIV_" Medical Center Division at "_$$SITE^DVBCUTL4
|
||||
W ?(80-$L(PRTDIV)\2),PRTDIV
|
||||
W !! S Y=$P(^DVB(396.3,DA(1),0),U,22) I Y]"" S Z="*** Transferred from ",Z=Z_$S($D(^DIC(4.2,+Y,0)):$P(^(0),U,1),1:"unknown site")_" ***" W ?(80-$L(Z)\2),Z,!
|
||||
W ?(80-$L(ROHD)\2),ROHD,! S RQ="Date Requested: ",Y=DTRQ X ^DD("DD") S RQ=RQ_Y W ?(80-$L(RQ)\2),RQ,! F XLN=1:1:80 W "="
|
||||
K XLN Q
|
||||
;
|
||||
CRTBOT ; ** Write form number at bottom of CRT **
|
||||
I $P(^DVB(396.3,DA(1),0),U,23)="Y" W !?20,"** Claim folder review will be required **",!
|
||||
F LPCNT=$Y:1:(IOSL-7) W !
|
||||
W !,"VA Form 21-2507"
|
||||
D TERM^DVBCUTL3
|
||||
Q
|
||||
;
|
||||
BOT I $P(^DVB(396.3,DA(1),0),U,23)="Y" W !?20,"** Claim folder review will be required **",!
|
||||
I IOST?1"C-".E F LPCNT=$Y:1:(IOSL-6) W !
|
||||
I IOST'?1"C-".E F LPCNT=$Y:1:(IOSL-4) W !
|
||||
W !,"VA Form 21-2507"
|
||||
I IOST?1"C-".E D TERM^DVBCUTL3
|
||||
Q
|
||||
;
|
||||
RMRK W !?2,"Name: ",PNAM,?56,"SSN: ",DVBCSSNO
|
||||
W ! F XLN=1:1:80 W "="
|
||||
W !!,"General remarks (continued):",!!
|
||||
Q
|
||||
|
|
|
|||
|
|
@ -1,69 +1,62 @@
|
|||
DVBCUTIL ;ALB/GTS-557/THM;C&P UTILITY ROUTINE ; 4/26/91 11:16 AM
|
||||
;;2.7;AMIE;**17,126**;Apr 10, 1995;Build 8
|
||||
KILL ;common exit
|
||||
D ^%ZISC I $D(FF),'$D(ZTQUEUED) W @FF,!!
|
||||
K %DT,ADR1,ADR2,ADR3,BDTRQ,BUSPHON,CITY,CNDCT,CNUM,DFN,DIW,DIWF,DIWL,DIWR,DIWT,DN,DOB,DTA,DTRQ,DX,DXCOD,DXNUM,EDTRQ,HOMPHON,I,LINE,MDTRM,NAME,OTHDIS,PCT,PG,PGHD,POP,PRINT,REQN,RO,ROHD,RONAME,RQ,SC,D,DIE,ONE,DVBCNEW,LN,FEXM,PRIO,DTB
|
||||
K SEX,SSN,STATE,TST,X,Y,Z,JI,JII,ZIP,JJ,KJX,D0,D1,DA,DI,DIC,DIPGM,DLAYGO,DQ,DWLW,HD,HD1,HD2,J,ONFILE,CTIM,JJ,C,DIZ,DPTSZ,STAT,JDT,JY,TSTDT,DIYS,EXAM,DR,REQDT,ELIG,INCMP,PRDSV,WARD,ADD1,ADD2,CNTY,PG,OLDDA,DIRUT,DUOUT
|
||||
K DVBCCNT,TNAM,DIR,TEMP,SWITCH,EDTA,RAD,EOD,%T,STATUS,XX,XDD,OLDA,OLDA1
|
||||
K DTTRNSC,ZIP4,DVBAINSF,DTT,TAD1,TAD2,TAD3,TCITY,TST,TZIP,TPHONE
|
||||
G KILL^DVBCUTL2
|
||||
;
|
||||
DICW ;used on ^DIC lookups only
|
||||
W ! S TSTDT=$P(^(0),U,2),RO=$P(^(0),U,3),STAT=$P(^(0),U,18),RONAME=$S($D(^DIC(4,+RO,0)):$P(^(0),U,1),1:"Unknown RO") D DICW1
|
||||
W ! Q
|
||||
;
|
||||
DICW1 F JY=0:0 S JY=$O(^DVB(396.4,"C",+Y,JY)) Q:JY="" S EXAM=$P(^DVB(396.4,+JY,0),U,3),EXAM=$S($D(^DVB(396.6,EXAM,0)):$P(^(0),U,1),1:"Unknown exam") D DICW2
|
||||
Q
|
||||
;
|
||||
DICW2 W ?3,EXAM," (",$$FMTE^XLFDT(TSTDT,"5DZ")," by ",RONAME,")",!
|
||||
Q
|
||||
;
|
||||
VARS S DTA=^DVB(396.3,DA,0),DFN=$P(DTA,U,1),(NAME,PNAM)=$P(^DPT(DFN,0),U,1),DOB=$P(^(0),U,3),SEX=$P(^(0),U,2),SSN=$P(^(0),U,9),CNUM=$S($D(^DPT(DFN,.31)):$P(^(.31),U,3),1:"Unknown"),DTRQ=$P(DTA,U,2)
|
||||
S RO=$P(DTA,U,3),FEXM=$P(DTA,U,9) S:RO="" RO=0 S RONAME=$S($D(^DIC(4,RO,0)):$P(^(0),U,1),1:"Unknown")
|
||||
S REQN=$P(DTA,U,4),REQN=$S($D(^VA(200,+REQN,0)):$P(^(0),U,1),1:"Unknown"),OTHDIS=$P(DTA,U,11) I $D(^DVB(396.3,DA,1)) S OTHDIS1=$P(^(1),U,9),OTHDIS2=$P(^(1),U,10)
|
||||
S ZPR=$P(DTA,U,10),PRIO=$S(ZPR="T":"Terminal",ZPR="P":"Prisoner of war",ZPR="OS":"Original SC",ZPR="ON":"Original NSC",ZPR="I":"Increase",ZPR="R":"Review",ZPR="OTR":"Other",ZPR="E":"Inadequate exam",1:"Unknown")
|
||||
K DVBAINSF S:ZPR="E" DVBAINSF=""
|
||||
S (ADR1,ADR2,ADR3,CITY,STATE,ZIP)=""
|
||||
I $D(^DPT(DFN,.11)) S DTA=^DPT(DFN,.11),ADR1=$P(DTA,U,1),ADR2=$P(DTA,U,2),ADR3=$P(DTA,U,3),CITY=$P(DTA,U,4),ZIP=$P(DTA,U,12) S:ZIP'="" ZIP=$S($L(ZIP)>5:$E(ZIP,1,5)_"-"_$E(ZIP,6,9),1:ZIP) I ZIP="" S ZIP="No Zip"
|
||||
S CITY=$S(CITY]"":CITY,1:"Unknown") S STATE=$P(DTA,U,5) I STATE]"" S STATE=$S($D(^DIC(5,STATE,0)):$P(^(0),U,1),1:"Unknown")
|
||||
S (HOMPHON,BUSPHON)="Unknown" I $D(^DPT(DFN,.13)) S HOMPHON=$P(^(.13),U,1),BUSPHON=$P(^(.13),U,2)
|
||||
I $D(^DPT(DFN,.121)) D ;DVBA/126 added
|
||||
.S (DTT,TAD1,TAD2,TAD3,TCITY,TST,TZIP,TPHONE)=""
|
||||
.S DTT=^DPT(DFN,.121)
|
||||
.S TAD1=$P(DTT,U,1),TAD2=$P(DTT,U,2),TAD3=$P(DTT,U,3),TCITY=$P(DTT,U,4)
|
||||
.S TZIP=$P(DTT,U,12) S:TZIP'="" TZIP=$S($L(TZIP)>5:$E(TZIP,1,5)_"-"_$E(TZIP,6,9),1:TZIP) I TZIP="" S TZIP="No Zip"
|
||||
.S TCITY=$S(TCITY]"":TCITY,1:"Unknown") S TST=$P(DTT,U,5) I TST]"" S TST=$S($D(^DIC(5,TST,0)):$P(^(0),U,1),1:"Unknown")
|
||||
.S TPHONE=$P(DTT,U,10) S:TPHONE="" TPHONE="Unknown"
|
||||
S EDTA=$S($D(^DPT(DFN,.32)):^(.32),1:""),EOD=$P(EDTA,U,6),RAD=$P(EDTA,U,7),Y=$S($D(^DVB(396.3,DA,1)):$P(^(1),U,7),1:"") X ^DD("DD") S LREXMDT=Y
|
||||
Q
|
||||
;
|
||||
HDR W @FF,?(IOM-$L(HD2)\2),HD2,!!!?5,"Veteran name: ",PNAM,?45,"SSN: ",SSN,!?40,"C-NUMBER: ",CNUM,!!,"Exams on this request:",!!
|
||||
S JII=""
|
||||
F JIJ=0:0 S JII=$O(^TMP($J,JII)) Q:JII="" S XST=$P(^TMP($J,JII),U,1) W JII,", ",$S(XST="C":"Completed",XST="RX":"Cancelled by RO",XST="X":"Cancelled by MAS",XST="T":"Transferred",1:"Open"),", " I $X>30 W !
|
||||
Q
|
||||
;
|
||||
ADDR S (ADD1,ADD2,CITY,CNTY,STATE,ZIP)=""
|
||||
I $D(^DPT(DFN,.11)) S DTA=^(.11),ADD1=$P(DTA,U,1),ADD2=$P(DTA,U,2),CITY=$P(DTA,U,4),STATE=$P(DTA,U,5),ZIP=$P(DTA,U,12),CNTY=$P(DTA,U,7)
|
||||
S:ZIP'="" ZIP=$S($L(ZIP)>5:$E(ZIP,1,5)_"-"_$E(ZIP,6,9),1:ZIP)
|
||||
S CNTY=$S($D(^DIC(5,+STATE,1,+CNTY,0)):$P(^(0),U,1),1:"Unknown")
|
||||
S STATE=$S($D(^DIC(5,+STATE,0)):$P(^(0),U,1),1:"Unknown")
|
||||
W !!?0,"Address: ",?9,ADD1,! W:ADD2]"" ?9,ADD2,! W ?0,"City:",?9,CITY," ",STATE," ",ZIP,!?0,"County:",?9,CNTY,!!
|
||||
S PRDSV=$S($D(^DPT(DFN,.32)):$P(^(.32),U,3),1:"") I PRDSV]"" S PRDSV=$P(^DIC(21,PRDSV,0),U,1)
|
||||
W "Period of service: ",PRDSV,!
|
||||
S ELIG="",INCMP=0
|
||||
W ?0,"Eligibility data:" I $D(^DPT(DFN,.36)),$P(^(.36),U,1)]"" S ELIG=$S($D(^DIC(8,+^(.36),0)):$P(^(0),U,6),1:"")
|
||||
I ELIG]"",$D(^DPT(DFN,.361)),^(.361)]"" S ELIG=ELIG_" ("_$S($P(^(.361),U,1)="P":"Pend ver",$P(^(.361),U,1)="R":"Pend re-verif",$P(^(.361),U,1)="V":"Verified",1:"Not verified")_")"
|
||||
I $D(^DPT(DFN,.29)),$P(^(.29),U,1)]"" S INCMP=1
|
||||
I $D(^DPT(DA,.293)),$P(^(.293),U,1)=1 S INCMP=1
|
||||
W ?19,ELIG_$S(ELIG]"":", ",1:"")_$S(INCMP=1:"Incompetent",1:""),!
|
||||
Q
|
||||
;
|
||||
SSNSHRT ; ** Set SSN in the Format '123 45 6789' **
|
||||
K DVBCSSNO
|
||||
S DVBCSSNO=$E(SSN,1,3)_" "_$E(SSN,4,5)_" "_$E(SSN,6,9)
|
||||
Q
|
||||
;
|
||||
SSNOUT ; ** Set SSN in the Format '123 45 6789 (Z6789) **
|
||||
D SSNSHRT
|
||||
S DVBCSSNO=DVBCSSNO_" ("_$E(PNAM)_$E(SSN,6,9)_")"
|
||||
Q
|
||||
DVBCUTIL ;ALB/GTS-557/THM;C&P UTILITY ROUTINE ; 4/26/91 11:16 AM
|
||||
;;2.7;AMIE;**17**;Apr 10, 1995
|
||||
KILL ;common exit
|
||||
D ^%ZISC I $D(FF),'$D(ZTQUEUED) W @FF,!!
|
||||
K %DT,ADR1,ADR2,ADR3,BDTRQ,BUSPHON,CITY,CNDCT,CNUM,DFN,DIW,DIWF,DIWL,DIWR,DIWT,DN,DOB,DTA,DTRQ,DX,DXCOD,DXNUM,EDTRQ,HOMPHON,I,LINE,MDTRM,NAME,OTHDIS,PCT,PG,PGHD,POP,PRINT,REQN,RO,ROHD,RONAME,RQ,SC,D,DIE,ONE,DVBCNEW,LN,FEXM,PRIO,DTB
|
||||
K SEX,SSN,STATE,TST,X,Y,Z,JI,JII,ZIP,JJ,KJX,D0,D1,DA,DI,DIC,DIPGM,DLAYGO,DQ,DWLW,HD,HD1,HD2,J,ONFILE,CTIM,JJ,C,DIZ,DPTSZ,STAT,JDT,JY,TSTDT,DIYS,EXAM,DR,REQDT,ELIG,INCMP,PRDSV,WARD,ADD1,ADD2,CNTY,PG,OLDDA,DIRUT,DUOUT
|
||||
K DVBCCNT,TNAM,DIR,TEMP,SWITCH,EDTA,RAD,EOD,%T,STATUS,XX,XDD,OLDA,OLDA1
|
||||
K DTTRNSC,ZIP4,DVBAINSF
|
||||
G KILL^DVBCUTL2
|
||||
;
|
||||
DICW ;used on ^DIC lookups only
|
||||
W ! S TSTDT=$P(^(0),U,2),RO=$P(^(0),U,3),STAT=$P(^(0),U,18),RONAME=$S($D(^DIC(4,+RO,0)):$P(^(0),U,1),1:"Unknown RO") D DICW1
|
||||
W ! Q
|
||||
;
|
||||
DICW1 F JY=0:0 S JY=$O(^DVB(396.4,"C",+Y,JY)) Q:JY="" S EXAM=$P(^DVB(396.4,+JY,0),U,3),EXAM=$S($D(^DVB(396.6,EXAM,0)):$P(^(0),U,1),1:"Unknown exam") D DICW2
|
||||
Q
|
||||
;
|
||||
DICW2 W ?3,EXAM," (",$$FMTE^XLFDT(TSTDT,"5DZ")," by ",RONAME,")",!
|
||||
Q
|
||||
;
|
||||
VARS S DTA=^DVB(396.3,DA,0),DFN=$P(DTA,U,1),(NAME,PNAM)=$P(^DPT(DFN,0),U,1),DOB=$P(^(0),U,3),SEX=$P(^(0),U,2),SSN=$P(^(0),U,9),CNUM=$S($D(^DPT(DFN,.31)):$P(^(.31),U,3),1:"Unknown"),DTRQ=$P(DTA,U,2)
|
||||
S RO=$P(DTA,U,3),FEXM=$P(DTA,U,9) S:RO="" RO=0 S RONAME=$S($D(^DIC(4,RO,0)):$P(^(0),U,1),1:"Unknown")
|
||||
S REQN=$P(DTA,U,4),REQN=$S($D(^VA(200,+REQN,0)):$P(^(0),U,1),1:"Unknown"),OTHDIS=$P(DTA,U,11) I $D(^DVB(396.3,DA,1)) S OTHDIS1=$P(^(1),U,9),OTHDIS2=$P(^(1),U,10)
|
||||
S ZPR=$P(DTA,U,10),PRIO=$S(ZPR="T":"Terminal",ZPR="P":"Prisoner of war",ZPR="OS":"Original SC",ZPR="ON":"Original NSC",ZPR="I":"Increase",ZPR="R":"Review",ZPR="OTR":"Other",ZPR="E":"Inadequate exam",1:"Unknown")
|
||||
K DVBAINSF S:ZPR="E" DVBAINSF=""
|
||||
S (ADR1,ADR2,ADR3,CITY,STATE,ZIP)=""
|
||||
I $D(^DPT(DFN,.11)) S DTA=^DPT(DFN,.11),ADR1=$P(DTA,U,1),ADR2=$P(DTA,U,2),ADR3=$P(DTA,U,3),CITY=$P(DTA,U,4),ZIP=$P(DTA,U,12) S:ZIP'="" ZIP=$S($L(ZIP)>5:$E(ZIP,1,5)_"-"_$E(ZIP,6,9),1:ZIP) I ZIP="" S ZIP="No Zip"
|
||||
S CITY=$S(CITY]"":CITY,1:"Unknown") S STATE=$P(DTA,U,5) I STATE]"" S STATE=$S($D(^DIC(5,STATE,0)):$P(^(0),U,1),1:"Unknown")
|
||||
S (HOMPHON,BUSPHON)="Unknown" I $D(^DPT(DFN,.13)) S HOMPHON=$P(^(.13),U,1),BUSPHON=$P(^(.13),U,2)
|
||||
S EDTA=$S($D(^DPT(DFN,.32)):^(.32),1:""),EOD=$P(EDTA,U,6),RAD=$P(EDTA,U,7),Y=$S($D(^DVB(396.3,DA,1)):$P(^(1),U,7),1:"") X ^DD("DD") S LREXMDT=Y
|
||||
Q
|
||||
;
|
||||
HDR W @FF,?(IOM-$L(HD2)\2),HD2,!!!?5,"Veteran name: ",PNAM,?45,"SSN: ",SSN,!?40,"C-NUMBER: ",CNUM,!!,"Exams on this request:",!!
|
||||
S JII=""
|
||||
F JIJ=0:0 S JII=$O(^TMP($J,JII)) Q:JII="" S XST=$P(^TMP($J,JII),U,1) W JII,", ",$S(XST="C":"Completed",XST="RX":"Cancelled by RO",XST="X":"Cancelled by MAS",XST="T":"Transferred",1:"Open"),", " I $X>30 W !
|
||||
Q
|
||||
;
|
||||
ADDR S (ADD1,ADD2,CITY,CNTY,STATE,ZIP)=""
|
||||
I $D(^DPT(DFN,.11)) S DTA=^(.11),ADD1=$P(DTA,U,1),ADD2=$P(DTA,U,2),CITY=$P(DTA,U,4),STATE=$P(DTA,U,5),ZIP=$P(DTA,U,12),CNTY=$P(DTA,U,7)
|
||||
S:ZIP'="" ZIP=$S($L(ZIP)>5:$E(ZIP,1,5)_"-"_$E(ZIP,6,9),1:ZIP)
|
||||
S CNTY=$S($D(^DIC(5,+STATE,1,+CNTY,0)):$P(^(0),U,1),1:"Unknown")
|
||||
S STATE=$S($D(^DIC(5,+STATE,0)):$P(^(0),U,1),1:"Unknown")
|
||||
W !!?0,"Address: ",?9,ADD1,! W:ADD2]"" ?9,ADD2,! W ?0,"City:",?9,CITY," ",STATE," ",ZIP,!?0,"County:",?9,CNTY,!!
|
||||
S PRDSV=$S($D(^DPT(DFN,.32)):$P(^(.32),U,3),1:"") I PRDSV]"" S PRDSV=$P(^DIC(21,PRDSV,0),U,1)
|
||||
W "Period of service: ",PRDSV,!
|
||||
S ELIG="",INCMP=0
|
||||
W ?0,"Eligibility data:" I $D(^DPT(DFN,.36)),$P(^(.36),U,1)]"" S ELIG=$S($D(^DIC(8,+^(.36),0)):$P(^(0),U,6),1:"")
|
||||
I ELIG]"",$D(^DPT(DFN,.361)),^(.361)]"" S ELIG=ELIG_" ("_$S($P(^(.361),U,1)="P":"Pend ver",$P(^(.361),U,1)="R":"Pend re-verif",$P(^(.361),U,1)="V":"Verified",1:"Not verified")_")"
|
||||
I $D(^DPT(DFN,.29)),$P(^(.29),U,1)]"" S INCMP=1
|
||||
I $D(^DPT(DA,.293)),$P(^(.293),U,1)=1 S INCMP=1
|
||||
W ?19,ELIG_$S(ELIG]"":", ",1:"")_$S(INCMP=1:"Incompetent",1:""),!
|
||||
Q
|
||||
;
|
||||
SSNSHRT ; ** Set SSN in the Format '123 45 6789' **
|
||||
K DVBCSSNO
|
||||
S DVBCSSNO=$E(SSN,1,3)_" "_$E(SSN,4,5)_" "_$E(SSN,6,9)
|
||||
Q
|
||||
;
|
||||
SSNOUT ; ** Set SSN in the Format '123 45 6789 (Z6789) **
|
||||
D SSNSHRT
|
||||
S DVBCSSNO=DVBCSSNO_" ("_$E(PNAM)_$E(SSN,6,9)_")"
|
||||
Q
|
||||
|
|
|
|||
|
|
@ -1,103 +1,102 @@
|
|||
ALPBGEN1 ;SFVAMC/JC - Parse and File HL7 PMU messages ;05/10/07
|
||||
;;3.0;BAR CODE MED ADMIN;**8,37**;Mar 2004;Build 10
|
||||
;;Per VHA Directive 2004-038, this routine should not be modified.
|
||||
Q
|
||||
;
|
||||
PARSIT ;PARSE MESSAGE ON RECEIVING SIDE
|
||||
N FS,EC,CS,RS,ESC,SS,EEC,EFS,ECS,ERS,ESS,ALPBID,ALPBKY,ALPBMENU,ALPBMT,ALPBVC,DATE,DIK,DLAYGO,STF
|
||||
S FS=$G(HL("FS")) I FS="" W !,"NO SEPARATOR" Q:FS="" ;Field separator
|
||||
S EC=$G(HL("ECH")) Q:EC="" ;Encoding Charaters
|
||||
S CS=$E(EC) ;Component separator
|
||||
S RS=$E(EC,2) ;Repitition separator
|
||||
S ESC=$E(EC,3) ;Escape character
|
||||
S SS=$E(EC,4) ;Subcomponent separator
|
||||
S EEC=ESC_"E"_ESC ;escaped escape character
|
||||
S EFS=ESC_"F"_ESC ;escaped field sep
|
||||
S ECS=ESC_"S"_ESC ;escaped component sep
|
||||
S ERS=ESC_"R"_ESC ; escaped repitition sep
|
||||
S ESS=ESC_"T"_ESC ;escaped subcomponent separator
|
||||
N ALPBI,ALBPJ,ALPBX,ALPBAC,ACLPVC,ALPBSSN,ALPBERR,ALPBNAM,ALPBTRM
|
||||
F X HLNEXT Q:$G(HLQUIT)'>0 D
|
||||
. I $E(HLNODE,1,3)="EVN" S ALPBMT=$P(HLNODE,2)
|
||||
. I $E(HLNODE,1,3)="STF" S STF=$E(HLNODE,5,9999) D PSTF
|
||||
Q
|
||||
PSTF ;Process STF segment
|
||||
S ALPBKY=$P(STF,FS,1) Q:ALPBKY'[200_CS_"VISTA"
|
||||
S ALPBID=$P(STF,FS,2) S ALPBSSN=$E(ALPBID,1,9),ALPBAC=$P(ALPBID,RS,2),ALPBVC=$P(ALPBID,RS,3) D
|
||||
. S ALPBSSN=$TR(ALPBSSN,"-","")
|
||||
. I ALPBAC']"" S ALERR("ACCESS")="MISSING ACCESS CODE"
|
||||
. I ALPBVC']"" S ALERR("VERIFY")="MISSING VERIFY CODE"
|
||||
. ;Unescape Access Code
|
||||
. S ALPBAC=$$UNESC(ALPBAC)
|
||||
. ;Unescape Verify Code
|
||||
. S ALPBVC=$$UNESC(ALPBVC)
|
||||
S ALPBNAM=$P(STF,FS,3),ALPBNAM=$P(ALPBNAM,CS,1)_","_$P(ALPBNAM,CS,2)_" "_$P(ALPBNAM,CS,3)_" "_$P(ALPBNAM,CS,4) I ALPBNAM[" " S ALPBNAM=$TR(ALPBNAM," ","") I ALPBNAM']"" S ALERR("NAME")="MISSING NAME"
|
||||
I $D(ALERR) G PERR
|
||||
S ALPBDIS=$S($P(STF,FS,7)="I":1,1:0)
|
||||
I $P(STF,FS,13)]"" S ALPBTRM=$$HL7TFM^XLFDT($P(STF,FS,13),"L")
|
||||
FILE ;Store File 200 data on backup system
|
||||
N Y,DIC,DIE,DA,DR
|
||||
Q:'$D(ALPBNAM)
|
||||
Q:$L(ALPBSSN)'=9
|
||||
;Try exact SSn lookup first
|
||||
K Y S DIC="^VA(200,",DIC(0)="X",X=ALPBSSN,D="SSN" D IX^DIC
|
||||
;S DLAYGO=200,DIC="^VA(200,",DIC(0)="LM",X=ALPBNAM D ^DIC K DIC,DA,DR
|
||||
;If SSN lookup fails, try name lookup and add
|
||||
I +Y<1 S DLAYGO=200,DIC="^VA(200,",DIC(0)="LM",X=ALPBNAM D ^DIC K DIC,DA,DR
|
||||
I +Y>0 S (ALPBDA,DA,DUZ)=+Y S ALPBMENU=$O(^DIC(19,"B","PSB BCBU WRKSTN MAIN",0)) D
|
||||
. S DIE="^VA(200,",DR="2////^S X=ALPBAC"
|
||||
. ;Update name too
|
||||
. S DR=DR_";.01////^S X=ALPBNAM"
|
||||
. I ALPBDIS]"" S DR=DR_";7////^S X=ALPBDIS"
|
||||
. I ALPBSSN]"",$L(ALPBSSN)=9 S DR=DR_";9////^S X=ALPBSSN"
|
||||
. I ALPBVC]"" S DR=DR_";11////^S X=ALPBVC"
|
||||
. I +ALPBMENU S DR=DR_";201////^S X=ALPBMENU"
|
||||
. I $G(ALPBTRM)]"" S DR=DR_";9.2////^S X=ALPBTRM"
|
||||
. I $G(DR)]"" D ^DIE K DIC,DA,DR S DIK=DIE,DA=ALPBDA D IX1^DIK
|
||||
K ALPBDA,HL,ALPBDIS,ALPBI,ALBPJ,ALPBX,ALPBAC,ACLPVC,ALPBSSN,ALERR,ALPBNAM,ALPBTRM
|
||||
Q
|
||||
UNESC(ST,PR) ;Unescape string from message
|
||||
;ST=String to translate
|
||||
;PR=Event Protocol to set up HL array variables (optional)
|
||||
;First, do the escape character
|
||||
I $G(ST)="" Q ""
|
||||
S PR=$G(PR) I PR]"" D INIT^HLFNC2(PR,.HL)
|
||||
I '$D(HL) D
|
||||
. S HL("FS")="^"
|
||||
. S HL("ECH")="~|\&"
|
||||
S FS=$G(HL("FS")) I FS="" Q "" ;Field separator
|
||||
S EC=$G(HL("ECH")) I EC="" Q "" ;Encoding Charaters
|
||||
S CS=$E(EC) ;Component separator
|
||||
S RS=$E(EC,2) ;Repitition separator
|
||||
S ESC=$E(EC,3) ;Escape character
|
||||
S SS=$E(EC,4) ;Subcomponent separator
|
||||
S EEC=ESC_"E"_ESC ;escaped escape character
|
||||
S EFS=ESC_"F"_ESC ;escaped field sep
|
||||
S ECS=ESC_"S"_ESC ;escaped component sep
|
||||
S ERS=ESC_"R"_ESC ; escaped repitition sep
|
||||
S ESS=ESC_"T"_ESC ;escaped subcomponent separator
|
||||
K I,J,K,L,X F S X=$F(ST,EEC) S:X I=$G(I)+1,K(I)=$E(ST,1,X-1),ST=$E(ST,X,999) S:'X K($G(I)+1)=ST Q:'X
|
||||
S I=0 F S I=$O(K(I)) Q:I<1 S:K(I)[EEC K(I)=$P(K(I),EEC)_ESC S L=$G(L)_K(I)
|
||||
I $G(L)]"" S ST=L
|
||||
;
|
||||
K I,J,K,L,X F S X=$F(ST,EFS) S:X I=$G(I)+1,K(I)=$E(ST,1,X-1),ST=$E(ST,X,999) S:'X K($G(I)+1)=ST Q:'X
|
||||
S I=0 F S I=$O(K(I)) Q:I<1 S:K(I)[EFS K(I)=$P(K(I),EFS)_FS S L=$G(L)_K(I)
|
||||
I $G(L)]"" S ST=L
|
||||
;
|
||||
K I,J,K,L,X S I=0 F S X=$F(ST,ECS) S:X I=$G(I)+1,K(I)=$E(ST,1,X-1),ST=$E(ST,X,999) S:'X K(I+1)=ST Q:'X
|
||||
S I=0 F S I=$O(K(I)) Q:I<1 S:K(I)[ECS K(I)=$P(K(I),ECS)_CS S L=$G(L)_K(I)
|
||||
I $G(L)]"" S ST=L
|
||||
;
|
||||
K I,J,K,L,X S I=0 F S X=$F(ST,ERS) S:X I=$G(I)+1,K(I)=$E(ST,1,X-1),ST=$E(ST,X,999) S:'X K(I+1)=ST Q:'X
|
||||
S I=0 F S I=$O(K(I)) Q:I<1 S:K(I)[ERS K(I)=$P(K(I),ERS)_RS S L=$G(L)_K(I)
|
||||
I $G(L)]"" S ST=L
|
||||
;
|
||||
K I,J,K,L,X S I=0 F S X=$F(ST,ESS) S:X I=$G(I)+1,K(I)=$E(ST,1,X-1),ST=$E(ST,X,999) S:'X K(I+1)=ST Q:'X
|
||||
S I=0 F S I=$O(K(I)) Q:I<1 S:K(I)[ESS K(I)=$P(K(I),ESS)_SS S L=$G(L)_K(I)
|
||||
I $G(L)]"" S ST=L
|
||||
K I,J,K,L,X
|
||||
Q ST
|
||||
PERR ;PROCESSING ERRORS
|
||||
H 1 S DATE=$$NOW^XLFDT M ^TMP("BCBU",$J,$S($G(ALPBSSN)'="":ALPBSSN,1:0),DATE)=ALERR
|
||||
K ALERR
|
||||
Q
|
||||
ALPBGEN1 ;SFVAMC/JC - Parse and File HL7 PMU messages ;04/30/2003 07:59
|
||||
;;3.0;BAR CODE MED ADMIN;**8**;Mar 2004
|
||||
Q
|
||||
;
|
||||
PARSIT ;PARSE MESSAGE ON RECEIVING SIDE
|
||||
N FS,EC,CS,RS,ESC,SS,EEC,EFS,ECS,ERS,ESS,ALPBID,ALPBKY,ALPBMENU,ALPBMT,ALPBVC,DATE,DIK,DLAYGO,STF
|
||||
S FS=$G(HL("FS")) I FS="" W !,"NO SEPARATOR" Q:FS="" ;Field separator
|
||||
S EC=$G(HL("ECH")) Q:EC="" ;Encoding Charaters
|
||||
S CS=$E(EC) ;Component separator
|
||||
S RS=$E(EC,2) ;Repitition separator
|
||||
S ESC=$E(EC,3) ;Escape character
|
||||
S SS=$E(EC,4) ;Subcomponent separator
|
||||
S EEC=ESC_"E"_ESC ;escaped escape character
|
||||
S EFS=ESC_"F"_ESC ;escaped field sep
|
||||
S ECS=ESC_"S"_ESC ;escaped component sep
|
||||
S ERS=ESC_"R"_ESC ; escaped repitition sep
|
||||
S ESS=ESC_"T"_ESC ;escaped subcomponent separator
|
||||
N ALPBI,ALBPJ,ALPBX,ALPBAC,ACLPVC,ALPBSSN,ALPBERR,ALPBNAM,ALPBTRM
|
||||
F X HLNEXT Q:$G(HLQUIT)'>0 D
|
||||
. I $E(HLNODE,1,3)="EVN" S ALPBMT=$P(HLNODE,2)
|
||||
. I $E(HLNODE,1,3)="STF" S STF=$E(HLNODE,5,9999) D PSTF
|
||||
Q
|
||||
PSTF ;Process STF segment
|
||||
S ALPBKY=$P(STF,FS,1) Q:ALPBKY'[200_CS_"VISTA"
|
||||
S ALPBID=$P(STF,FS,2) S ALPBSSN=$E(ALPBID,1,9),ALPBAC=$P(ALPBID,RS,2),ALPBVC=$P(ALPBID,RS,3) D
|
||||
. S ALPBSSN=$TR(ALPBSSN,"-","")
|
||||
. I ALPBAC']"" S ALERR("ACCESS")="MISSING ACCESS CODE"
|
||||
. I ALPBVC']"" S ALERR("VERIFY")="MISSING VERIFY CODE"
|
||||
. ;Unescape Access Code
|
||||
. S ALPBAC=$$UNESC(ALPBAC)
|
||||
. ;Unescape Verify Code
|
||||
. S ALPBVC=$$UNESC(ALPBVC)
|
||||
S ALPBNAM=$P(STF,FS,3),ALPBNAM=$P(ALPBNAM,CS,1)_","_$P(ALPBNAM,CS,2)_" "_$P(ALPBNAM,CS,3)_" "_$P(ALPBNAM,CS,4) I ALPBNAM[" " S ALPBNAM=$TR(ALPBNAM," ","") I ALPBNAM']"" S ALERR("NAME")="MISSING NAME"
|
||||
I $D(ALERR) G PERR
|
||||
S ALPBDIS=$S($P(STF,FS,7)="I":1,1:0)
|
||||
I $P(STF,FS,13)]"" S ALPBTRM=$$HL7TFM^XLFDT($P(STF,FS,13),"L")
|
||||
FILE ;Store File 200 data on backup system
|
||||
N Y,DIC,DIE,DA,DR
|
||||
Q:'$D(ALPBNAM)
|
||||
Q:$L(ALPBSSN)'=9
|
||||
;Try exact SSn lookup first
|
||||
K Y S DIC="^VA(200,",DIC(0)="X",X=ALPBSSN,D="SSN" D IX^DIC
|
||||
;S DLAYGO=200,DIC="^VA(200,",DIC(0)="LM",X=ALPBNAM D ^DIC K DIC,DA,DR
|
||||
;If SSN lookup fails, try name lookup and add
|
||||
I +Y<1 S DLAYGO=200,DIC="^VA(200,",DIC(0)="LM",X=ALPBNAM D ^DIC K DIC,DA,DR
|
||||
I +Y>0 S (ALPBDA,DA)=+Y S ALPBMENU=$O(^DIC(19,"B","PSB BCBU WRKSTN MAIN",0)) D
|
||||
. S DIE="^VA(200,",DR="2////^S X=ALPBAC"
|
||||
. ;Update name too
|
||||
. S DR=DR_";.01////^S X=ALPBNAM"
|
||||
. I ALPBDIS]"" S DR=DR_";7////^S X=ALPBDIS"
|
||||
. I ALPBSSN]"",$L(ALPBSSN)=9 S DR=DR_";9////^S X=ALPBSSN"
|
||||
. I ALPBVC]"" S DR=DR_";11////^S X=ALPBVC"
|
||||
. I +ALPBMENU S DR=DR_";201////^S X=ALPBMENU"
|
||||
. I $G(ALPBTRM)]"" S DR=DR_";9.2////^S X=ALPBTRM"
|
||||
. I $G(DR)]"" D ^DIE K DIC,DA,DR S DIK=DIE,DA=ALPBDA D IX1^DIK
|
||||
K ALPBDA,HL,ALPBDIS,ALPBI,ALBPJ,ALPBX,ALPBAC,ACLPVC,ALPBSSN,ALERR,ALPBNAM,ALPBTRM
|
||||
Q
|
||||
UNESC(ST,PR) ;Unescape string from message
|
||||
;ST=String to translate
|
||||
;PR=Event Protocol to set up HL array variables (optional)
|
||||
;First, do the escape character
|
||||
I $G(ST)="" Q ""
|
||||
S PR=$G(PR) I PR]"" D INIT^HLFNC2(PR,.HL)
|
||||
I '$D(HL) D
|
||||
. S HL("FS")="^"
|
||||
. S HL("ECH")="~|\&"
|
||||
S FS=$G(HL("FS")) I FS="" Q "" ;Field separator
|
||||
S EC=$G(HL("ECH")) I EC="" Q "" ;Encoding Charaters
|
||||
S CS=$E(EC) ;Component separator
|
||||
S RS=$E(EC,2) ;Repitition separator
|
||||
S ESC=$E(EC,3) ;Escape character
|
||||
S SS=$E(EC,4) ;Subcomponent separator
|
||||
S EEC=ESC_"E"_ESC ;escaped escape character
|
||||
S EFS=ESC_"F"_ESC ;escaped field sep
|
||||
S ECS=ESC_"S"_ESC ;escaped component sep
|
||||
S ERS=ESC_"R"_ESC ; escaped repitition sep
|
||||
S ESS=ESC_"T"_ESC ;escaped subcomponent separator
|
||||
K I,J,K,L,X F S X=$F(ST,EEC) S:X I=$G(I)+1,K(I)=$E(ST,1,X-1),ST=$E(ST,X,999) S:'X K($G(I)+1)=ST Q:'X
|
||||
S I=0 F S I=$O(K(I)) Q:I<1 S:K(I)[EEC K(I)=$P(K(I),EEC)_ESC S L=$G(L)_K(I)
|
||||
I $G(L)]"" S ST=L
|
||||
;
|
||||
K I,J,K,L,X F S X=$F(ST,EFS) S:X I=$G(I)+1,K(I)=$E(ST,1,X-1),ST=$E(ST,X,999) S:'X K($G(I)+1)=ST Q:'X
|
||||
S I=0 F S I=$O(K(I)) Q:I<1 S:K(I)[EFS K(I)=$P(K(I),EFS)_FS S L=$G(L)_K(I)
|
||||
I $G(L)]"" S ST=L
|
||||
;
|
||||
K I,J,K,L,X S I=0 F S X=$F(ST,ECS) S:X I=$G(I)+1,K(I)=$E(ST,1,X-1),ST=$E(ST,X,999) S:'X K(I+1)=ST Q:'X
|
||||
S I=0 F S I=$O(K(I)) Q:I<1 S:K(I)[ECS K(I)=$P(K(I),ECS)_CS S L=$G(L)_K(I)
|
||||
I $G(L)]"" S ST=L
|
||||
;
|
||||
K I,J,K,L,X S I=0 F S X=$F(ST,ERS) S:X I=$G(I)+1,K(I)=$E(ST,1,X-1),ST=$E(ST,X,999) S:'X K(I+1)=ST Q:'X
|
||||
S I=0 F S I=$O(K(I)) Q:I<1 S:K(I)[ERS K(I)=$P(K(I),ERS)_RS S L=$G(L)_K(I)
|
||||
I $G(L)]"" S ST=L
|
||||
;
|
||||
K I,J,K,L,X S I=0 F S X=$F(ST,ESS) S:X I=$G(I)+1,K(I)=$E(ST,1,X-1),ST=$E(ST,X,999) S:'X K(I+1)=ST Q:'X
|
||||
S I=0 F S I=$O(K(I)) Q:I<1 S:K(I)[ESS K(I)=$P(K(I),ESS)_SS S L=$G(L)_K(I)
|
||||
I $G(L)]"" S ST=L
|
||||
K I,J,K,L,X
|
||||
Q ST
|
||||
PERR ;PROCESSING ERRORS
|
||||
H 1 S DATE=$$NOW^XLFDT M ^TMP("BCBU",$J,$S($G(ALPBSSN)'="":ALPBSSN,1:0),DATE)=ALERR
|
||||
K ALERR
|
||||
Q
|
||||
|
|
|
|||
|
|
@ -1,223 +1,221 @@
|
|||
ALPBINP ;OIFO-DALLAS/SED/KC/MW BCMA - BCBU INPT TO HL7 ;5/2/2002
|
||||
;;3.0;BAR CODE MED ADMIN;**8,37**;May 2007;Build 10
|
||||
;;Per VHA Directive 2004-038, this routine should not be modified.
|
||||
;This routine will intercept the HL7 message that it sent from Pharmacy
|
||||
;to CPRS to update order information. The message is then parsed and
|
||||
;repackage so it can be sent to the BCBU workstation.
|
||||
;
|
||||
; Reference/IA
|
||||
; EN^PSJBCBU/3876
|
||||
; $$EN^VAFHLPID/263
|
||||
; $$EN^VAFHAPV1/4512
|
||||
; EN1^GMRADPT/10099
|
||||
; EN^PSJBCMA1/2829
|
||||
;
|
||||
IPH(MSG) ;CAPTURE MESSAGE ARRAY FROM PHARMACY
|
||||
N VAIN,ALPMSG
|
||||
S ALPMSG=$S($L($G(MSG)):MSG,1:"MSG")
|
||||
I '$O(@ALPMSG@(0)) Q "0^MSG^Missing Message Array"
|
||||
S MSH=0
|
||||
F S MSH=$O(@ALPMSG@(MSH)) Q:MSH'>0 Q:$E(@ALPMSG@(MSH),1,3)="MSH"
|
||||
I +MSH'>0 Q "0^MSG^Missing MSH Segment Bad Message"
|
||||
S MSFS=$E(@ALPMSG@(MSH),4,4)
|
||||
S MSCS=$E(@ALPMSG@(MSH),5,5)
|
||||
S MSCH=$E(@ALPMSG@(MSH),6,6)
|
||||
S MSCTR=$E(@ALPMSG@(MSH),4,8)
|
||||
;The message is confirmed to be a Pharmacy message
|
||||
I $P(@ALPMSG@(MSH),MSFS,3)'="PHARMACY" Q "1^^Not a Pharmacy Message"
|
||||
;A PID and PV1 segment is required for this message
|
||||
S PID=0
|
||||
F S PID=$O(@ALPMSG@(PID)) Q:PID'>0 Q:$E(@ALPMSG@(PID),1,3)="PID"
|
||||
I +PID'>0 Q "0^MSG^Missing PID Segment Bad Message"
|
||||
;Also the patient must have an inpatient status
|
||||
S PV1=0
|
||||
F S PV1=$O(@ALPMSG@(PV1)) Q:PV1'>0 Q:$E(@ALPMSG@(PV1),1,3)="PV1"
|
||||
I +PV1'>0 Q "0^MSG^Missing PV1 Segment Bad Message"
|
||||
I $P(@ALPMSG@(PV1),MSFS,3)'="I" Q "1^^Not an Inpatient Pharmacy Message"
|
||||
S ORC=0
|
||||
F S ORC=$O(@ALPMSG@(ORC)) Q:ORC'>0 Q:$E(@ALPMSG@(ORC),1,3)="ORC"
|
||||
I +ORC'>0 Q "0^MSG^Missing ORC Segment Bad Message"
|
||||
;RE-BUILDING THE MESSAGE FOR BCBU
|
||||
S ALPDFN=$P(@ALPMSG@(PID),MSFS,4)
|
||||
I +ALPDFN'>0 Q "0^MSG^Invalid or Missing Patient - PID"
|
||||
S ALPORD=$P($P(@ALPMSG@(ORC),MSFS,4),MSCS,1)
|
||||
I ALPORD="" Q "0^MSG^Invalid or Missing Order Number - ORC"
|
||||
K ALPB
|
||||
D EN^PSJBCBU(ALPDFN,ALPORD,.ALPB)
|
||||
SEED ;Entry point for ^ALPBIND
|
||||
N VAIN
|
||||
D INIT
|
||||
S SUB=0 F S SUB=$O(ALPB(SUB)) Q:'SUB D
|
||||
. ;convert and move the message to the HLA array for transport
|
||||
. S HLA("HLS",SUB)=$$CNV^ALPBUTL1(MSCTR,HLCTR,ALPB(SUB))
|
||||
. ;Now check for continuations
|
||||
. S SUB1=0
|
||||
. F S SUB1=$O(ALPB(SUB,SUB1)) Q:'SUB1 D
|
||||
. . S HLA("HLS",SUB,SUB1)=$$CNV^ALPBUTL1(MSCTR,HLCTR,ALPB(SUB,SUB1))
|
||||
. I $E(HLA("HLS",SUB),1,3)="RXE" S RXE=SUB
|
||||
. I $E(HLA("HLS",SUB),1,3)="PID" S PID=SUB
|
||||
. I $E(HLA("HLS",SUB),1,3)="PV1" S PV1=SUB
|
||||
K HLA("HLS",MSH)
|
||||
I '$D(HLA("HLS",PID)) Q "0^MSG^Missing PID Segment Bad Message"
|
||||
S ALPDFN=$P($P(HLA("HLS",PID),HLFS,4),HLCS,1)
|
||||
I +ALPDFN'>0 Q "0^MSG^Invalid or Missing Patient - PID"
|
||||
S HLA("HLS",PID)=$$EN^VAFHLPID(ALPDFN,"2,7,8,19")
|
||||
;Fix RXE segement for Administration Type
|
||||
D RXE
|
||||
;Get the Division that the patient is associated with
|
||||
D PDIV
|
||||
I ALPDIV="DOM",+$$GET^XPAR("PKG.BAR CODE MED ADMIN","PSB BKUP DOM FILTER",1,"Q")>0 Q "0^^Screen of DOMICILIARY"
|
||||
I '$D(HLL("LINKS")) Q "0^HL7^Missing HLL Links Array Division # "_ALPDIV
|
||||
;SET NEW PV1
|
||||
D NOW^%DTC
|
||||
S STRING=$$EN^VAFHAPV1(ALPDFN,%,"2,3,7,18")
|
||||
S HLA("HLS",PV1)=STRING
|
||||
I +ORC>0 D
|
||||
. S ALPST=$$STAT^ALPBUTL1($P(HLA("HLS",ORC),HLFS,6))
|
||||
. Q:ALPST=""
|
||||
. S $P(HLA("HLS",ORC),HLFS,6)=$P(HLA("HLS",ORC),HLFS,6)_HLCS_ALPST
|
||||
D AL1
|
||||
;Capture message to review for testing before sending
|
||||
D SEND
|
||||
EXIT ;EXIT and kill
|
||||
K HLA,SUB,SUB1,STRING,ALPLOC,HLCS,HLCTR,HLFS,MSCH,MSCS,MSCTR
|
||||
K MSH,ORC,PID,PV1,RXE,RXR,ALPB,ALPBY,ALPBYN,ALPC,ALPDATA,ALPDFN
|
||||
K ALPDT,ALPI,ALPII,ALPIV,ALPOPTS,ALPOR,ALPORD,ALPST
|
||||
K ALPSTN,ALPSYM,EVENT,GMRA,GMRAL
|
||||
Q ALPRSLT
|
||||
INI() ;INTIAL SET UP ENTRY
|
||||
G SEED
|
||||
INIT ;CALL HL7 TO INITIALIZE MESSAGE VARIABLES
|
||||
;SET UP ENVIRONMENT FOR MESSAGE
|
||||
K HL,HLA,HLECH,HLQ,ALPRSLT,ALPOPTS
|
||||
S EVENT="PSB BCBU ORM SEND"
|
||||
D INIT^HLFNC2(EVENT,.HL,1)
|
||||
S HLCS=$E(HL("ECH")),HLCTR=HLFS_HL("ECH")
|
||||
Q
|
||||
SEND ;CALL HL7 TO TRANSMIT SINGLE MESSAGE
|
||||
K ALPRSLT,ALPOPTS
|
||||
D GENERATE^HLMA(EVENT,"LM",1,.ALPRSLT,"",.ALPOPTS)
|
||||
Q
|
||||
AL1 ;ALLERGY SEGMENT BUILD
|
||||
;The will build the ALP segment with the curent allergies
|
||||
;for the patient to be added to the message
|
||||
N DFN
|
||||
Q:+ALPDFN'>0
|
||||
K GMRAL
|
||||
S DFN=ALPDFN
|
||||
S GMRA="0^0^111" ;DEFINES WHAT ALLERGIES TO RETURN
|
||||
D EN1^GMRADPT
|
||||
Q:'$D(GMRAL)
|
||||
S ALPI=0,ALPC=1,ALPSYM=""
|
||||
F S ALPI=$O(GMRAL(ALPI)) Q:+ALPI'>0 D
|
||||
. S ALPADR=""
|
||||
. I $P($P(GMRAL(ALPI),U,8),";",2)="P" S ALPADR="**ADR** "
|
||||
. S ALPDATA="AL1"_HLFS_ALPC_HLFS_$P(GMRAL(ALPI),U,7)
|
||||
. S ALPDATA=ALPDATA_HLFS_ALPI_HLCS_ALPADR_$E($P(GMRAL(ALPI),U,2),1,25)_HLCS_"VA120.8"
|
||||
. ;S ALPII=0 F S ALPII=$O(GMRAL(ALPI,"S",ALPII)) Q:+ALPII'>0 D
|
||||
. ;. S ALPSYM=ALPSYM_$P(GMRAL(ALPI,"S",ALPII),";",1)_HLCS
|
||||
. ;S $P(ALPDATA,HLFS,6)=ALPSYM
|
||||
. S HLA("HLS",$O(HLA("HLS",9999999),-1)+1)=ALPDATA
|
||||
. S ALPC=ALPC+1
|
||||
K GMRAL
|
||||
Q
|
||||
RXE ;
|
||||
Q:+$G(RXE)'>0
|
||||
K ^TMP("PSJ1",$J)
|
||||
Q:'$D(HLA("HLS",RXE))
|
||||
S DATA=HLA("HLS",RXE)
|
||||
D EN^PSJBCMA1(ALPDFN,ALPORD,1)
|
||||
S TYP=$P($G(^TMP("PSJ1",$J,4)),U,2)
|
||||
Q:TYP="CONTINUOUS"
|
||||
Q:TYP="FILL ON REQUEST"
|
||||
S ALP1=$P(DATA,HLFS,2),ALP2=$P(ALP1,HLCS,2)
|
||||
I ALP1[TYP Q
|
||||
I ALP2[TYP Q
|
||||
S $P(ALP2,"&",1)=$P(ALP2,"&",1)_" "_TYP
|
||||
S $P(ALP1,HLCS,2)=ALP2,$P(DATA,HLFS,2)=ALP1
|
||||
S HLA("HLS",RXE)=DATA
|
||||
K TYP,ALP1,ALP2,^TMP("PSJ1",$J)
|
||||
Q
|
||||
PDIV ;PATIENT DIVISION
|
||||
;Check ALPBMDT Variable
|
||||
S:+$G(ALPBMDT)'>0 ALPBMDT=0
|
||||
S ALPDIV=$$DIV^ALPBUTL1(ALPDFN,ALPBMDT)
|
||||
;Screen Dom
|
||||
I ALPDIV="DOM",+$$GET^XPAR("PKG.BAR CODE MED ADMIN","PSB BKUP DOM FILTER",1,"Q")>0 Q
|
||||
;Now do I send the Message or not Based of Division
|
||||
I $D(ALPHLL("LINKS")) M HLL("LINKS")=ALPHLL("LINKS")
|
||||
I '$D(HLL("LINKS")) D GET^ALPBPARM(.HLL,ALPDIV)
|
||||
Q
|
||||
MEDL(ALPML) ;Use this entry to send MedLog messages
|
||||
N VAIN
|
||||
;ALPML is the IEN of the MedLog for file #53.79
|
||||
I '$D(ALPML) Q "0^ALPML^No Med-Log Number"
|
||||
I '$D(^PSB(53.79,ALPML,0)) Q "0^"_ALPML_"^Med - Log Number Invalid"
|
||||
;First get the required HL7 Variables
|
||||
D INIT
|
||||
;Need to build the PID, PV1 and ORC segments
|
||||
S ALPDFN=+$P($G(^PSB(53.79,ALPML,0)),U,1)
|
||||
I +ALPDFN'>0 Q "0^"_ALPML_"^Invalid or Missing Patient - Med-Log"
|
||||
;Get the Division that the patient is associated with
|
||||
D PDIV
|
||||
I ALPDIV="DOM",+$$GET^XPAR("PKG.BAR CODE MED ADMIN","PSB BKUP DOM FILTER",1,"Q")>0 Q "0^^Screen of DOMICILIARY"
|
||||
I '$D(HLL("LINKS")) Q "0^"_ALPML_"^Missing HLL Links Array Med-Log"
|
||||
S ALPST=$P($G(^PSB(53.79,ALPML,0)),U,9)
|
||||
S ALPBY=$P($G(^PSB(53.79,ALPML,0)),U,7)
|
||||
S ALPDT=$P($G(^PSB(53.79,ALPML,0)),U,6)
|
||||
S ALPOR=$P($G(^PSB(53.79,ALPML,.1)),U,1)
|
||||
S ALPBYN=$P($G(^VA(200,ALPBY,0)),U,1)
|
||||
S ALPSTN=$S($D(ALPST):$$EXTERNAL^DILFD(53.79,".09",,ALPST),1:"Non")
|
||||
I '$D(ALPOR) Q "0^"_ALPML_"^Invalid or Missing Pharmacy Order Number Med-Log"
|
||||
S PID=$$EN^VAFHLPID(ALPDFN,"2,7,8,19")
|
||||
I '$D(PID) Q "0^"_ALPML_"^Invalid or Missing Patient - PID Med-Log"
|
||||
S PV1=$$EN^VAFHAPV1(ALPDFN,DT,"2,3,7,18")
|
||||
I '$D(PV1) Q "0^"_ALPML_"^Invalid or Missing Patient Location - PV1 Med-Log"
|
||||
S HLA("HLS",1)=PID
|
||||
S HLA("HLS",2)=PV1
|
||||
;BUILD ORC SEGMENT
|
||||
S ORC="ORC"_HLFS_"ML"_HLFS_ALPML_HLCS_"ML"_HLFS_ALPOR_HLCS_"PS"_HLFS
|
||||
S ORC=ORC_HLFS_ALPST_HLCS_ALPSTN_HLFS_HLFS_HLFS_HLFS
|
||||
S ORC=ORC_$$HLDATE^HLFNC(ALPDT,"TS")_HLFS_ALPBY_HLCS_ALPBYN
|
||||
S HLA("HLS",3)=ORC
|
||||
;The Message is ready to send
|
||||
D SEND
|
||||
Q ALPRSLT
|
||||
;
|
||||
ADMQ ;Need to que a single patient init for admissions
|
||||
S ALDFN=ALPDFN
|
||||
S ZTDTH=$$NOW^XLFDT
|
||||
S ZTRTN="PAT^ALPBIND"
|
||||
S ZTDESC="PSB - Initialize Single Patient on Admission Contingency Workstation"
|
||||
S ZTIO="",ZTSAVE("ALDFN")=""
|
||||
D ^%ZTLOAD
|
||||
K ZTIO,ZTDESC,ZTRTN,ZTSK
|
||||
Q
|
||||
PMOV(ALPDFN,ALPTYP,ALPTT,ALPBMDT) ;Entry Point to send patient movement
|
||||
N VAIN
|
||||
I +$G(ALPDFN)'>0 Q "0^^Missing Patient ID"
|
||||
D INIT
|
||||
;Check Movement type. If not a discharge then don't pass date and time
|
||||
S:$G(ALPTT)'="DISCHARGE" ALPBMDT=0
|
||||
;Get the Division that the patient is associated with
|
||||
D PDIV
|
||||
I ALPDIV="DOM",+$$GET^XPAR("PKG.BAR CODE MED ADMIN","PSB BKUP DOM FILTER",1,"Q")>0 Q "0^^Screen of DOMICILIARY"
|
||||
I '$D(HLL("LINKS")) Q "0^"_ALPDFN_"^Missing HLL Links Array Pat-Move"
|
||||
S HLA("HLS",1)=$$EN^VAFHLPID(ALPDFN,"2,7,8,19")
|
||||
S HLA("HLS",2)=$$EN^VAFHAPV1(ALPDFN,DT,"2,3,7,18")
|
||||
S:$G(ALPTT)="DISCHARGE" $P(HLA("HLS",2),HLFS,37)=$G(ALPTYP)
|
||||
D SEND
|
||||
I ALPTYP=14!(ALPTYP=41) S ALPTT="ADMISSION" ;FOR RETURN FROM ASIH
|
||||
I $G(ALPTT)="ADMISSION" D ADMQ
|
||||
;SEND A DISCHARGE TO DIV SENDING ASIH
|
||||
I $G(ALPTYP)[13!($G(ALPTYP)[40) D
|
||||
.D INIT
|
||||
.S ALPWRD=$P($G(DGPMVI(5)),U,1) ;LAST WARD
|
||||
.I +ALPWRD'>0 S ALPRSLT="0^^Screen - No Ward" Q ;NO WARD
|
||||
.S ALPBDIV=$P($G(^DIC(42,ALPWRD,0)),U,11)
|
||||
.D GET^ALPBPARM(.HLL,ALPBDIV)
|
||||
.S HLA("HLS",1)=$$EN^VAFHLPID(ALPDFN,"2,7,8,19")
|
||||
.S HLA("HLS",2)=$$EN^VAFHAPV1(ALPDFN,DT,"2,3,7,18")
|
||||
.S $P(HLA("HLS",2),HLFS,37)="ASIH"
|
||||
.D SEND
|
||||
Q ALPRSLT
|
||||
ALPBINP ;OIFO-DALLAS/SED/KC/MW BCMA - BCBU INPT TO HL7 ;5/2/2002
|
||||
;;3.0;BAR CODE MED ADMIN;**8**;Mar 2004
|
||||
;This routine will intercept the HL7 message that it sent from Pharmacy
|
||||
;to CPRS to update order information. The message is then parsed and
|
||||
;repackage so it can be sent to the BCBU workstation.
|
||||
;
|
||||
; Reference/IA
|
||||
; EN^PSJBCBU/3876
|
||||
; $$EN^VAFHLPID/263
|
||||
; $$EN^VAFHAPV1/4512
|
||||
; EN1^GMRADPT/10099
|
||||
; EN^PSJBCMA1/2829
|
||||
;
|
||||
IPH(MSG) ;CAPTURE MESSAGE ARRAY FROM PHARMACY
|
||||
N VAIN,ALPMSG
|
||||
S ALPMSG=$S($L($G(MSG)):MSG,1:"MSG")
|
||||
I '$O(@ALPMSG@(0)) Q "0^MSG^Missing Message Array"
|
||||
S MSH=0
|
||||
F S MSH=$O(@ALPMSG@(MSH)) Q:MSH'>0 Q:$E(@ALPMSG@(MSH),1,3)="MSH"
|
||||
I +MSH'>0 Q "0^MSG^Missing MSH Segment Bad Message"
|
||||
S MSFS=$E(@ALPMSG@(MSH),4,4)
|
||||
S MSCS=$E(@ALPMSG@(MSH),5,5)
|
||||
S MSCH=$E(@ALPMSG@(MSH),6,6)
|
||||
S MSCTR=$E(@ALPMSG@(MSH),4,8)
|
||||
;The message is confirmed to be a Pharmacy message
|
||||
I $P(@ALPMSG@(MSH),MSFS,3)'="PHARMACY" Q "1^^Not a Pharmacy Message"
|
||||
;A PID and PV1 segment is required for this message
|
||||
S PID=0
|
||||
F S PID=$O(@ALPMSG@(PID)) Q:PID'>0 Q:$E(@ALPMSG@(PID),1,3)="PID"
|
||||
I +PID'>0 Q "0^MSG^Missing PID Segment Bad Message"
|
||||
;Also the patient must have an inpatient status
|
||||
S PV1=0
|
||||
F S PV1=$O(@ALPMSG@(PV1)) Q:PV1'>0 Q:$E(@ALPMSG@(PV1),1,3)="PV1"
|
||||
I +PV1'>0 Q "0^MSG^Missing PV1 Segment Bad Message"
|
||||
I $P(@ALPMSG@(PV1),MSFS,3)'="I" Q "1^^Not an Inpatient Pharmacy Message"
|
||||
S ORC=0
|
||||
F S ORC=$O(@ALPMSG@(ORC)) Q:ORC'>0 Q:$E(@ALPMSG@(ORC),1,3)="ORC"
|
||||
I +ORC'>0 Q "0^MSG^Missing ORC Segment Bad Message"
|
||||
;RE-BUILDING THE MESSAGE FOR BCBU
|
||||
S ALPDFN=$P(@ALPMSG@(PID),MSFS,4)
|
||||
I +ALPDFN'>0 Q "0^MSG^Invalid or Missing Patient - PID"
|
||||
S ALPORD=$P($P(@ALPMSG@(ORC),MSFS,4),MSCS,1)
|
||||
I ALPORD="" Q "0^MSG^Invalid or Missing Order Number - ORC"
|
||||
K ALPB
|
||||
D EN^PSJBCBU(ALPDFN,ALPORD,.ALPB)
|
||||
SEED ;Entry point for ^ALPBIND
|
||||
D INIT
|
||||
S SUB=0 F S SUB=$O(ALPB(SUB)) Q:'SUB D
|
||||
. ;convert and move the message to the HLA array for transport
|
||||
. S HLA("HLS",SUB)=$$CNV^ALPBUTL1(MSCTR,HLCTR,ALPB(SUB))
|
||||
. ;Now check for continuations
|
||||
. S SUB1=0
|
||||
. F S SUB1=$O(ALPB(SUB,SUB1)) Q:'SUB1 D
|
||||
. . S HLA("HLS",SUB,SUB1)=$$CNV^ALPBUTL1(MSCTR,HLCTR,ALPB(SUB,SUB1))
|
||||
. I $E(HLA("HLS",SUB),1,3)="RXE" S RXE=SUB
|
||||
. I $E(HLA("HLS",SUB),1,3)="PID" S PID=SUB
|
||||
. I $E(HLA("HLS",SUB),1,3)="PV1" S PV1=SUB
|
||||
K HLA("HLS",MSH)
|
||||
I '$D(HLA("HLS",PID)) Q "0^MSG^Missing PID Segment Bad Message"
|
||||
S ALPDFN=$P($P(HLA("HLS",PID),HLFS,4),HLCS,1)
|
||||
I +ALPDFN'>0 Q "0^MSG^Invalid or Missing Patient - PID"
|
||||
S HLA("HLS",PID)=$$EN^VAFHLPID(ALPDFN,"2,7,8,19")
|
||||
;Fix RXE segement for Administration Type
|
||||
D RXE
|
||||
;Get the Division that the patient is associated with
|
||||
D PDIV
|
||||
I ALPDIV="DOM" Q "0^^Screen of DOMICILIARY"
|
||||
I '$D(HLL("LINKS")) Q "0^HL7^Missing HLL Links Array Division # "_ALPDIV
|
||||
;SET NEW PV1
|
||||
D NOW^%DTC
|
||||
S STRING=$$EN^VAFHAPV1(ALPDFN,%,"2,3,7,18")
|
||||
S HLA("HLS",PV1)=STRING
|
||||
I +ORC>0 D
|
||||
. S ALPST=$$STAT^ALPBUTL1($P(HLA("HLS",ORC),HLFS,6))
|
||||
. Q:ALPST=""
|
||||
. S $P(HLA("HLS",ORC),HLFS,6)=$P(HLA("HLS",ORC),HLFS,6)_HLCS_ALPST
|
||||
D AL1
|
||||
;Capture message to review for testing before sending
|
||||
D SEND
|
||||
EXIT ;EXIT and kill
|
||||
K HLA,SUB,SUB1,STRING,ALPLOC,HLCS,HLCTR,HLFS,MSCH,MSCS,MSCTR
|
||||
K MSH,ORC,PID,PV1,RXE,RXR,ALPB,ALPBY,ALPBYN,ALPC,ALPDATA,ALPDFN
|
||||
K ALPDT,ALPI,ALPII,ALPIV,ALPOPTS,ALPOR,ALPORD,ALPST
|
||||
K ALPSTN,ALPSYM,EVENT,GMRA,GMRAL
|
||||
Q ALPRSLT
|
||||
INI() ;INTIAL SET UP ENTRY
|
||||
G SEED
|
||||
INIT ;CALL HL7 TO INITIALIZE MESSAGE VARIABLES
|
||||
;SET UP ENVIRONMENT FOR MESSAGE
|
||||
K HL,HLA,HLECH,HLQ,ALPRSLT,ALPOPTS
|
||||
S EVENT="PSB BCBU ORM SEND"
|
||||
D INIT^HLFNC2(EVENT,.HL,1)
|
||||
S HLCS=$E(HL("ECH")),HLCTR=HLFS_HL("ECH")
|
||||
Q
|
||||
SEND ;CALL HL7 TO TRANSMIT SINGLE MESSAGE
|
||||
K ALPRSLT,ALPOPTS
|
||||
D GENERATE^HLMA(EVENT,"LM",1,.ALPRSLT,"",.ALPOPTS)
|
||||
Q
|
||||
AL1 ;ALLERGY SEGMENT BUILD
|
||||
;The will build the ALP segment with the curent allergies
|
||||
;for the patient to be added to the message
|
||||
N DFN
|
||||
Q:+ALPDFN'>0
|
||||
K GMRAL
|
||||
S DFN=ALPDFN
|
||||
S GMRA="0^0^111" ;DEFINES WHAT ALLERGIES TO RETURN
|
||||
D EN1^GMRADPT
|
||||
Q:'$D(GMRAL)
|
||||
S ALPI=0,ALPC=1,ALPSYM=""
|
||||
F S ALPI=$O(GMRAL(ALPI)) Q:+ALPI'>0 D
|
||||
. S ALPADR=""
|
||||
. I $P($P(GMRAL(ALPI),U,8),";",2)="P" S ALPADR="**ADR** "
|
||||
. S ALPDATA="AL1"_HLFS_ALPC_HLFS_$P(GMRAL(ALPI),U,7)
|
||||
. S ALPDATA=ALPDATA_HLFS_ALPI_HLCS_ALPADR_$E($P(GMRAL(ALPI),U,2),1,25)_HLCS_"VA120.8"
|
||||
. ;S ALPII=0 F S ALPII=$O(GMRAL(ALPI,"S",ALPII)) Q:+ALPII'>0 D
|
||||
. ;. S ALPSYM=ALPSYM_$P(GMRAL(ALPI,"S",ALPII),";",1)_HLCS
|
||||
. ;S $P(ALPDATA,HLFS,6)=ALPSYM
|
||||
. S HLA("HLS",$O(HLA("HLS",9999999),-1)+1)=ALPDATA
|
||||
. S ALPC=ALPC+1
|
||||
K GMRAL
|
||||
Q
|
||||
RXE ;
|
||||
Q:+$G(RXE)'>0
|
||||
K ^TMP("PSJ1",$J)
|
||||
Q:'$D(HLA("HLS",RXE))
|
||||
S DATA=HLA("HLS",RXE)
|
||||
D EN^PSJBCMA1(ALPDFN,ALPORD,1)
|
||||
S TYP=$P($G(^TMP("PSJ1",$J,4)),U,2)
|
||||
Q:TYP="CONTINUOUS"
|
||||
Q:TYP="FILL ON REQUEST"
|
||||
S ALP1=$P(DATA,HLFS,2),ALP2=$P(ALP1,HLCS,2)
|
||||
I ALP1[TYP Q
|
||||
I ALP2[TYP Q
|
||||
S $P(ALP2,"&",1)=$P(ALP2,"&",1)_" "_TYP
|
||||
S $P(ALP1,HLCS,2)=ALP2,$P(DATA,HLFS,2)=ALP1
|
||||
S HLA("HLS",RXE)=DATA
|
||||
K TYP,ALP1,ALP2,^TMP("PSJ1",$J)
|
||||
Q
|
||||
PDIV ;PATIENT DIVISION
|
||||
;Check ALPBMDT Variable
|
||||
S:+$G(ALPBMDT)'>0 ALPBMDT=0
|
||||
S ALPDIV=$$DIV^ALPBUTL1(ALPDFN,ALPBMDT)
|
||||
;Screen Dom
|
||||
Q:ALPDIV="DOM"
|
||||
;Now do I send the Message or not Based of Division
|
||||
I $D(ALPHLL("LINKS")) M HLL("LINKS")=ALPHLL("LINKS")
|
||||
I '$D(HLL("LINKS")) D GET^ALPBPARM(.HLL,ALPDIV)
|
||||
Q
|
||||
MEDL(ALPML) ;Use this entry to send MedLog messages
|
||||
N VAIN
|
||||
;ALPML is the IEN of the MedLog for file #53.79
|
||||
I '$D(ALPML) Q "0^ALPML^No Med-Log Number"
|
||||
I '$D(^PSB(53.79,ALPML,0)) Q "0^"_ALPML_"^Med - Log Number Invalid"
|
||||
;First get the required HL7 Variables
|
||||
D INIT
|
||||
;Need to build the PID, PV1 and ORC segments
|
||||
S ALPDFN=+$P($G(^PSB(53.79,ALPML,0)),U,1)
|
||||
I +ALPDFN'>0 Q "0^"_ALPML_"^Invalid or Missing Patient - Med-Log"
|
||||
;Get the Division that the patient is associated with
|
||||
D PDIV
|
||||
I ALPDIV="DOM" Q "0^^Screen of DOMICILIARY"
|
||||
I '$D(HLL("LINKS")) Q "0^"_ALPML_"^Missing HLL Links Array Med-Log"
|
||||
S ALPST=$P($G(^PSB(53.79,ALPML,0)),U,9)
|
||||
S ALPBY=$P($G(^PSB(53.79,ALPML,0)),U,7)
|
||||
S ALPDT=$P($G(^PSB(53.79,ALPML,0)),U,6)
|
||||
S ALPOR=$P($G(^PSB(53.79,ALPML,.1)),U,1)
|
||||
S ALPBYN=$P($G(^VA(200,ALPBY,0)),U,1)
|
||||
S ALPSTN=$S($D(ALPST):$$EXTERNAL^DILFD(53.79,".09",,ALPST),1:"Non")
|
||||
I '$D(ALPOR) Q "0^"_ALPML_"^Invalid or Missing Pharmacy Order Number Med-Log"
|
||||
S PID=$$EN^VAFHLPID(ALPDFN,"2,7,8,19")
|
||||
I '$D(PID) Q "0^"_ALPML_"^Invalid or Missing Patient - PID Med-Log"
|
||||
S PV1=$$EN^VAFHAPV1(ALPDFN,DT,"2,3,7,18")
|
||||
I '$D(PV1) Q "0^"_ALPML_"^Invalid or Missing Patient Location - PV1 Med-Log"
|
||||
S HLA("HLS",1)=PID
|
||||
S HLA("HLS",2)=PV1
|
||||
;BUILD ORC SEGMENT
|
||||
S ORC="ORC"_HLFS_"ML"_HLFS_ALPML_HLCS_"ML"_HLFS_ALPOR_HLCS_"PS"_HLFS
|
||||
S ORC=ORC_HLFS_ALPST_HLCS_ALPSTN_HLFS_HLFS_HLFS_HLFS
|
||||
S ORC=ORC_$$HLDATE^HLFNC(ALPDT,"TS")_HLFS_ALPBY_HLCS_ALPBYN
|
||||
S HLA("HLS",3)=ORC
|
||||
;The Message is ready to send
|
||||
D SEND
|
||||
Q ALPRSLT
|
||||
;
|
||||
ADMQ ;Need to que a single patient init for admissions
|
||||
S ALDFN=ALPDFN
|
||||
S ZTDTH=$$NOW^XLFDT
|
||||
S ZTRTN="PAT^ALPBIND"
|
||||
S ZTDESC="PSB - Initialize Single Patient on Admission Contingency Workstation"
|
||||
S ZTIO="",ZTSAVE("ALDFN")=""
|
||||
D ^%ZTLOAD
|
||||
K ZTIO,ZTDESC,ZTRTN,ZTSK
|
||||
Q
|
||||
PMOV(ALPDFN,ALPTYP,ALPTT,ALPBMDT) ;Entry Point to send patient movement
|
||||
N VAIN
|
||||
I +$G(ALPDFN)'>0 Q "0^^Missing Patient ID"
|
||||
D INIT
|
||||
;Check Movement type. If not a discharge then don't pass date and time
|
||||
S:$G(ALPTT)'="DISCHARGE" ALPBMDT=0
|
||||
;Get the Division that the patient is associated with
|
||||
D PDIV
|
||||
I ALPDIV="DOM" Q "0^^Screen of DOMICILIARY"
|
||||
I '$D(HLL("LINKS")) Q "0^"_ALPDFN_"^Missing HLL Links Array Pat-Move"
|
||||
S HLA("HLS",1)=$$EN^VAFHLPID(ALPDFN,"2,7,8,19")
|
||||
S HLA("HLS",2)=$$EN^VAFHAPV1(ALPDFN,DT,"2,3,7,18")
|
||||
S:$G(ALPTT)="DISCHARGE" $P(HLA("HLS",2),HLFS,37)=$G(ALPTYP)
|
||||
D SEND
|
||||
I ALPTYP=14!(ALPTYP=41) S ALPTT="ADMISSION" ;FOR RETURN FROM ASIH
|
||||
I $G(ALPTT)="ADMISSION" D ADMQ
|
||||
;SEND A DISCHARGE TO DIV SENDING ASIH
|
||||
I $G(ALPTYP)[13!($G(ALPTYP)[40) D
|
||||
.D INIT
|
||||
.S ALPWRD=$P($G(DGPMVI(5)),U,1) ;LAST WARD
|
||||
.I +ALPWRD'>0 S ALPRSLT="0^^Screen - No Ward" Q ;NO WARD
|
||||
.S ALPBDIV=$P($G(^DIC(42,ALPWRD,0)),U,11)
|
||||
.D GET^ALPBPARM(.HLL,ALPBDIV)
|
||||
.S HLA("HLS",1)=$$EN^VAFHLPID(ALPDFN,"2,7,8,19")
|
||||
.S HLA("HLS",2)=$$EN^VAFHAPV1(ALPDFN,DT,"2,3,7,18")
|
||||
.S $P(HLA("HLS",2),HLFS,37)="ASIH"
|
||||
.D SEND
|
||||
Q ALPRSLT
|
||||
|
|
|
|||
|
|
@ -1,201 +1,199 @@
|
|||
ALPBPWRD ;OIFO-DALLAS MW,SED,KC-PRINT 3-DAY MAR BCMA BCBU REPORT FOR A SELECTED WARD ;01/01/03
|
||||
;;3.0;BAR CODE MED ADMIN;**8,37**;Mar 2004;Build 10
|
||||
;;Per VHA Directive 2004-038, this routine should not be modified.
|
||||
;
|
||||
; NOTE: this routine is designed for hard-copy output.
|
||||
; Output is formatted for 132-column printing.
|
||||
;
|
||||
F D Q:$D(DIRUT)
|
||||
.W !,"Inpatient Pharmacy Orders for a selected ward"
|
||||
.S DIR(0)="FAO^2:10"
|
||||
.S DIR("A")="Select WARD: "
|
||||
.S DIR("?")="^D WARDLIST^ALPBUTL(""C"")"
|
||||
.D ^DIR K DIR
|
||||
.I $D(DIRUT) Q
|
||||
.D WARDSEL^ALPBUTL(Y,.ALPBSEL)
|
||||
.I +$G(ALPBSEL(0))=0 D Q
|
||||
..W $C(7)
|
||||
..W " ??"
|
||||
..D WARDLIST^ALPBUTL("C")
|
||||
..K ALPBSEL
|
||||
.I +$G(ALPBSEL(0))=1 D
|
||||
..S ALPBWARD=ALPBSEL(1)
|
||||
..W " ",ALPBWARD
|
||||
..K ALPBSEL
|
||||
.I +$G(ALPBSEL(0))>1 D I $D(DIRUT) K DIRUT,DTOUT,X,Y Q
|
||||
..S ALPBX=0
|
||||
..F S ALPBX=$O(ALPBSEL(ALPBX)) Q:'ALPBX W !?2,$J(ALPBX,2)," ",ALPBSEL(ALPBX)
|
||||
..K ALPBX
|
||||
..S DIR(0)="NA^1:"_ALPBSEL(0)
|
||||
..S DIR("A")="Select Ward from the list (1-"_ALPBSEL(0)_"): "
|
||||
..W ! D ^DIR K DIR
|
||||
..I $D(DIRUT) K ALPBSEL Q
|
||||
..S ALPBWARD=ALPBSEL(+Y)
|
||||
..K ALPBSEL
|
||||
.;
|
||||
.; get all or just current orders?...
|
||||
.S DIR(0)="SA^A:ALL;C:CURRENT"
|
||||
.S DIR("A")="Report [A]LL or [C]URRENT orders? "
|
||||
.S DIR("B")="CURRENT"
|
||||
.S DIR("?")="[A]LL=all orders in the file, [C]URRENT=orders not yet expired."
|
||||
.W ! D ^DIR K DIR
|
||||
.I $D(DIRUT) K ALPBWARD,DIRUT,DTOUT,X,Y Q
|
||||
.S ALPBOTYP=Y
|
||||
.;
|
||||
.;SORT BY NAME OR ROOM/BED added 6/23/05
|
||||
.S DIR(0)="SA^N:Name;R:Room/Bed"
|
||||
.S DIR("A")="Sort Patients by [N]ame or [R]oom/Bed? "
|
||||
.S DIR("B")="Room/bed"
|
||||
.S DIR("?")="Sort by [N]ame or [R]oom Bed"
|
||||
.W ! D ^DIR K DIR
|
||||
.I $D(DIRUT) K ALPBWARD,DIRUT,DTOUT,X,Y Q
|
||||
.S ALPBSORT=Y
|
||||
.;
|
||||
.; print how many days MAR?...
|
||||
.S DIR(0)="NA^1:7"
|
||||
.S DIR("A")="Print how many days MAR? "
|
||||
.S DIR("B")=$$DEFDAYS^ALPBUTL()
|
||||
.S DIR("?")="The default is shown; you may enter 3 or 7."
|
||||
.W ! D ^DIR K DIR
|
||||
.I $D(DIRUT) K ALPBOTYP,DIRUT,DTOUT,X,Y Q
|
||||
.S ALPBDAYS=+Y
|
||||
.;
|
||||
.; BCMA Med Log info for how many ?...
|
||||
.S DIR(0)="NA^1:99"
|
||||
.S DIR("B")=$$DEFML^ALPBUTL3()
|
||||
.S DIR("A")="Select how many BCMA Medication Log history: "
|
||||
.S DIR("A",1)=" "
|
||||
.S DIR("?",1)="Select a number of BCMA Medication log entries"
|
||||
.S DIR("?",2)="for each of the patient's orders"
|
||||
.S DIR("?")="They are listed by the most current entry first"
|
||||
.D ^DIR K DIR
|
||||
.I $D(DIRUT) K ALPBOTYP,ALPBWARD,DIRUT,DTOUT,X,Y Q
|
||||
.S ALPBMLOG=Y
|
||||
.;
|
||||
.S %ZIS="Q"
|
||||
.S %ZIS("B")=$$DEFPRT^ALPBUTL()
|
||||
.I %ZIS("B")="" K %ZIS("B")
|
||||
.W ! D ^%ZIS K %ZIS
|
||||
.I POP D Q
|
||||
..W $C(7)
|
||||
..K ALPBMLOG,ALPBOTYP,ALPBWARD,POP
|
||||
.;
|
||||
.; output not queued...
|
||||
.I '$D(IO("Q")) D
|
||||
..U IO
|
||||
..D DQ
|
||||
..I IO'=IO(0) D ^%ZISC
|
||||
.;
|
||||
.; set up the Task...
|
||||
.I $D(IO("Q")) D
|
||||
..S ZTRTN="DQ^ALPBPWRD"
|
||||
..S ZTDESC="PSB INPT PHARM ORDERS FOR WARD "_ALPBWARD
|
||||
..S ZTSAVE("ALPBDAYS")=""
|
||||
..S ZTSAVE("ALPBWARD")=""
|
||||
..S ZTSAVE("ALPBMLOG")=""
|
||||
..S ZTSAVE("ALPBOTYP")=""
|
||||
..S ZTSAVE("ALPBSORT")=""
|
||||
..S ZTIO=ION
|
||||
..D ^%ZTLOAD
|
||||
..D HOME^%ZIS
|
||||
..W !,$S($G(ZTSK):"Task number "_ZTSK_" queued.",1:"ERROR -- NOT QUEUED!")
|
||||
..K IO("Q"),ZTSK
|
||||
.K ALPBDAYS,ALPBMLOG,ALPBOTYP,ALPBWARD
|
||||
K DIRUT,DTOUT,X,Y
|
||||
Q
|
||||
;
|
||||
DQ ; output entry point...
|
||||
K ^TMP($J)
|
||||
;
|
||||
; set report date... SED 11/4/03
|
||||
S ALPBRDAT=$S(ALPBOTYP="C":$$NOW^XLFDT(),1:"")
|
||||
;
|
||||
; loop through ward cross reference in 53.7...
|
||||
S ALPBPTN=""
|
||||
F S ALPBPTN=$O(^ALPB(53.7,"AW",ALPBWARD,ALPBPTN)) Q:ALPBPTN="" D
|
||||
.S ALPBIEN=0
|
||||
.F S ALPBIEN=$O(^ALPB(53.7,"AW",ALPBWARD,ALPBPTN,ALPBIEN)) Q:'ALPBIEN D
|
||||
..D ORDS^ALPBUTL(ALPBIEN,ALPBRDAT,.ALPBORDS)
|
||||
..I +ALPBORDS(0)'>0 K ALPBORDS Q
|
||||
..I $G(ALPBPDAT(0))="" S ALPBPDAT(0)=$G(^ALPB(53.7,ALPBIEN,0))
|
||||
..S ALPBOIEN=0
|
||||
..F S ALPBOIEN=$O(ALPBORDS(ALPBOIEN)) Q:'ALPBOIEN D
|
||||
...S ALPBDATA=$G(^ALPB(53.7,ALPBIEN,2,ALPBOIEN,1))
|
||||
...S ALPBOCT=$P($G(^ALPB(53.7,ALPBIEN,2,ALPBOIEN,3)),U,1)
|
||||
...S:$P($G(^ALPB(53.7,ALPBIEN,2,ALPBOIEN,4)),U,3)["PRN" ALPBOCT=ALPBOCT_"P"
|
||||
...; if report is for "C"urrent, check stop date and quit if
|
||||
...; stop date is less than report date...
|
||||
...I ALPBOTYP="C"&($P(ALPBDATA,U,2)<ALPBRDAT) K ALPBDATA Q
|
||||
...S ALPBORDN=ALPBORDS(ALPBOIEN)
|
||||
...S ALPBOST=$$STAT2^ALPBUTL1(ALPBORDS(ALPBOIEN,2))
|
||||
...I '$D(^TMP($J,ALPBPTN)) S ^TMP($J,ALPBPTN)=ALPBIEN
|
||||
...S ^TMP($J,ALPBPTN,ALPBOCT,ALPBOST,ALPBORDN)=ALPBOIEN
|
||||
...K ALPBDATA,ALPBORDN,ALPBOST
|
||||
..K ALPBOIEN,ALPBORDS,ALPBPDAT
|
||||
.K ALPBIEN
|
||||
K ALPBPTN
|
||||
;
|
||||
; Sort by Patient Name or room/bed capability added 6/23/05 KFOX
|
||||
S ALPBPG=0
|
||||
S ALPBPTN=""
|
||||
I ALPBSORT="N" D
|
||||
.F S ALPBPTN=$O(^TMP($J,ALPBPTN)) Q:ALPBPTN="" S ALPBIEN=^TMP($J,ALPBPTN) D PRT
|
||||
;SORT BY ROOM/BED
|
||||
I ALPBSORT="R" D
|
||||
.S ALPBD="",ALPRM=""
|
||||
.F S ALPBPTN=$O(^TMP($J,ALPBPTN)) Q:ALPBPTN="" D Q:ALPBPTN=""
|
||||
..I ALPBPTN="BCBU" S ALPBPTN=$O(^TMP($J,ALPBPTN)) ;SKIP "BCBU" SUBSCRIBE
|
||||
..I ALPBPTN="" Q ;PSB*3*37 Stop null subscript when "BCBU" is the last entry in ^TMP
|
||||
..S ALPBIEN=^TMP($J,ALPBPTN) S ALPRM=$P($G(^ALPB(53.7,ALPBIEN,0)),"^",6),ALPBD=$P($G(^ALPB(53.7,ALPBIEN,0)),"^",7)
|
||||
..I ALPBD="" S ALPB="NONE" I ALPRM="" S ALPB="NONE" ;INCASE NO ROOM AND BED YET
|
||||
..S ^TMP($J,"BCBU",ALPRM,ALPRM,ALPBD,ALPBPTN)=ALPBIEN
|
||||
.S ALPRM1="" F S ALPRM1=$O(^TMP($J,"BCBU",ALPRM1)) Q:ALPRM1="" D
|
||||
..S ALPRM="" F S ALPRM=$O(^TMP($J,"BCBU",ALPRM1,ALPRM)) Q:ALPRM="" D
|
||||
...S ALPBD="" F S ALPBD=$O(^TMP($J,"BCBU",ALPRM1,ALPRM,ALPBD)) Q:ALPBD="" D
|
||||
....S ALPBPTN="" F S ALPBPTN=$O(^TMP($J,"BCBU",ALPRM1,ALPRM,ALPBD,ALPBPTN)) Q:ALPBPTN="" D
|
||||
.....S ALPBIEN=$G(^TMP($J,"BCBU",ALPRM1,ALPRM,ALPBD,ALPBPTN)) D PRT
|
||||
D DONE
|
||||
Q
|
||||
PRT S ALPBPDAT(0)=$G(^ALPB(53.7,ALPBIEN,0))
|
||||
M ALPBPDAT(1)=^ALPB(53.7,ALPBIEN,1)
|
||||
I ALPBPG=0 D PAGE
|
||||
S ALPBOCT=""
|
||||
F S ALPBOCT=$O(^TMP($J,ALPBPTN,ALPBOCT)) Q:ALPBOCT="" D
|
||||
.S ALPBOST=""
|
||||
.F S ALPBOST=$O(^TMP($J,ALPBPTN,ALPBOCT,ALPBOST)) Q:ALPBOST="" D
|
||||
..S ALPBORDN=""
|
||||
..F S ALPBORDN=$O(^TMP($J,ALPBPTN,ALPBOCT,ALPBOST,ALPBORDN)) Q:ALPBORDN="" D
|
||||
...S ALPBOIEN=^TMP($J,ALPBPTN,ALPBOCT,ALPBOST,ALPBORDN)
|
||||
...; get and print this order's data...
|
||||
...M ALPBDATA=^ALPB(53.7,ALPBIEN,2,ALPBOIEN)
|
||||
...D F132^ALPBFRM1(.ALPBDATA,ALPBDAYS,ALPBMLOG,.ALPBFORM,ALPBIEN)
|
||||
...;D F132^ALPBFRM1(.ALPBDATA,ALPBDAYS,.ALPBFORM)
|
||||
...I $Y+ALPBFORM(0)=IOSL!($Y+ALPBFORM(0)>IOSL) D PAGE
|
||||
...F ALPBX=1:1:ALPBFORM(0) W !,ALPBFORM(ALPBX)
|
||||
...K ALPBDATA,ALPBFORM,ALPBOIEN,ALPBX
|
||||
..K ALPBORDN
|
||||
.K ALPBOST
|
||||
K ALPBOCT
|
||||
; print footer at end of this patient's record...
|
||||
I $Y+10>IOSL D PAGE
|
||||
W !!
|
||||
D FOOT^ALPBFRMU
|
||||
;Print a blank page between patient
|
||||
W @IOF
|
||||
S ALPBPG=0
|
||||
K ALPBPDAT
|
||||
Q
|
||||
;K ALPBIEN,ALPBPDAT KILLING ALPBIEN WILL BREAK SORT BY ROOM/BED
|
||||
;
|
||||
DONE ;
|
||||
K ALPBDAYS,ALPBMLOG,ALPBOTYP,ALPBPG,ALPBPTN,ALPBRDAT,ALPBWARD,^TMP($J),ALPRM,ALPRM1,ALPBD,ALPBIEN,ALPBSORT
|
||||
I $D(ZTQUEUED) S ZTREQ="@"
|
||||
Q
|
||||
;
|
||||
PAGE ; print page header for patient...
|
||||
W @IOF
|
||||
S ALPBPG=ALPBPG+1
|
||||
D HDR^ALPBFRMU(.ALPBPDAT,ALPBPG,.ALPBHDR)
|
||||
F ALPBX=1:1:ALPBHDR(0) W !,ALPBHDR(ALPBX)
|
||||
K ALPBHDR,ALPBX
|
||||
Q
|
||||
ALPBPWRD ;OIFO-DALLAS MW,SED,KC-PRINT 3-DAY MAR BCMA BCBU REPORT FOR A SELECTED WARD ;01/01/03
|
||||
;;3.0;BAR CODE MED ADMIN;**8**;Mar 2004
|
||||
;
|
||||
; NOTE: this routine is designed for hard-copy output.
|
||||
; Output is formatted for 132-column printing.
|
||||
;
|
||||
F D Q:$D(DIRUT)
|
||||
.W !,"Inpatient Pharmacy Orders for a selected ward"
|
||||
.S DIR(0)="FAO^2:10"
|
||||
.S DIR("A")="Select WARD: "
|
||||
.S DIR("?")="^D WARDLIST^ALPBUTL(""C"")"
|
||||
.D ^DIR K DIR
|
||||
.I $D(DIRUT) Q
|
||||
.D WARDSEL^ALPBUTL(Y,.ALPBSEL)
|
||||
.I +$G(ALPBSEL(0))=0 D Q
|
||||
..W $C(7)
|
||||
..W " ??"
|
||||
..D WARDLIST^ALPBUTL("C")
|
||||
..K ALPBSEL
|
||||
.I +$G(ALPBSEL(0))=1 D
|
||||
..S ALPBWARD=ALPBSEL(1)
|
||||
..W " ",ALPBWARD
|
||||
..K ALPBSEL
|
||||
.I +$G(ALPBSEL(0))>1 D I $D(DIRUT) K DIRUT,DTOUT,X,Y Q
|
||||
..S ALPBX=0
|
||||
..F S ALPBX=$O(ALPBSEL(ALPBX)) Q:'ALPBX W !?2,$J(ALPBX,2)," ",ALPBSEL(ALPBX)
|
||||
..K ALPBX
|
||||
..S DIR(0)="NA^1:"_ALPBSEL(0)
|
||||
..S DIR("A")="Select Ward from the list (1-"_ALPBSEL(0)_"): "
|
||||
..W ! D ^DIR K DIR
|
||||
..I $D(DIRUT) K ALPBSEL Q
|
||||
..S ALPBWARD=ALPBSEL(+Y)
|
||||
..K ALPBSEL
|
||||
.;
|
||||
.; get all or just current orders?...
|
||||
.S DIR(0)="SA^A:ALL;C:CURRENT"
|
||||
.S DIR("A")="Report [A]LL or [C]URRENT orders? "
|
||||
.S DIR("B")="CURRENT"
|
||||
.S DIR("?")="[A]LL=all orders in the file, [C]URRENT=orders not yet expired."
|
||||
.W ! D ^DIR K DIR
|
||||
.I $D(DIRUT) K ALPBWARD,DIRUT,DTOUT,X,Y Q
|
||||
.S ALPBOTYP=Y
|
||||
.;
|
||||
.;SORT BY NAME OR ROOM/BED added 6/23/05
|
||||
.S DIR(0)="SA^N:Name;R:Room/Bed"
|
||||
.S DIR("A")="Sort Patients by [N]ame or [R]oom/Bed? "
|
||||
.S DIR("B")="Room/bed"
|
||||
.S DIR("?")="Sort by [N]ame or [R]oom Bed"
|
||||
.W ! D ^DIR K DIR
|
||||
.I $D(DIRUT) K ALPBWARD,DIRUT,DTOUT,X,Y Q
|
||||
.S ALPBSORT=Y
|
||||
.;
|
||||
.; print how many days MAR?...
|
||||
.S DIR(0)="NA^1:7"
|
||||
.S DIR("A")="Print how many days MAR? "
|
||||
.S DIR("B")=$$DEFDAYS^ALPBUTL()
|
||||
.S DIR("?")="The default is shown; you may enter 3 or 7."
|
||||
.W ! D ^DIR K DIR
|
||||
.I $D(DIRUT) K ALPBOTYP,DIRUT,DTOUT,X,Y Q
|
||||
.S ALPBDAYS=+Y
|
||||
.;
|
||||
.; BCMA Med Log info for how many ?...
|
||||
.S DIR(0)="NA^1:99"
|
||||
.S DIR("B")=$$DEFML^ALPBUTL3()
|
||||
.S DIR("A")="Select how many BCMA Medication Log history: "
|
||||
.S DIR("A",1)=" "
|
||||
.S DIR("?",1)="Select a number of BCMA Medication log entries"
|
||||
.S DIR("?",2)="for each of the patient's orders"
|
||||
.S DIR("?")="They are listed by the most current entry first"
|
||||
.D ^DIR K DIR
|
||||
.I $D(DIRUT) K ALPBOTYP,ALPBWARD,DIRUT,DTOUT,X,Y Q
|
||||
.S ALPBMLOG=Y
|
||||
.;
|
||||
.S %ZIS="Q"
|
||||
.S %ZIS("B")=$$DEFPRT^ALPBUTL()
|
||||
.I %ZIS("B")="" K %ZIS("B")
|
||||
.W ! D ^%ZIS K %ZIS
|
||||
.I POP D Q
|
||||
..W $C(7)
|
||||
..K ALPBMLOG,ALPBOTYP,ALPBWARD,POP
|
||||
.;
|
||||
.; output not queued...
|
||||
.I '$D(IO("Q")) D
|
||||
..U IO
|
||||
..D DQ
|
||||
..I IO'=IO(0) D ^%ZISC
|
||||
.;
|
||||
.; set up the Task...
|
||||
.I $D(IO("Q")) D
|
||||
..S ZTRTN="DQ^ALPBPWRD"
|
||||
..S ZTDESC="PSB INPT PHARM ORDERS FOR WARD "_ALPBWARD
|
||||
..S ZTSAVE("ALPBDAYS")=""
|
||||
..S ZTSAVE("ALPBWARD")=""
|
||||
..S ZTSAVE("ALPBMLOG")=""
|
||||
..S ZTSAVE("ALPBOTYP")=""
|
||||
..S ZTSAVE("ALPBSORT")=""
|
||||
..S ZTIO=ION
|
||||
..D ^%ZTLOAD
|
||||
..D HOME^%ZIS
|
||||
..W !,$S($G(ZTSK):"Task number "_ZTSK_" queued.",1:"ERROR -- NOT QUEUED!")
|
||||
..K IO("Q"),ZTSK
|
||||
.K ALPBDAYS,ALPBMLOG,ALPBOTYP,ALPBWARD
|
||||
K DIRUT,DTOUT,X,Y
|
||||
Q
|
||||
;
|
||||
DQ ; output entry point...
|
||||
K ^TMP($J)
|
||||
;
|
||||
; set report date... SED 11/4/03
|
||||
S ALPBRDAT=$S(ALPBOTYP="C":$$NOW^XLFDT(),1:"")
|
||||
;
|
||||
; loop through ward cross reference in 53.7...
|
||||
S ALPBPTN=""
|
||||
F S ALPBPTN=$O(^ALPB(53.7,"AW",ALPBWARD,ALPBPTN)) Q:ALPBPTN="" D
|
||||
.S ALPBIEN=0
|
||||
.F S ALPBIEN=$O(^ALPB(53.7,"AW",ALPBWARD,ALPBPTN,ALPBIEN)) Q:'ALPBIEN D
|
||||
..D ORDS^ALPBUTL(ALPBIEN,ALPBRDAT,.ALPBORDS)
|
||||
..I +ALPBORDS(0)'>0 K ALPBORDS Q
|
||||
..I $G(ALPBPDAT(0))="" S ALPBPDAT(0)=$G(^ALPB(53.7,ALPBIEN,0))
|
||||
..S ALPBOIEN=0
|
||||
..F S ALPBOIEN=$O(ALPBORDS(ALPBOIEN)) Q:'ALPBOIEN D
|
||||
...S ALPBDATA=$G(^ALPB(53.7,ALPBIEN,2,ALPBOIEN,1))
|
||||
...S ALPBOCT=$P($G(^ALPB(53.7,ALPBIEN,2,ALPBOIEN,3)),U,1)
|
||||
...S:$P($G(^ALPB(53.7,ALPBIEN,2,ALPBOIEN,4)),U,3)["PRN" ALPBOCT=ALPBOCT_"P"
|
||||
...; if report is for "C"urrent, check stop date and quit if
|
||||
...; stop date is less than report date...
|
||||
...I ALPBOTYP="C"&($P(ALPBDATA,U,2)<ALPBRDAT) K ALPBDATA Q
|
||||
...S ALPBORDN=ALPBORDS(ALPBOIEN)
|
||||
...S ALPBOST=$$STAT2^ALPBUTL1(ALPBORDS(ALPBOIEN,2))
|
||||
...I '$D(^TMP($J,ALPBPTN)) S ^TMP($J,ALPBPTN)=ALPBIEN
|
||||
...S ^TMP($J,ALPBPTN,ALPBOCT,ALPBOST,ALPBORDN)=ALPBOIEN
|
||||
...K ALPBDATA,ALPBORDN,ALPBOST
|
||||
..K ALPBOIEN,ALPBORDS,ALPBPDAT
|
||||
.K ALPBIEN
|
||||
K ALPBPTN
|
||||
;
|
||||
; Sort by Patient Name or room/bed capability added 6/23/05 KFOX
|
||||
S ALPBPG=0
|
||||
S ALPBPTN=""
|
||||
I ALPBSORT="N" D
|
||||
.F S ALPBPTN=$O(^TMP($J,ALPBPTN)) Q:ALPBPTN="" S ALPBIEN=^TMP($J,ALPBPTN) D PRT
|
||||
;SORT BY ROOM/BED
|
||||
I ALPBSORT="R" D
|
||||
.S ALPBD="",ALPRM=""
|
||||
.F S ALPBPTN=$O(^TMP($J,ALPBPTN)) Q:ALPBPTN="" D
|
||||
..I ALPBPTN="BCBU" S ALPBPTN=$O(^TMP($J,ALPBPTN)) ;SKIP "BCBU" SUBSCRIBE
|
||||
..S ALPBIEN=^TMP($J,ALPBPTN) S ALPRM=$P($G(^ALPB(53.7,ALPBIEN,0)),"^",6),ALPBD=$P($G(^ALPB(53.7,ALPBIEN,0)),"^",7)
|
||||
..I ALPBD="" S ALPB="NONE" I ALPRM="" S ALPB="NONE" ;INCASE NO ROOM AND BED YET
|
||||
..S ^TMP($J,"BCBU",ALPRM,ALPRM,ALPBD,ALPBPTN)=ALPBIEN
|
||||
.S ALPRM1="" F S ALPRM1=$O(^TMP($J,"BCBU",ALPRM1)) Q:ALPRM1="" D
|
||||
..S ALPRM="" F S ALPRM=$O(^TMP($J,"BCBU",ALPRM1,ALPRM)) Q:ALPRM="" D
|
||||
...S ALPBD="" F S ALPBD=$O(^TMP($J,"BCBU",ALPRM1,ALPRM,ALPBD)) Q:ALPBD="" D
|
||||
....S ALPBPTN="" F S ALPBPTN=$O(^TMP($J,"BCBU",ALPRM1,ALPRM,ALPBD,ALPBPTN)) Q:ALPBPTN="" D
|
||||
.....S ALPBIEN=$G(^TMP($J,"BCBU",ALPRM1,ALPRM,ALPBD,ALPBPTN)) D PRT
|
||||
D DONE
|
||||
Q
|
||||
PRT S ALPBPDAT(0)=$G(^ALPB(53.7,ALPBIEN,0))
|
||||
M ALPBPDAT(1)=^ALPB(53.7,ALPBIEN,1)
|
||||
I ALPBPG=0 D PAGE
|
||||
S ALPBOCT=""
|
||||
F S ALPBOCT=$O(^TMP($J,ALPBPTN,ALPBOCT)) Q:ALPBOCT="" D
|
||||
.S ALPBOST=""
|
||||
.F S ALPBOST=$O(^TMP($J,ALPBPTN,ALPBOCT,ALPBOST)) Q:ALPBOST="" D
|
||||
..S ALPBORDN=""
|
||||
..F S ALPBORDN=$O(^TMP($J,ALPBPTN,ALPBOCT,ALPBOST,ALPBORDN)) Q:ALPBORDN="" D
|
||||
...S ALPBOIEN=^TMP($J,ALPBPTN,ALPBOCT,ALPBOST,ALPBORDN)
|
||||
...; get and print this order's data...
|
||||
...M ALPBDATA=^ALPB(53.7,ALPBIEN,2,ALPBOIEN)
|
||||
...D F132^ALPBFRM1(.ALPBDATA,ALPBDAYS,ALPBMLOG,.ALPBFORM,ALPBIEN)
|
||||
...;D F132^ALPBFRM1(.ALPBDATA,ALPBDAYS,.ALPBFORM)
|
||||
...I $Y+ALPBFORM(0)=IOSL!($Y+ALPBFORM(0)>IOSL) D PAGE
|
||||
...F ALPBX=1:1:ALPBFORM(0) W !,ALPBFORM(ALPBX)
|
||||
...K ALPBDATA,ALPBFORM,ALPBOIEN,ALPBX
|
||||
..K ALPBORDN
|
||||
.K ALPBOST
|
||||
K ALPBOCT
|
||||
; print footer at end of this patient's record...
|
||||
I $Y+10>IOSL D PAGE
|
||||
W !!
|
||||
D FOOT^ALPBFRMU
|
||||
;Print a blank page between patient
|
||||
W @IOF
|
||||
S ALPBPG=0
|
||||
K ALPBPDAT
|
||||
Q
|
||||
;K ALPBIEN,ALPBPDAT KILLING ALPBIEN WILL BREAK SORT BY ROOM/BED
|
||||
;
|
||||
DONE ;
|
||||
K ALPBDAYS,ALPBMLOG,ALPBOTYP,ALPBPG,ALPBPTN,ALPBRDAT,ALPBWARD,^TMP($J),ALPRM,ALPRM1,ALPBD,ALPBIEN,ALPBSORT
|
||||
I $D(ZTQUEUED) S ZTREQ="@"
|
||||
Q
|
||||
;
|
||||
PAGE ; print page header for patient...
|
||||
W @IOF
|
||||
S ALPBPG=ALPBPG+1
|
||||
D HDR^ALPBFRMU(.ALPBPDAT,ALPBPG,.ALPBHDR)
|
||||
F ALPBX=1:1:ALPBHDR(0) W !,ALPBHDR(ALPBX)
|
||||
K ALPBHDR,ALPBX
|
||||
Q
|
||||
|
|
|
|||
|
|
@ -1,208 +1,207 @@
|
|||
ALPBUTL1 ;OIFO-DALLAS MW,SED,KC-BCBU BACKUP REPORT FUNCTIONS AND UTILITIES ;01/01/03
|
||||
;;3.0;BAR CODE MED ADMIN;**8,37**;Mar 2004;Build 10
|
||||
;;Per VHA Directive 2004-038, this routine should not be modified.
|
||||
;
|
||||
; Reference/IA
|
||||
; INP^VADPT/10061
|
||||
; DIC(42/10039
|
||||
; DIC(42/2440
|
||||
;
|
||||
ERRBLD(SEG,MSG,ERR) ; build an error array for non-FileMan-related errors...
|
||||
; SEG = HL7 segment name
|
||||
; MSG = a message that will be used in the error text portion of the array (optional -- if not passed, the
|
||||
; default will be used)
|
||||
; ERR = array passed by reference in which error will be returned
|
||||
; note: code 999 is a code indicating a non-FileMan error for filing the error message in file 53.71
|
||||
S ERR("DIERR")=1
|
||||
S ERR("DIERR",1)=999
|
||||
S ERR("DIERR",1,"TEXT",1)=$S($G(MSG)'="":MSG,1:"Invalid parameter passed to "_SEG_" module in routine ALPBHL1U")
|
||||
Q
|
||||
;
|
||||
ERRLOG(IEN,OIEN,MSGREC,SEGNAME,SEGDATA,ERRTEXT) ; log filing errors...
|
||||
; this module logs error data in the BCMA BACKUP PARAMETERS file (53.71). These
|
||||
; errors usually occur as the result of missing or bad data passed to one of the
|
||||
; File Manager DBS calls used by this package.
|
||||
;
|
||||
; IEN = the patient's record number in file 53.7
|
||||
; OIEN = the order number's sub-file record number in file 53.7
|
||||
; MSGREC = the HL7 message's record number in file 772
|
||||
; SEGNAME = the HL7 segment associated with the error (optional)
|
||||
; SEGDATA = the HL7 segment's data (optional)
|
||||
; ERRTEXT = an array passed by reference which contains the error
|
||||
; code (numeric) and the error text to be filed. It is
|
||||
; expected that this is usually the error array returned
|
||||
; from a FileMan DBS call, so the format is specific:
|
||||
;
|
||||
; ERRTEXT("DIERR",n)=error code (numeric)
|
||||
; ERRTEXT("DIERR",n,"TEXT",1)=first line of error text
|
||||
; ERRTEXT("DIERR",n,"TEXT",2)=second line of error text
|
||||
; ERRTEXT("DIERR",n,"TEXT",n)=last line of error text
|
||||
;
|
||||
; However, any error message can be passed to this module
|
||||
; as long as the above format is used.
|
||||
N ALPBCODE,ALPBFERR,ALPBFILE,ALPBLOGD,ALPBN1,ALPBN2,ALPBPIEN,ALPBTEXT,ALPBX
|
||||
S ALPBLOGD=$$NOW^XLFDT()
|
||||
S ALPBPIEN=+$O(^ALPB(53.71,0))
|
||||
I ALPBPIEN=0 D
|
||||
.S X="ONE"
|
||||
.S DIC="^ALPB(53.71,"
|
||||
.S DIC(0)="LZ"
|
||||
.S DIC("DR")="1///^S X=3"
|
||||
.S DINUM=1
|
||||
.S DLAYGO=53.71
|
||||
.D FILE^DICN K DIC
|
||||
.S ALPBPIEN=+Y
|
||||
I ALPBPIEN'>0 Q
|
||||
S ALPBN1=+$O(^ALPB(53.71,ALPBPIEN,1," "),-1)+1
|
||||
S ALPBFILE(53.713,"+"_ALPBN1_","_ALPBPIEN_",",.01)=ALPBLOGD
|
||||
S ALPBFILE(53.713,"+"_ALPBN1_","_ALPBPIEN_",",1)=+$G(IEN)
|
||||
S ALPBFILE(53.713,"+"_ALPBN1_","_ALPBPIEN_",",2)=+$G(OIEN)
|
||||
S ALPBFILE(53.713,"+"_ALPBN1_","_ALPBPIEN_",",3)=+$G(MSGREC)
|
||||
S ALPBFILE(53.713,"+"_ALPBN1_","_ALPBPIEN_",",3.1)=$G(SEGNAME)
|
||||
S ALPBFILE(53.713,"+"_ALPBN1_","_ALPBPIEN_",",3.2)=$G(SEGDATA)
|
||||
D UPDATE^DIE("","ALPBFILE","ALPBN1","ALPBFERR")
|
||||
K ALPBFERR,ALPBFILE
|
||||
S ALPBX=0
|
||||
F S ALPBX=$O(ERRTEXT("DIERR",ALPBX)) Q:'ALPBX D
|
||||
.S ALPBCODE=ERRTEXT("DIERR",ALPBX)
|
||||
.; file the error code...
|
||||
.S ALPBN2=+$O(^ALPB(53.71,ALPBPIEN,1,ALPBN1,2," "),-1)+1
|
||||
.S ALPBFILE(53.7135,"+"_ALPBN2_","_ALPBN1_","_ALPBPIEN_",",.01)=ALPBCODE
|
||||
.D UPDATE^DIE("","ALPBFILE","ALPBN2","ALPBFERR")
|
||||
.K ALPBFERR,ALPBFILE
|
||||
.; file the error text...
|
||||
.M ALPBTEXT=ERRTEXT("DIERR",ALPBX,"TEXT")
|
||||
.D WP^DIE(53.7135,ALPBN2_","_ALPBN1_","_ALPBPIEN_",",1,"","ALPBTEXT","ALPBFERR")
|
||||
.;S ALPBFILE(53.7135,"+"_ALPBN2_","_ALPBN1_","_ALPBPIEN_",",1)=ALPBTEXT
|
||||
.;D UPDATE^DIE("","ALPBFILE","ALPBN2","ALPBFERR")
|
||||
.K ALPBCODE,ALPBFERR,ALPBFILE,ALPBN2,ALPBTEXT
|
||||
Q
|
||||
;
|
||||
CLEAN(IEN) ; check error log records to see if the patients' whose records
|
||||
; are noted still exist in file 53.7. if not, delete the error log
|
||||
; record(s) in file 53.71...
|
||||
; IEN = patient record number in file 53.7
|
||||
; Note: this function is also called from DELPT^ALPBUTL when a patient's
|
||||
; record is deleted (as a result of a discharge action) from 53.7.
|
||||
;
|
||||
N ALPBX,ALPBY,DA,DIK,X,Y
|
||||
; patient still has record in 53.7? if so, quit...
|
||||
I $G(^ALPB(53.7,IEN,0))'="" Q
|
||||
S ALPBX=0
|
||||
F S ALPBX=$O(^ALPB(53.71,"C",IEN,ALPBX)) Q:'ALPBX D
|
||||
.S ALPBY=0
|
||||
.F S ALPBY=$O(^ALPB(53.71,"C",IEN,ALPBX,ALPBY)) Q:'ALPBY D
|
||||
..S DA=ALPBY
|
||||
..S DA(1)=ALPBX
|
||||
..S DIK="^ALPB(53.71,"_DA(1)_",1,"
|
||||
..D ^DIK
|
||||
..K DA,DIK
|
||||
.K ALPBY
|
||||
K ALPBX
|
||||
Q
|
||||
;
|
||||
DELERR(ERRIEN) ; delete an error log entry from file 53.71...
|
||||
; ERRIEN = error log entry's internal record number
|
||||
N ALPBPARM,DA,DIK,X,Y
|
||||
S ALPBPARM=+$O(^ALPB(53.71,0))
|
||||
I ALPBPARM'>0 Q
|
||||
S DA=ERRIEN
|
||||
S DA(1)=ALPBPARM
|
||||
S DIK="^ALPB(53.71,"_DA(1)_",1,"
|
||||
D ^DIK
|
||||
Q
|
||||
;
|
||||
PTLIST(LTYPE,RESULTS) ; get list of patients in file 53.7...
|
||||
; LTYPE = passed = "ALL" to list all patients or
|
||||
; = <wardname> to list patients on a selected ward
|
||||
; RESULTS = an array passed by reference in which data will be returned
|
||||
N ALPBDATA,ALPBIEN,ALPBPTN,ALPBX
|
||||
I $G(LTYPE)="" S LTYPE="ALL"
|
||||
S ALPBX=0
|
||||
I LTYPE="ALL" D
|
||||
.S ALPBPTN=""
|
||||
.F S ALPBPTN=$O(^ALPB(53.7,"B",ALPBPTN)) Q:ALPBPTN="" D
|
||||
..S ALPBIEN=0
|
||||
..F S ALPBIEN=$O(^ALPB(53.7,"B",ALPBPTN,ALPBIEN)) Q:'ALPBIEN D
|
||||
...S ALPBDATA=$G(^ALPB(53.7,ALPBIEN,0))
|
||||
...I ALPBDATA="" K ALPBDATA Q
|
||||
...S ALPBX=ALPBX+1
|
||||
...S RESULTS(ALPBX)=ALPBPTN_"^"_$P(ALPBDATA,"^",2)_"^"_$P(ALPBDATA,"^",5)_"^"_$P(ALPBDATA,"^",6)_"^"_$P(ALPBDATA,"^",7)
|
||||
...K ALPBDATA
|
||||
..K ALPBIEN
|
||||
.K ALPBPTN
|
||||
I LTYPE'="ALL" D
|
||||
.S ALPBPTN=""
|
||||
.F S ALPBPTN=$O(^ALPB(53.7,"AW",LTYPE,ALPBPTN)) Q:ALPBPTN="" D
|
||||
..S ALPBIEN=0
|
||||
..F S ALPBIEN=$O(^ALPB(53.7,"AW",LTYPE,ALPBPTN,ALPBIEN)) Q:'ALPBIEN D
|
||||
...S ALPBDATA=$G(^ALPB(53.7,ALPBIEN,0))
|
||||
...I ALPBDATA="" K ALPBDATA Q
|
||||
...S ALPBX=ALPBX+1
|
||||
...S RESULTS(ALPBX)=ALPBPTN_"^"_$P(ALPBDATA,"^",2)_"^"_$P(ALPBDATA,"^",5)_"^"_$P(ALPBDATA,"^",6)_"^"_$P(ALPBDATA,"^",7)
|
||||
...K ALPBDATA
|
||||
..K ALPBIEN
|
||||
.K ALPBPTN
|
||||
Q
|
||||
;
|
||||
STAT(ST) ;This will return the value of a status code for pharmacy
|
||||
I $G(ST)="" Q ""
|
||||
I $L($T(@ST)) G @ST
|
||||
Q ""
|
||||
IP Q "pending"
|
||||
CM Q "finished/verified by pharmacist(active)"
|
||||
DC Q "discontinued"
|
||||
RP Q "replaced"
|
||||
HD Q "on hold"
|
||||
ZE Q "expired"
|
||||
ZS Q "suspended(active)"
|
||||
ZU Q "un-suspended(active)"
|
||||
ZX Q "unreleased"
|
||||
ZZ Q "renewed"
|
||||
;
|
||||
STAT2(CODE) ; convert order status code for output...
|
||||
; this function is used primarily by the workstation software
|
||||
; CODE = an order status code
|
||||
; returns printable status code
|
||||
I $G(CODE)="" Q "Unknown"
|
||||
I CODE="IP"!(CODE="ZX") Q "Pending"
|
||||
I CODE="CM"!(CODE="ZU")!(CODE="ZZ") Q "Active"
|
||||
I CODE="HD"!(CODE="ZS") Q "Hold"
|
||||
I CODE="DC"!(CODE="RP")!(CODE="ZE") Q "Expired"
|
||||
Q "Unknown"
|
||||
;
|
||||
DIV(DFN,ALPBMDT) ;get the Division for a patient
|
||||
I +$G(DFN)'>0 Q ""
|
||||
N ALPBDIV,ALPWRD,VAIN,VAINDT
|
||||
S:+$G(ALPBMDT)>0 VAINDT=$P(ALPBMDT,".",1)
|
||||
K ALPBMDT
|
||||
D INP^VADPT
|
||||
S ALPWRD=$P($G(VAIN(4)),U,1)
|
||||
Q:+ALPWRD'>0 ""
|
||||
;Check to see if ward is a DOMICILIARY
|
||||
I $P($G(^DIC(42,ALPWRD,0)),U,3)="D",+$$GET^XPAR("PKG.BAR CODE MED ADMIN","PSB BKUP DOM FILTER",1,"Q")>0 Q "DOM"
|
||||
S ALPBDIV=$P($G(^DIC(42,ALPWRD,0)),U,11)
|
||||
Q:+ALPBDIV'>0 ""
|
||||
Q ALPBDIV
|
||||
;
|
||||
CNV(A,B,X) ;CONVERT A STRING
|
||||
;This API will take a HL7 segment and convert characters
|
||||
;defined in the input
|
||||
;Example:
|
||||
;Single encoding characters can be converted such as ^ to ~
|
||||
;or multiple encoding characters can be converted such as
|
||||
; |~^@/ to ^~|/@
|
||||
;A is the string of HL7 encoding characters to be converted
|
||||
;B is the string of HL7 encoding characters to be converted to
|
||||
;X is te message string to be converted
|
||||
I A=""!B=""!X="" Q ""
|
||||
F I=1:1:$L(A) S A(I)=$E(A,I,I),A(I,1)=""
|
||||
F I=1:1:$L(B) S B(I)=$E(B,I,I)
|
||||
S J=0
|
||||
F S J=$O(A(J)) Q:+J'>0 D
|
||||
. F I=1:1:$L(X) S:$E(X,I,I)=A(J) A(J,1)=A(J,1)_I_U
|
||||
S J=0
|
||||
F S J=$O(A(J)) Q:+J'>0 D
|
||||
. Q:'$D(A(J,1))!'$D(B(J))
|
||||
. F I=1:1:$L(A(J,1),U) S C=$P(A(J,1),U,I) S:+C>0 $E(X,C,C)=B(J)
|
||||
Q X
|
||||
ALPBUTL1 ;OIFO-DALLAS MW,SED,KC-BCBU BACKUP REPORT FUNCTIONS AND UTILITIES ;01/01/03
|
||||
;;3.0;BAR CODE MED ADMIN;**8**;Mar 2004
|
||||
;
|
||||
; Reference/IA
|
||||
; INP^VADPT/10061
|
||||
; DIC(42/10039
|
||||
; DIC(42/2440
|
||||
;
|
||||
ERRBLD(SEG,MSG,ERR) ; build an error array for non-FileMan-related errors...
|
||||
; SEG = HL7 segment name
|
||||
; MSG = a message that will be used in the error text portion of the array (optional -- if not passed, the
|
||||
; default will be used)
|
||||
; ERR = array passed by reference in which error will be returned
|
||||
; note: code 999 is a code indicating a non-FileMan error for filing the error message in file 53.71
|
||||
S ERR("DIERR")=1
|
||||
S ERR("DIERR",1)=999
|
||||
S ERR("DIERR",1,"TEXT",1)=$S($G(MSG)'="":MSG,1:"Invalid parameter passed to "_SEG_" module in routine ALPBHL1U")
|
||||
Q
|
||||
;
|
||||
ERRLOG(IEN,OIEN,MSGREC,SEGNAME,SEGDATA,ERRTEXT) ; log filing errors...
|
||||
; this module logs error data in the BCMA BACKUP PARAMETERS file (53.71). These
|
||||
; errors usually occur as the result of missing or bad data passed to one of the
|
||||
; File Manager DBS calls used by this package.
|
||||
;
|
||||
; IEN = the patient's record number in file 53.7
|
||||
; OIEN = the order number's sub-file record number in file 53.7
|
||||
; MSGREC = the HL7 message's record number in file 772
|
||||
; SEGNAME = the HL7 segment associated with the error (optional)
|
||||
; SEGDATA = the HL7 segment's data (optional)
|
||||
; ERRTEXT = an array passed by reference which contains the error
|
||||
; code (numeric) and the error text to be filed. It is
|
||||
; expected that this is usually the error array returned
|
||||
; from a FileMan DBS call, so the format is specific:
|
||||
;
|
||||
; ERRTEXT("DIERR",n)=error code (numeric)
|
||||
; ERRTEXT("DIERR",n,"TEXT",1)=first line of error text
|
||||
; ERRTEXT("DIERR",n,"TEXT",2)=second line of error text
|
||||
; ERRTEXT("DIERR",n,"TEXT",n)=last line of error text
|
||||
;
|
||||
; However, any error message can be passed to this module
|
||||
; as long as the above format is used.
|
||||
N ALPBCODE,ALPBFERR,ALPBFILE,ALPBLOGD,ALPBN1,ALPBN2,ALPBPIEN,ALPBTEXT,ALPBX
|
||||
S ALPBLOGD=$$NOW^XLFDT()
|
||||
S ALPBPIEN=+$O(^ALPB(53.71,0))
|
||||
I ALPBPIEN=0 D
|
||||
.S X="ONE"
|
||||
.S DIC="^ALPB(53.71,"
|
||||
.S DIC(0)="LZ"
|
||||
.S DIC("DR")="1///^S X=3"
|
||||
.S DINUM=1
|
||||
.S DLAYGO=53.71
|
||||
.D FILE^DICN K DIC
|
||||
.S ALPBPIEN=+Y
|
||||
I ALPBPIEN'>0 Q
|
||||
S ALPBN1=+$O(^ALPB(53.71,ALPBPIEN,1," "),-1)+1
|
||||
S ALPBFILE(53.713,"+"_ALPBN1_","_ALPBPIEN_",",.01)=ALPBLOGD
|
||||
S ALPBFILE(53.713,"+"_ALPBN1_","_ALPBPIEN_",",1)=+$G(IEN)
|
||||
S ALPBFILE(53.713,"+"_ALPBN1_","_ALPBPIEN_",",2)=+$G(OIEN)
|
||||
S ALPBFILE(53.713,"+"_ALPBN1_","_ALPBPIEN_",",3)=+$G(MSGREC)
|
||||
S ALPBFILE(53.713,"+"_ALPBN1_","_ALPBPIEN_",",3.1)=$G(SEGNAME)
|
||||
S ALPBFILE(53.713,"+"_ALPBN1_","_ALPBPIEN_",",3.2)=$G(SEGDATA)
|
||||
D UPDATE^DIE("","ALPBFILE","ALPBN1","ALPBFERR")
|
||||
K ALPBFERR,ALPBFILE
|
||||
S ALPBX=0
|
||||
F S ALPBX=$O(ERRTEXT("DIERR",ALPBX)) Q:'ALPBX D
|
||||
.S ALPBCODE=ERRTEXT("DIERR",ALPBX)
|
||||
.; file the error code...
|
||||
.S ALPBN2=+$O(^ALPB(53.71,ALPBPIEN,1,ALPBN1,2," "),-1)+1
|
||||
.S ALPBFILE(53.7135,"+"_ALPBN2_","_ALPBN1_","_ALPBPIEN_",",.01)=ALPBCODE
|
||||
.D UPDATE^DIE("","ALPBFILE","ALPBN2","ALPBFERR")
|
||||
.K ALPBFERR,ALPBFILE
|
||||
.; file the error text...
|
||||
.M ALPBTEXT=ERRTEXT("DIERR",ALPBX,"TEXT")
|
||||
.D WP^DIE(53.7135,ALPBN2_","_ALPBN1_","_ALPBPIEN_",",1,"","ALPBTEXT","ALPBFERR")
|
||||
.;S ALPBFILE(53.7135,"+"_ALPBN2_","_ALPBN1_","_ALPBPIEN_",",1)=ALPBTEXT
|
||||
.;D UPDATE^DIE("","ALPBFILE","ALPBN2","ALPBFERR")
|
||||
.K ALPBCODE,ALPBFERR,ALPBFILE,ALPBN2,ALPBTEXT
|
||||
Q
|
||||
;
|
||||
CLEAN(IEN) ; check error log records to see if the patients' whose records
|
||||
; are noted still exist in file 53.7. if not, delete the error log
|
||||
; record(s) in file 53.71...
|
||||
; IEN = patient record number in file 53.7
|
||||
; Note: this function is also called from DELPT^ALPBUTL when a patient's
|
||||
; record is deleted (as a result of a discharge action) from 53.7.
|
||||
;
|
||||
N ALPBX,ALPBY,DA,DIK,X,Y
|
||||
; patient still has record in 53.7? if so, quit...
|
||||
I $G(^ALPB(53.7,IEN,0))'="" Q
|
||||
S ALPBX=0
|
||||
F S ALPBX=$O(^ALPB(53.71,"C",IEN,ALPBX)) Q:'ALPBX D
|
||||
.S ALPBY=0
|
||||
.F S ALPBY=$O(^ALPB(53.71,"C",IEN,ALPBX,ALPBY)) Q:'ALPBY D
|
||||
..S DA=ALPBY
|
||||
..S DA(1)=ALPBX
|
||||
..S DIK="^ALPB(53.71,"_DA(1)_",1,"
|
||||
..D ^DIK
|
||||
..K DA,DIK
|
||||
.K ALPBY
|
||||
K ALPBX
|
||||
Q
|
||||
;
|
||||
DELERR(ERRIEN) ; delete an error log entry from file 53.71...
|
||||
; ERRIEN = error log entry's internal record number
|
||||
N ALPBPARM,DA,DIK,X,Y
|
||||
S ALPBPARM=+$O(^ALPB(53.71,0))
|
||||
I ALPBPARM'>0 Q
|
||||
S DA=ERRIEN
|
||||
S DA(1)=ALPBPARM
|
||||
S DIK="^ALPB(53.71,"_DA(1)_",1,"
|
||||
D ^DIK
|
||||
Q
|
||||
;
|
||||
PTLIST(LTYPE,RESULTS) ; get list of patients in file 53.7...
|
||||
; LTYPE = passed = "ALL" to list all patients or
|
||||
; = <wardname> to list patients on a selected ward
|
||||
; RESULTS = an array passed by reference in which data will be returned
|
||||
N ALPBDATA,ALPBIEN,ALPBPTN,ALPBX
|
||||
I $G(LTYPE)="" S LTYPE="ALL"
|
||||
S ALPBX=0
|
||||
I LTYPE="ALL" D
|
||||
.S ALPBPTN=""
|
||||
.F S ALPBPTN=$O(^ALPB(53.7,"B",ALPBPTN)) Q:ALPBPTN="" D
|
||||
..S ALPBIEN=0
|
||||
..F S ALPBIEN=$O(^ALPB(53.7,"B",ALPBPTN,ALPBIEN)) Q:'ALPBIEN D
|
||||
...S ALPBDATA=$G(^ALPB(53.7,ALPBIEN,0))
|
||||
...I ALPBDATA="" K ALPBDATA Q
|
||||
...S ALPBX=ALPBX+1
|
||||
...S RESULTS(ALPBX)=ALPBPTN_"^"_$P(ALPBDATA,"^",2)_"^"_$P(ALPBDATA,"^",5)_"^"_$P(ALPBDATA,"^",6)_"^"_$P(ALPBDATA,"^",7)
|
||||
...K ALPBDATA
|
||||
..K ALPBIEN
|
||||
.K ALPBPTN
|
||||
I LTYPE'="ALL" D
|
||||
.S ALPBPTN=""
|
||||
.F S ALPBPTN=$O(^ALPB(53.7,"AW",LTYPE,ALPBPTN)) Q:ALPBPTN="" D
|
||||
..S ALPBIEN=0
|
||||
..F S ALPBIEN=$O(^ALPB(53.7,"AW",LTYPE,ALPBPTN,ALPBIEN)) Q:'ALPBIEN D
|
||||
...S ALPBDATA=$G(^ALPB(53.7,ALPBIEN,0))
|
||||
...I ALPBDATA="" K ALPBDATA Q
|
||||
...S ALPBX=ALPBX+1
|
||||
...S RESULTS(ALPBX)=ALPBPTN_"^"_$P(ALPBDATA,"^",2)_"^"_$P(ALPBDATA,"^",5)_"^"_$P(ALPBDATA,"^",6)_"^"_$P(ALPBDATA,"^",7)
|
||||
...K ALPBDATA
|
||||
..K ALPBIEN
|
||||
.K ALPBPTN
|
||||
Q
|
||||
;
|
||||
STAT(ST) ;This will return the value of a status code for pharmacy
|
||||
I $G(ST)="" Q ""
|
||||
I $L($T(@ST)) G @ST
|
||||
Q ""
|
||||
IP Q "pending"
|
||||
CM Q "finished/verified by pharmacist(active)"
|
||||
DC Q "discontinued"
|
||||
RP Q "replaced"
|
||||
HD Q "on hold"
|
||||
ZE Q "expired"
|
||||
ZS Q "suspended(active)"
|
||||
ZU Q "un-suspended(active)"
|
||||
ZX Q "unreleased"
|
||||
ZZ Q "renewed"
|
||||
;
|
||||
STAT2(CODE) ; convert order status code for output...
|
||||
; this function is used primarily by the workstation software
|
||||
; CODE = an order status code
|
||||
; returns printable status code
|
||||
I $G(CODE)="" Q "Unknown"
|
||||
I CODE="IP"!(CODE="ZX") Q "Pending"
|
||||
I CODE="CM"!(CODE="ZU")!(CODE="ZZ") Q "Active"
|
||||
I CODE="HD"!(CODE="ZS") Q "Hold"
|
||||
I CODE="DC"!(CODE="RP")!(CODE="ZE") Q "Expired"
|
||||
Q "Unknown"
|
||||
;
|
||||
DIV(DFN,ALPBMDT) ;get the Division for a patient
|
||||
I +$G(DFN)'>0 Q ""
|
||||
N ALPBDIV,ALPWRD,VAIN,VAINDT
|
||||
S:+$G(ALPBMDT)>0 VAINDT=$P(ALPBMDT,".",1)
|
||||
K ALPBMDT
|
||||
D INP^VADPT
|
||||
S ALPWRD=$P($G(VAIN(4)),U,1)
|
||||
Q:+ALPWRD'>0 ""
|
||||
;Check to see if ward is a DOMICILIARY
|
||||
I $P($G(^DIC(42,ALPWRD,0)),U,3)="D" Q "DOM"
|
||||
S ALPBDIV=$P($G(^DIC(42,ALPWRD,0)),U,11)
|
||||
Q:+ALPBDIV'>0 ""
|
||||
Q ALPBDIV
|
||||
;
|
||||
CNV(A,B,X) ;CONVERT A STRING
|
||||
;This API will take a HL7 segment and convert characters
|
||||
;defined in the input
|
||||
;Example:
|
||||
;Single encoding characters can be converted such as ^ to ~
|
||||
;or multiple encoding characters can be converted such as
|
||||
; |~^@/ to ^~|/@
|
||||
;A is the string of HL7 encoding characters to be converted
|
||||
;B is the string of HL7 encoding characters to be converted to
|
||||
;X is te message string to be converted
|
||||
I A=""!B=""!X="" Q ""
|
||||
F I=1:1:$L(A) S A(I)=$E(A,I,I),A(I,1)=""
|
||||
F I=1:1:$L(B) S B(I)=$E(B,I,I)
|
||||
S J=0
|
||||
F S J=$O(A(J)) Q:+J'>0 D
|
||||
. F I=1:1:$L(X) S:$E(X,I,I)=A(J) A(J,1)=A(J,1)_I_U
|
||||
S J=0
|
||||
F S J=$O(A(J)) Q:+J'>0 D
|
||||
. Q:'$D(A(J,1))!'$D(B(J))
|
||||
. F I=1:1:$L(A(J,1),U) S C=$P(A(J,1),U,I) S:+C>0 $E(X,C,C)=B(J)
|
||||
Q X
|
||||
|
|
|
|||
|
|
@ -1,194 +1,194 @@
|
|||
PSBO ;BIRMINGHAM/EFC-BCMA OUTPUTS ;Mar 2004
|
||||
;;3.0;BAR CODE MED ADMIN;**13,32,2**;Mar 2004;Build 22
|
||||
;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified.
|
||||
; Reference/IA
|
||||
; ^DPT(/10035
|
||||
; WARD^NURSUT5/3052
|
||||
; EN^PSJBCMA/2828
|
||||
; ^ORD(101.24/3429
|
||||
; ^PSDRUG(/221
|
||||
RPC(RESULTS,PSBTYPE,PSBDFN,PSBSTRT,PSBSTOP,PSBINCL,PSBDEV,PSBSORT,PSBOI,PSBWLOC,PSBWSORT,PSBFUTR,PSBORDNM,PSBRCRI,PSBLIST) ;
|
||||
;
|
||||
; RPC: PSB REPORT
|
||||
;
|
||||
; Description:
|
||||
; Used by the client to create individual patient extracts of
|
||||
; CHUI report options to display on the client.
|
||||
;
|
||||
S RESULTS=$NAME(^TMP("PSBO",$J))
|
||||
N PSBIENS,PSBRPT,PSBFDA,DIC,PSBANS
|
||||
K ^TMP("PSBO",$J) S ^TMP("PSBO",$J,1)="-1^"
|
||||
S DFN=PSBDFN
|
||||
D NEW^PSBO1(.PSBRPT,PSBTYPE)
|
||||
I +PSBRPT(0)<1 S ^TMP("PSBO",$J,1)="-1^Error: "_$P(PSBRPT(0),U,2) Q
|
||||
S PSBIENS=+PSBRPT(0)_","
|
||||
S PSBSTRT(0)=$E($P(PSBSTRT,".",2)_"0000",1,4),PSBSTRT=PSBSTRT\1
|
||||
S PSBSTOP(0)=$E($P(PSBSTOP,".",2)_"0000",1,4),PSBSTOP=PSBSTOP\1
|
||||
D:$G(PSBDEV)]""
|
||||
.D NOW^%DTC
|
||||
.I $P(PSBDEV,U,2)="" D VAL^DIE(53.69,PSBIENS,.06,"F",PSBDEV,"PSBRET","PSBFDA")
|
||||
.I $P(PSBDEV,U,2)'="" D VAL^DIE(53.69,PSBIENS,.06,"F","`"_$P(PSBDEV,U,2),"PSBRET","PSBFDA")
|
||||
.D VAL^DIE(53.69,PSBIENS,.07,"F",$S($P(PSBRCRI,U)="QD":$P(PSBRCRI,U,2),1:%),"PSBRET","PSBFDA")
|
||||
D:$G(PSBOI)]"" VAL^DIE(53.69,PSBIENS,.09,"F",PSBOI,"PSBRET","PSBFDA")
|
||||
S:($G(PSBSORT)']"")&(PSBTYPE'="XA") PSBSORT="P" D VAL^DIE(53.69,PSBIENS,.11,"F",PSBSORT,"PSBRET","PSBFDA")
|
||||
D VAL^DIE(53.69,PSBIENS,.12,"F","`"_PSBDFN,"PSBRET","PSBFDA")
|
||||
I $G(PSBWLOC)]"" S PSBFDA(53.69,PSBIENS,.13)=PSBWLOC
|
||||
D:$G(PSBWSORT)]"" VAL^DIE(53.69,PSBIENS,.15,"F",PSBWSORT,"PSBRET","PSBFDA")
|
||||
D VAL^DIE(53.69,PSBIENS,.16,"F",PSBSTRT,"PSBRET","PSBFDA")
|
||||
D VAL^DIE(53.69,PSBIENS,.17,"F",PSBSTRT(0),"PSBRET","PSBFDA")
|
||||
D VAL^DIE(53.69,PSBIENS,.18,"F",PSBSTOP,"PSBRET","PSBFDA")
|
||||
D VAL^DIE(53.69,PSBIENS,.19,"F",PSBSTOP(0),"PSBRET","PSBFDA")
|
||||
D:$G(PSBINCL)]""
|
||||
.D VAL^DIE(53.69,PSBIENS,.21,"F",+$P(PSBINCL,"^",1),"PSBRET","PSBFDA")
|
||||
.D VAL^DIE(53.69,PSBIENS,.22,"F",+$P(PSBINCL,"^",2),"PSBRET","PSBFDA")
|
||||
.D VAL^DIE(53.69,PSBIENS,.23,"F",+$P(PSBINCL,"^",3),"PSBRET","PSBFDA")
|
||||
.D VAL^DIE(53.69,PSBIENS,.24,"F",+$P(PSBINCL,"^",4),"PSBRET","PSBFDA")
|
||||
.D VAL^DIE(53.69,PSBIENS,.28,"F",+$P(PSBINCL,"^",5),"PSBRET","PSBFDA")
|
||||
.D VAL^DIE(53.69,PSBIENS,.29,"F",+$P(PSBINCL,"^",6),"PSBRET","PSBFDA")
|
||||
D:$G(PSBFUTR)]""
|
||||
.D VAL^DIE(53.69,PSBIENS,.25,"F",+$P(PSBFUTR,"^",1),"PSBRET","PSBFDA")
|
||||
.D VAL^DIE(53.69,PSBIENS,.26,"F",+$P(PSBFUTR,"^",2),"PSBRET","PSBFDA")
|
||||
.D VAL^DIE(53.69,PSBIENS,.27,"F",+$P(PSBFUTR,"^",3),"PSBRET","PSBFDA")
|
||||
.D VAL^DIE(53.69,PSBIENS,.41,"F",+$P(PSBFUTR,"^",4),"PSBRET","PSBFDA")
|
||||
.D VAL^DIE(53.69,PSBIENS,.61,"F",$TR(PSBFUTR,"^ ","~"),"PSBRET","PSBFDA")
|
||||
D FILE^DIE("","PSBFDA")
|
||||
I $G(PSBLIST(0),"")]"" D LIST^PSBO1(.PSBLIST)
|
||||
I $G(PSBDEV)]"" D PRINT^PSBO1 S RESULTS=$NAME(^TMP("PSBO",$J)) Q
|
||||
D HFSOPEN^PSBUTL("RPC") I POP S ^TMP("PSBO",$J,1)="ERROR: UNABLE TO ACCESS HFS DIRECTORY "_$$GET^XPAR("DIV","PSB HFS SCRATCH"),^TMP("PSBO",$J,2)="PLEASE CHECK DIRECTORY WRITE PRIVILEDGES." Q
|
||||
U IO D DQ(+PSBIENS)
|
||||
D HFSCLOSE^PSBUTL("RPC")
|
||||
S RESULTS=$NAME(^TMP("PSBO",$J))
|
||||
D:$G(PSBDEV)]"" PRINT^PSBO1
|
||||
Q
|
||||
;
|
||||
XQ(PSBTYPE) ; Called via Kernel Menus
|
||||
N PSBANS,PSBANS1,PSBRPT,PSBSAVE,DA,DIK,DR,DDSFILE
|
||||
D NEW^PSBO1(.PSBRPT,PSBTYPE)
|
||||
I +PSBRPT(0)<1 W !,"Error: ",$P(PSBRPT(0),U,2) S DIR(0)="E" D ^DIR Q
|
||||
S DA=+PSBRPT(0),DR="[PSBO "_PSBTYPE_"]",DDSFILE=53.69 D ^DDS
|
||||
W @IOF
|
||||
I 'PSBSAVE W !,"Cancelling Request..." S DIK="^PSB(53.69," D ^DIK W "Cancelled!"
|
||||
D:PSBSAVE
|
||||
.;Check Drug to Patient Relationship.
|
||||
.I (PSBTYPE="BL")!(PSBTYPE="BZ") S PSBANS="" D CHECK I PSBANS=0!($D(DIRUT)) W !,"Cancelling Request..." S DIK="^PSB(53.69," D ^DIK W "Cancelled!" Q
|
||||
.;
|
||||
.;Allow "'BROWSER" Device
|
||||
.S IOP=$$GET1^DIQ(53.69,DA_",",.06,"I"),PSBSIO=0 I IOP]"" D
|
||||
..S IOP="`"_IOP,%ZIS="N"
|
||||
..D ^%ZIS
|
||||
..I IO=IO(0) S PSBSIO=1
|
||||
..D HOME^%ZIS K IOP
|
||||
.I $$GET1^DIQ(53.69,DA_",",.06)["BROWSER"!(PSBSIO=1) S IOP=$$GET1^DIQ(53.69,DA_",",.06)_";132" D ^%ZIS U IO D DQ(DA) D ^%ZISC K IOP Q
|
||||
.W @IOF,"Submitting Your Report Request to Taskman..."
|
||||
.S ZTIO=$$GET1^DIQ(53.69,DA_",",.06)
|
||||
.S ZTDTH=$P(^PSB(53.69,DA,0),U,7)
|
||||
.S ZTDESC="BCMA - "_$$GET1^DIQ(53.69,DA_",",.05)
|
||||
.S ZTRTN="DQ^PSBO("_DA_")"
|
||||
.D ^%ZTLOAD
|
||||
.W "Submitted!",!,"Your Task Number Is: ",$G(ZTSK),!
|
||||
K ^TMP("PSBO",$J)
|
||||
Q
|
||||
;
|
||||
DQ(PSBRPT) ; Dequeue report from Taskman
|
||||
N PSBWRD,PSBDFN
|
||||
Q:'$D(^PSB(53.69,PSBRPT,0)) ; No Such Report
|
||||
S $P(^PSB(53.69,PSBRPT,0),U,8)=$G(ZTSK,"RPC")
|
||||
D:$$SETUP @("EN^PSBO"_$P(PSBRPT(0),U,5))
|
||||
K ^TMP("PSBO",$J)
|
||||
S ZTREQ="@"
|
||||
Q
|
||||
;
|
||||
IOM() ; Returns good margin or not
|
||||
Q:IOM'<132 1
|
||||
W !,"**************************************************************"
|
||||
W !,"* SORRY, Your selected DEVICE does not print 132 columns. *"
|
||||
W !,"**************************************************************"
|
||||
W !
|
||||
Q 0
|
||||
;
|
||||
VAL(PSBFLDS) ; Validate that fields in PSBFLDS are filled in
|
||||
N PSB,PSBFLD,PSBMSG,PSBSTOP,PSBST,PSBDAYS S PSBSTRT=""
|
||||
F PSB=1:1 Q:$P(PSBFLDS,";",PSB)="" S PSBFLD=$P(PSBFLDS,";",PSB),PSBFLD(PSBFLD)=$$GET^DDSVAL(53.69,DA,PSBFLD)
|
||||
I $D(PSBFLD(.11)) K:$E(PSBFLD(.11))="P" PSBFLD(.13),PSBFLD(.15) K:$E(PSBFLD(.11))="W" PSBFLD(.12)
|
||||
S PSB="" F S PSB=$O(PSBFLD(PSB)) Q:PSB="" D:PSBFLD(PSB)=""
|
||||
.I '$D(PSBMSG) S PSBMSG(0)="UNABLE TO FILE REQUEST",PSBMSG(1)=" ",PSBMSG(2)="ERROR: MISSING DATA - ALL FIELDS ARE REQUIRED",PSBMSG(3)=" "
|
||||
.D FIELD^DID(53.69,PSB,"","TITLE;LABEL","PSB")
|
||||
.S Z=" Missing Field: "_$S(PSB("TITLE")]"":PSB("TITLE"),1:PSB("LABEL"))
|
||||
.S PSBMSG($O(PSBMSG(""),-1)+1)=Z
|
||||
; Check Times
|
||||
D:$G(PSBFLD(.16))
|
||||
.S PSBSTRT=PSBFLD(.16)+$G(PSBFLD(.17))
|
||||
.D:$P($$GET1^DIQ(53.69,DA_",",.01),U)["MH"
|
||||
..S PSBDAYS=$$GET1^DIQ(101.24,$$FIND1^DIC(101.24,"","X","ORRP BCMA MAH","B")_",",.42) ;check maxdays
|
||||
..S:PSBDAYS="" PSBDAYS=7
|
||||
..S X=PSBSTRT\1 D H^%DTC S PSBST=%H+PSBDAYS ;Determine stop date
|
||||
.S PSBSTOP=$S($G(PSBFLD(.18)):PSBFLD(.18),1:PSBFLD(.16))+$G(PSBFLD(.19))
|
||||
.I PSBSTOP<PSBSTRT S Y=$O(PSBMSG(""),-1)+1,PSBMSG(Y)=" Date: Stop Date/Time is before Start Date/Time"
|
||||
.I $P($$GET1^DIQ(53.69,DA_",",.01),U)["MH" S X=PSBSTOP\1 D H^%DTC I %H>PSBST S Y=$O(PSBMSG(""),-1)+1,PSBMSG(Y)=" The date range cannot exceed "_PSBDAYS_" day(s) as defined in the CPRS 'MAXIMUM DAYS BACK' parameter"
|
||||
Q:'$D(PSBMSG) ; All is well
|
||||
D MSG^DDSUTL(.PSBMSG)
|
||||
S DDSERROR=1
|
||||
Q
|
||||
;
|
||||
SETUP() ; Setup parameters for the report in PSBRPT
|
||||
N PSBWRDL,PSBINDX,PSBWRDA
|
||||
K ^TMP("PSBO",$J)
|
||||
F X=0,.1,.2,.3,.4,1 S PSBRPT(X)=$G(^PSB(53.69,PSBRPT,X))
|
||||
I $D(^PSB(53.69,PSBRPT,2)) M PSBRPT(2)=^PSB(53.69,PSBRPT,2)
|
||||
I $P(PSBRPT(.1),U,1)="P" S PSBDFN=+$P(PSBRPT(.1),U,2) Q:'PSBDFN S ^TMP("PSBO",$J,PSBDFN,0)=$P(^DPT(PSBDFN,0),U)_U_$P(^DPT(PSBDFN,0),U,9),^TMP("PSBO",$J,"B",$P(^DPT(PSBDFN,0),U),PSBDFN)=""
|
||||
D:$P(PSBRPT(.1),U,1)="W"
|
||||
.S PSBWRD=$P(PSBRPT(.1),U,3) Q:'PSBWRD D WARD^NURSUT5("L^"_PSBWRD,.PSBWRDA)
|
||||
.S X="" F S X=$O(PSBWRDA(PSBWRD,2,X)) Q:X="" S PSBWRDL=$P(PSBWRDA(PSBWRD,2,X,.01),U,2) D
|
||||
..F PSBDFN=0:0 S PSBDFN=$O(^DPT("CN",PSBWRDL,PSBDFN)) Q:'PSBDFN D
|
||||
...S ^TMP("PSBO",$J,PSBDFN,0)=$P(^DPT(PSBDFN,0),U)_U_$P(^DPT(PSBDFN,0),U,9)
|
||||
...; Determine Sort or default to Pt Name...
|
||||
...S:$P(PSBRPT(.1),U,5)="P" PSBINDX=$P(^DPT(PSBDFN,0),U)
|
||||
...I $P(PSBRPT(.1),U,5)="B" S PSBINDX=$P($G(^DPT(PSBDFN,.101)),U) S:PSBINDX="" PSBINDX="** NO ROOM BED **"
|
||||
...S:$P(PSBRPT(.1),U,5)="" PSBINDX=$P(^DPT(PSBDFN,0),U)
|
||||
...S:$G(PSBINDX)="" PSBINDX=$P(^DPT(PSBDFN,0),U)
|
||||
...S ^TMP("PSBO",$J,"B",PSBINDX,PSBDFN)=""
|
||||
Q 1
|
||||
;
|
||||
WRAP(X,Y,Z) ; Quick text wrap
|
||||
;
|
||||
; Input Parameters Description:
|
||||
; X: Left Column of display [Optional]
|
||||
; Y: Cols to wrap in [Optional]
|
||||
; Z: Text to wrap [Optional]
|
||||
;
|
||||
N PSB
|
||||
F Q:'$L(Z) D
|
||||
.W:$X>X !
|
||||
.W:$X<X ?X
|
||||
.I $L(Z)<Y W Z S Z="" Q
|
||||
.F PSB=Y:-1:0 Q:$E(Z,PSB)=" "
|
||||
.S:PSB<1 PSB=Y
|
||||
.W $E(Z,1,PSB)
|
||||
.S Z=$E(Z,PSB+1,250)
|
||||
Q ""
|
||||
;
|
||||
CHECK ;Beginning of PSB*1*10
|
||||
K ^TMP("PSJ",$J)
|
||||
N PSBDFN,PSBBAR,PSBDRUG,PSBFLAG,PSBPNM,PSBNDX,PSBX
|
||||
S PSBFLAG="",PSBBAR=$P($P($G(^PSB(53.69,DA,.3)),U,1),"~",2)
|
||||
S PSBDRUG=$$GET1^DIQ(53.69,DA_",",.31)
|
||||
S PSBDFN=$$GET1^DIQ(53.69,DA_",",.12,"I") S:$G(PSBDFN) PSBFLAG=1
|
||||
D EN^PSJBCMA(PSBDFN)
|
||||
F PSBX=0:0 S PSBX=$O(^TMP("PSJ",$J,PSBX)) Q:'PSBX D
|
||||
.K Y,PSBORD,PSBPNM,PSBNDX
|
||||
.M PSBORD=^TMP("PSJ",$J,PSBX)
|
||||
.F PSBNDX=700,850,950 D
|
||||
..F Y=0:0 S Y=$O(PSBORD(PSBNDX,Y)) Q:'Y D
|
||||
...I $P($G(PSBORD(1)),U,7)'="A" Q
|
||||
...S PSBPNM=$P(PSBORD(PSBNDX,Y,0),U,1)
|
||||
...I PSBNDX=700,PSBPNM=PSBBAR S PSBFLAG=0 Q
|
||||
...I PSBNDX=850,$D(^PSDRUG("A526",PSBBAR,PSBPNM)) S PSBFLAG=0 Q
|
||||
...I PSBNDX=950,$D(^PSDRUG("A527",PSBBAR,PSBPNM)) S PSBFLAG=0
|
||||
I PSBFLAG=1 D
|
||||
.W !,"Patient is not currently on medication: ",PSBDRUG
|
||||
.K DIRUT,DIR
|
||||
.S DIR("A")="Do you want to continue"
|
||||
.S DIR(0)="Y"
|
||||
.D ^DIR
|
||||
.S PSBANS=+Y W !
|
||||
;
|
||||
PSBO ;BIRMINGHAM/EFC-BCMA OUTPUTS ;Mar 2004
|
||||
;;3.0;BAR CODE MED ADMIN;**13,32**;Mar 2004;Build 32
|
||||
;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified.
|
||||
; Reference/IA
|
||||
; ^DPT(/10035
|
||||
; WARD^NURSUT5/3052
|
||||
; EN^PSJBCMA/2828
|
||||
; ^ORD(101.24/3429
|
||||
; ^PSDRUG(/221
|
||||
RPC(RESULTS,PSBTYPE,PSBDFN,PSBSTRT,PSBSTOP,PSBINCL,PSBDEV,PSBSORT,PSBOI,PSBWLOC,PSBWSORT,PSBFUTR,PSBORDNM,PSBRCRI,PSBLIST) ;
|
||||
;
|
||||
; RPC: PSB REPORT
|
||||
;
|
||||
; Description:
|
||||
; Used by the client to create individual patient extracts of
|
||||
; CHUI report options to display on the client.
|
||||
;
|
||||
S RESULTS=$NAME(^TMP("PSBO",$J))
|
||||
N PSBIENS,PSBRPT,PSBFDA,DIC,PSBANS
|
||||
K ^TMP("PSBO",$J) S ^TMP("PSBO",$J,1)="-1^"
|
||||
S DFN=PSBDFN
|
||||
D NEW^PSBO1(.PSBRPT,PSBTYPE)
|
||||
I +PSBRPT(0)<1 S ^TMP("PSBO",$J,1)="-1^Error: "_$P(PSBRPT(0),U,2) Q
|
||||
S PSBIENS=+PSBRPT(0)_","
|
||||
S PSBSTRT(0)=$E($P(PSBSTRT,".",2)_"0000",1,4),PSBSTRT=PSBSTRT\1
|
||||
S PSBSTOP(0)=$E($P(PSBSTOP,".",2)_"0000",1,4),PSBSTOP=PSBSTOP\1
|
||||
D:$G(PSBDEV)]""
|
||||
.D NOW^%DTC
|
||||
.I $P(PSBDEV,U,2)="" D VAL^DIE(53.69,PSBIENS,.06,"F",PSBDEV,"PSBRET","PSBFDA")
|
||||
.I $P(PSBDEV,U,2)'="" D VAL^DIE(53.69,PSBIENS,.06,"F","`"_$P(PSBDEV,U,2),"PSBRET","PSBFDA")
|
||||
.D VAL^DIE(53.69,PSBIENS,.07,"F",$S($P(PSBRCRI,U)="QD":$P(PSBRCRI,U,2),1:%),"PSBRET","PSBFDA")
|
||||
D:$G(PSBOI)]"" VAL^DIE(53.69,PSBIENS,.09,"F",PSBOI,"PSBRET","PSBFDA")
|
||||
S:($G(PSBSORT)']"")&(PSBTYPE'="XA") PSBSORT="P" D VAL^DIE(53.69,PSBIENS,.11,"F",PSBSORT,"PSBRET","PSBFDA")
|
||||
D VAL^DIE(53.69,PSBIENS,.12,"F","`"_PSBDFN,"PSBRET","PSBFDA")
|
||||
I $G(PSBWLOC)]"" S PSBFDA(53.69,PSBIENS,.13)=PSBWLOC
|
||||
D:$G(PSBWSORT)]"" VAL^DIE(53.69,PSBIENS,.15,"F",PSBWSORT,"PSBRET","PSBFDA")
|
||||
D VAL^DIE(53.69,PSBIENS,.16,"F",PSBSTRT,"PSBRET","PSBFDA")
|
||||
D VAL^DIE(53.69,PSBIENS,.17,"F",PSBSTRT(0),"PSBRET","PSBFDA")
|
||||
D VAL^DIE(53.69,PSBIENS,.18,"F",PSBSTOP,"PSBRET","PSBFDA")
|
||||
D VAL^DIE(53.69,PSBIENS,.19,"F",PSBSTOP(0),"PSBRET","PSBFDA")
|
||||
D:$G(PSBINCL)]""
|
||||
.D VAL^DIE(53.69,PSBIENS,.21,"F",+$P(PSBINCL,"^",1),"PSBRET","PSBFDA")
|
||||
.D VAL^DIE(53.69,PSBIENS,.22,"F",+$P(PSBINCL,"^",2),"PSBRET","PSBFDA")
|
||||
.D VAL^DIE(53.69,PSBIENS,.23,"F",+$P(PSBINCL,"^",3),"PSBRET","PSBFDA")
|
||||
.D VAL^DIE(53.69,PSBIENS,.24,"F",+$P(PSBINCL,"^",4),"PSBRET","PSBFDA")
|
||||
.D VAL^DIE(53.69,PSBIENS,.28,"F",+$P(PSBINCL,"^",5),"PSBRET","PSBFDA")
|
||||
.D VAL^DIE(53.69,PSBIENS,.29,"F",+$P(PSBINCL,"^",6),"PSBRET","PSBFDA")
|
||||
D:$G(PSBFUTR)]""
|
||||
.D VAL^DIE(53.69,PSBIENS,.25,"F",+$P(PSBFUTR,"^",1),"PSBRET","PSBFDA")
|
||||
.D VAL^DIE(53.69,PSBIENS,.26,"F",+$P(PSBFUTR,"^",2),"PSBRET","PSBFDA")
|
||||
.D VAL^DIE(53.69,PSBIENS,.27,"F",+$P(PSBFUTR,"^",3),"PSBRET","PSBFDA")
|
||||
.D VAL^DIE(53.69,PSBIENS,.41,"F",+$P(PSBFUTR,"^",4),"PSBRET","PSBFDA")
|
||||
.D VAL^DIE(53.69,PSBIENS,.61,"F",$TR(PSBFUTR,"^ ","~"),"PSBRET","PSBFDA")
|
||||
D FILE^DIE("","PSBFDA")
|
||||
I $G(PSBLIST(0),"")]"" D LIST^PSBO1(.PSBLIST)
|
||||
I $G(PSBDEV)]"" D PRINT^PSBO1 S RESULTS=$NAME(^TMP("PSBO",$J)) Q
|
||||
D HFSOPEN^PSBUTL("RPC") I POP S ^TMP("PSBO",$J,1)="ERROR: UNABLE TO ACCESS HFS DIRECTORY "_$$GET^XPAR("DIV","PSB HFS SCRATCH"),^TMP("PSBO",$J,2)="PLEASE CHECK DIRECTORY WRITE PRIVILEDGES." Q
|
||||
U IO D DQ(+PSBIENS)
|
||||
D HFSCLOSE^PSBUTL("RPC")
|
||||
S RESULTS=$NAME(^TMP("PSBO",$J))
|
||||
D:$G(PSBDEV)]"" PRINT^PSBO1
|
||||
Q
|
||||
;
|
||||
XQ(PSBTYPE) ; Called via Kernel Menus
|
||||
N PSBANS,PSBANS1,PSBRPT,PSBSAVE,DA,DIK,DR,DDSFILE
|
||||
D NEW^PSBO1(.PSBRPT,PSBTYPE)
|
||||
I +PSBRPT(0)<1 W !,"Error: ",$P(PSBRPT(0),U,2) S DIR(0)="E" D ^DIR Q
|
||||
S DA=+PSBRPT(0),DR="[PSBO "_PSBTYPE_"]",DDSFILE=53.69 D ^DDS
|
||||
W @IOF
|
||||
I 'PSBSAVE W !,"Cancelling Request..." S DIK="^PSB(53.69," D ^DIK W "Cancelled!"
|
||||
D:PSBSAVE
|
||||
.;Check Drug to Patient Relationship.
|
||||
.I PSBTYPE="BL" S PSBANS="" D CHECK I PSBANS=0!($D(DIRUT)) W !,"Cancelling Request..." S DIK="^PSB(53.69," D ^DIK W "Cancelled!" Q
|
||||
.;
|
||||
.;Allow "'BROWSER" Device
|
||||
.S IOP=$$GET1^DIQ(53.69,DA_",",.06,"I"),PSBSIO=0 I IOP]"" D
|
||||
..S IOP="`"_IOP,%ZIS="N"
|
||||
..D ^%ZIS
|
||||
..I IO=IO(0) S PSBSIO=1
|
||||
..D HOME^%ZIS K IOP
|
||||
.I $$GET1^DIQ(53.69,DA_",",.06)["BROWSER"!(PSBSIO=1) S IOP=$$GET1^DIQ(53.69,DA_",",.06)_";132" D ^%ZIS U IO D DQ(DA) D ^%ZISC K IOP Q
|
||||
.W @IOF,"Submitting Your Report Request to Taskman..."
|
||||
.S ZTIO=$$GET1^DIQ(53.69,DA_",",.06)
|
||||
.S ZTDTH=$P(^PSB(53.69,DA,0),U,7)
|
||||
.S ZTDESC="BCMA - "_$$GET1^DIQ(53.69,DA_",",.05)
|
||||
.S ZTRTN="DQ^PSBO("_DA_")"
|
||||
.D ^%ZTLOAD
|
||||
.W "Submitted!",!,"Your Task Number Is: ",$G(ZTSK),!
|
||||
K ^TMP("PSBO",$J)
|
||||
Q
|
||||
;
|
||||
DQ(PSBRPT) ; Dequeue report from Taskman
|
||||
N PSBWRD,PSBDFN
|
||||
Q:'$D(^PSB(53.69,PSBRPT,0)) ; No Such Report
|
||||
S $P(^PSB(53.69,PSBRPT,0),U,8)=$G(ZTSK,"RPC")
|
||||
D:$$SETUP @("EN^PSBO"_$P(PSBRPT(0),U,5))
|
||||
K ^TMP("PSBO",$J)
|
||||
S ZTREQ="@"
|
||||
Q
|
||||
;
|
||||
IOM() ; Returns good margin or not
|
||||
Q:IOM'<132 1
|
||||
W !,"**************************************************************"
|
||||
W !,"* SORRY, Your selected DEVICE does not print 132 columns. *"
|
||||
W !,"**************************************************************"
|
||||
W !
|
||||
Q 0
|
||||
;
|
||||
VAL(PSBFLDS) ; Validate that fields in PSBFLDS are filled in
|
||||
N PSB,PSBFLD,PSBMSG,PSBSTOP,PSBST,PSBDAYS S PSBSTRT=""
|
||||
F PSB=1:1 Q:$P(PSBFLDS,";",PSB)="" S PSBFLD=$P(PSBFLDS,";",PSB),PSBFLD(PSBFLD)=$$GET^DDSVAL(53.69,DA,PSBFLD)
|
||||
I $D(PSBFLD(.11)) K:$E(PSBFLD(.11))="P" PSBFLD(.13),PSBFLD(.15) K:$E(PSBFLD(.11))="W" PSBFLD(.12)
|
||||
S PSB="" F S PSB=$O(PSBFLD(PSB)) Q:PSB="" D:PSBFLD(PSB)=""
|
||||
.I '$D(PSBMSG) S PSBMSG(0)="UNABLE TO FILE REQUEST",PSBMSG(1)=" ",PSBMSG(2)="ERROR: MISSING DATA - ALL FIELDS ARE REQUIRED",PSBMSG(3)=" "
|
||||
.D FIELD^DID(53.69,PSB,"","TITLE;LABEL","PSB")
|
||||
.S Z=" Missing Field: "_$S(PSB("TITLE")]"":PSB("TITLE"),1:PSB("LABEL"))
|
||||
.S PSBMSG($O(PSBMSG(""),-1)+1)=Z
|
||||
; Check Times
|
||||
D:$G(PSBFLD(.16))
|
||||
.S PSBSTRT=PSBFLD(.16)+$G(PSBFLD(.17))
|
||||
.D:$P($$GET1^DIQ(53.69,DA_",",.01),U)["MH"
|
||||
..S PSBDAYS=$$GET1^DIQ(101.24,$$FIND1^DIC(101.24,"","X","ORRP BCMA MAH","B")_",",.42) ;check maxdays
|
||||
..S:PSBDAYS="" PSBDAYS=7
|
||||
..S X=PSBSTRT\1 D H^%DTC S PSBST=%H+PSBDAYS ;Determine stop date
|
||||
.S PSBSTOP=$S($G(PSBFLD(.18)):PSBFLD(.18),1:PSBFLD(.16))+$G(PSBFLD(.19))
|
||||
.I PSBSTOP<PSBSTRT S Y=$O(PSBMSG(""),-1)+1,PSBMSG(Y)=" Date: Stop Date/Time is before Start Date/Time"
|
||||
.I $P($$GET1^DIQ(53.69,DA_",",.01),U)["MH" S X=PSBSTOP\1 D H^%DTC I %H>PSBST S Y=$O(PSBMSG(""),-1)+1,PSBMSG(Y)=" The date range cannot exceed "_PSBDAYS_" day(s) as defined in the CPRS 'MAXIMUM DAYS BACK' parameter"
|
||||
Q:'$D(PSBMSG) ; All is well
|
||||
D MSG^DDSUTL(.PSBMSG)
|
||||
S DDSERROR=1
|
||||
Q
|
||||
;
|
||||
SETUP() ; Setup parameters for the report in PSBRPT
|
||||
N PSBWRDL,PSBINDX,PSBWRDA
|
||||
K ^TMP("PSBO",$J)
|
||||
F X=0,.1,.2,.3,.4,1 S PSBRPT(X)=$G(^PSB(53.69,PSBRPT,X))
|
||||
I $D(^PSB(53.69,PSBRPT,2)) M PSBRPT(2)=^PSB(53.69,PSBRPT,2)
|
||||
I $P(PSBRPT(.1),U,1)="P" S PSBDFN=+$P(PSBRPT(.1),U,2) Q:'PSBDFN S ^TMP("PSBO",$J,PSBDFN,0)=$P(^DPT(PSBDFN,0),U)_U_$P(^DPT(PSBDFN,0),U,9),^TMP("PSBO",$J,"B",$P(^DPT(PSBDFN,0),U),PSBDFN)=""
|
||||
D:$P(PSBRPT(.1),U,1)="W"
|
||||
.S PSBWRD=$P(PSBRPT(.1),U,3) Q:'PSBWRD D WARD^NURSUT5("L^"_PSBWRD,.PSBWRDA)
|
||||
.S X="" F S X=$O(PSBWRDA(PSBWRD,2,X)) Q:X="" S PSBWRDL=$P(PSBWRDA(PSBWRD,2,X,.01),U,2) D
|
||||
..F PSBDFN=0:0 S PSBDFN=$O(^DPT("CN",PSBWRDL,PSBDFN)) Q:'PSBDFN D
|
||||
...S ^TMP("PSBO",$J,PSBDFN,0)=$P(^DPT(PSBDFN,0),U)_U_$P(^DPT(PSBDFN,0),U,9)
|
||||
...; Determine Sort or default to Pt Name...
|
||||
...S:$P(PSBRPT(.1),U,5)="P" PSBINDX=$P(^DPT(PSBDFN,0),U)
|
||||
...I $P(PSBRPT(.1),U,5)="B" S PSBINDX=$P($G(^DPT(PSBDFN,.101)),U) S:PSBINDX="" PSBINDX="** NO ROOM BED **"
|
||||
...S:$P(PSBRPT(.1),U,5)="" PSBINDX=$P(^DPT(PSBDFN,0),U)
|
||||
...S:$G(PSBINDX)="" PSBINDX=$P(^DPT(PSBDFN,0),U)
|
||||
...S ^TMP("PSBO",$J,"B",PSBINDX,PSBDFN)=""
|
||||
Q 1
|
||||
;
|
||||
WRAP(X,Y,Z) ; Quick text wrap
|
||||
;
|
||||
; Input Parameters Description:
|
||||
; X: Left Column of display [Optional]
|
||||
; Y: Cols to wrap in [Optional]
|
||||
; Z: Text to wrap [Optional]
|
||||
;
|
||||
N PSB
|
||||
F Q:'$L(Z) D
|
||||
.W:$X>X !
|
||||
.W:$X<X ?X
|
||||
.I $L(Z)<Y W Z S Z="" Q
|
||||
.F PSB=Y:-1:0 Q:$E(Z,PSB)=" "
|
||||
.S:PSB<1 PSB=Y
|
||||
.W $E(Z,1,PSB)
|
||||
.S Z=$E(Z,PSB+1,250)
|
||||
Q ""
|
||||
;
|
||||
CHECK ;Beginning of PSB*1*10
|
||||
K ^TMP("PSJ",$J)
|
||||
N PSBDFN,PSBBAR,PSBDRUG,PSBFLAG,PSBPNM,PSBNDX,PSBX
|
||||
S PSBFLAG="",PSBBAR=$P($P($G(^PSB(53.69,DA,.3)),U,1),"~",2)
|
||||
S PSBDRUG=$$GET1^DIQ(53.69,DA_",",.31)
|
||||
S PSBDFN=$$GET1^DIQ(53.69,DA_",",.12,"I") S:$G(PSBDFN) PSBFLAG=1
|
||||
D EN^PSJBCMA(PSBDFN)
|
||||
F PSBX=0:0 S PSBX=$O(^TMP("PSJ",$J,PSBX)) Q:'PSBX D
|
||||
.K Y,PSBORD,PSBPNM,PSBNDX
|
||||
.M PSBORD=^TMP("PSJ",$J,PSBX)
|
||||
.F PSBNDX=700,850,950 D
|
||||
..F Y=0:0 S Y=$O(PSBORD(PSBNDX,Y)) Q:'Y D
|
||||
...I $P($G(PSBORD(1)),U,7)'="A" Q
|
||||
...S PSBPNM=$P(PSBORD(PSBNDX,Y,0),U,1)
|
||||
...I PSBNDX=700,PSBPNM=PSBBAR S PSBFLAG=0 Q
|
||||
...I PSBNDX=850,$D(^PSDRUG("A526",PSBBAR,PSBPNM)) S PSBFLAG=0 Q
|
||||
...I PSBNDX=950,$D(^PSDRUG("A527",PSBBAR,PSBPNM)) S PSBFLAG=0
|
||||
I PSBFLAG=1 D
|
||||
.W !,"Patient is not currently on medication: ",PSBDRUG
|
||||
.K DIRUT,DIR
|
||||
.S DIR("A")="Do you want to continue"
|
||||
.S DIR(0)="Y"
|
||||
.D ^DIR
|
||||
.S PSBANS=+Y W !
|
||||
;
|
||||
|
|
|
|||
|
|
@ -1,57 +1,57 @@
|
|||
PSBO1 ;BIRMINGHAM/EFC-BCMA OUTPUTS ;Mar 2004
|
||||
;;3.0;BAR CODE MED ADMIN;**4,13,32,2,43**;Mar 2004;Build 2
|
||||
;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified.
|
||||
; Reference/IA
|
||||
; FILE^DICN/10009
|
||||
;
|
||||
NEW(RESULTS,PSBRTYP) ; Create a new report request
|
||||
; Called interactively and via RPCBroker
|
||||
K RESULTS
|
||||
; Check Type
|
||||
I '$F("DL^MD^MH^ML^MM^MV^MT^PE^PM^WA^BL^PI^AL^DO^VT^PF^XA^IV^CM^CP^CE^CI^BZ^",PSBRTYP) S RESULTS(0)="-1^Invalid Report Type" Q
|
||||
I '+$G(DUZ) S RESULTS(0)="-1^Undefined User" Q
|
||||
I '$G(DUZ(2)) S RESULTS(0)="-1^Undefined Division" Q
|
||||
; Lock Log
|
||||
L +(^PSB(53.69,0)):$S($G(DILOCKTM)>30:DILOCKTM,1:30)
|
||||
E S RESULTS(0)="-1^Request Log Locked" Q
|
||||
; Generate Unique Entry and Create
|
||||
F D NOW^%DTC S X=$E(%_"000000",1,14) S X=(1700+$E(X,1,3))_$E(X,4,14),X=PSBRTYP_"-"_$TR(X,".","-") Q:'$D(^PSB(53.69,"B",X))
|
||||
S DIC="^PSB(53.69,",DIC(0)="L"
|
||||
S DIC("DR")=".02///N;.03////^S X=DUZ;.04////^S X=DUZ(2);.05///^S X=PSBRTYP"
|
||||
K DD,DO D FILE^DICN
|
||||
L -(^PSB(53.69,0))
|
||||
; Okay, setup return and Boogie
|
||||
I +Y<1 S RESULTS(0)="-1^Error Creating Request"
|
||||
E S RESULTS(0)=Y
|
||||
Q
|
||||
;
|
||||
PRINT ;
|
||||
N ZTDTH,ZTRTN,ZTSK,ZTDESC,ZTSAVE,DA
|
||||
S DA=+PSBRPT(0)
|
||||
S IOP=$$GET1^DIQ(53.69,DA_",",.06,"I"),PSBSIO=0 I IOP]"" D
|
||||
.S IOP="`"_IOP,%ZIS="N"
|
||||
.D ^%ZIS
|
||||
.I IO=IO(0) S PSBSIO=1
|
||||
.D HOME^%ZIS K IOP
|
||||
I $$GET1^DIQ(53.69,DA_",",.06)["BROWSER"!(PSBSIO=1) S IOP=$$GET1^DIQ(53.69,DA_",",.06)_";132" D ^%ZIS U IO D DQ^PSBO(DA) D ^%ZISC K IOP Q
|
||||
W @IOF,"Submitting Your Report Request to Taskman..."
|
||||
S ZTIO=$$GET1^DIQ(53.69,DA_",",.06)_";132"
|
||||
S ZTDTH=$S($$GET1^DIQ(53.69,DA_",",.07,"I")]"":$$GET1^DIQ(53.69,DA_",",.07,"I"),1:$H)
|
||||
S ZTDESC="BCMA - "_$$GET1^DIQ(53.69,DA_",",.05)
|
||||
S ZTRTN="DQ^PSBO("_DA_")"
|
||||
F I="PSBDFN","PSBTYPE" S ZTSAVE(I)=""
|
||||
I $G(PSBORDNM)]"" S ZTSAVE("PSBORDNM")=""
|
||||
D ^%ZTLOAD
|
||||
I $D(ZTSK) S ^TMP("PSBO",$J,1)="0^Report queued. (Task #"_ZTSK_")"
|
||||
E S ^TMP("PSBO",$J,1)="-1^Task Rejected."
|
||||
Q
|
||||
;
|
||||
LIST(XLIST) ; Place List Criteria into subfile #53.692 (multiple)
|
||||
F XL1=$O(XLIST("")):1:$O(XLIST("B"),-1) Q:+XL1="" D
|
||||
.I $P(XLIST(XL1),U)=PSBTYPE D
|
||||
..K PSBFDA,PSBRET,PSBIENX D CLEAN^DILF
|
||||
..S PSBIENX="+"_(XL1+1)_","_PSBIENS
|
||||
..D VAL^DIE(53.692,"+"_(XL1+1)_","_PSBIENS,.01,"F",$TR(XLIST(XL1),"^","~"),"PSBRET","PSBFDA")
|
||||
..D UPDATE^DIE("","PSBFDA","PSBIENX","PSBRET")
|
||||
Q
|
||||
;
|
||||
PSBO1 ;BIRMINGHAM/EFC-BCMA OUTPUTS ;Mar 2004
|
||||
;;3.0;BAR CODE MED ADMIN;**4,13,32**;Mar 2004;Build 32
|
||||
;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified.
|
||||
; Reference/IA
|
||||
; FILE^DICN/10009
|
||||
;
|
||||
NEW(RESULTS,PSBRTYP) ; Create a new report request
|
||||
; Called interactively and via RPCBroker
|
||||
K RESULTS
|
||||
; Check Type
|
||||
I '$F("DL^MD^MH^ML^MM^MV^MT^PE^PM^WA^BL^PI^AL^DO^VT^PF^XA^IV^CM^CP^CE^CI^",PSBRTYP) S RESULTS(0)="-1^Invalid Report Type" Q
|
||||
I '+$G(DUZ) S RESULTS(0)="-1^Undefined User" Q
|
||||
I '$G(DUZ(2)) S RESULTS(0)="-1^Undefined Division" Q
|
||||
; Lock Log
|
||||
L +(^PSB(53.69,0)):0
|
||||
E S RESULTS(0)="-1^Request Log Locked" Q
|
||||
; Generate Unique Entry and Create
|
||||
F D NOW^%DTC S X=$E(%_"000000",1,14) S X=(1700+$E(X,1,3))_$E(X,4,14),X=PSBRTYP_"-"_$TR(X,".","-") Q:'$D(^PSB(53.69,"B",X))
|
||||
S DIC="^PSB(53.69,",DIC(0)="L"
|
||||
S DIC("DR")=".02///N;.03////^S X=DUZ;.04////^S X=DUZ(2);.05///^S X=PSBRTYP"
|
||||
K DD,DO D FILE^DICN
|
||||
L -(^PSB(53.69,0))
|
||||
; Okay, setup return and Boogie
|
||||
I +Y<1 S RESULTS(0)="-1^Error Creating Request"
|
||||
E S RESULTS(0)=Y
|
||||
Q
|
||||
;
|
||||
PRINT ;
|
||||
N ZTDTH,ZTRTN,ZTSK,ZTDESC,ZTSAVE,DA
|
||||
S DA=+PSBRPT(0)
|
||||
S IOP=$$GET1^DIQ(53.69,DA_",",.06,"I"),PSBSIO=0 I IOP]"" D
|
||||
.S IOP="`"_IOP,%ZIS="N"
|
||||
.D ^%ZIS
|
||||
.I IO=IO(0) S PSBSIO=1
|
||||
.D HOME^%ZIS K IOP
|
||||
I $$GET1^DIQ(53.69,DA_",",.06)["BROWSER"!(PSBSIO=1) S IOP=$$GET1^DIQ(53.69,DA_",",.06)_";132" D ^%ZIS U IO D DQ^PSBO(DA) D ^%ZISC K IOP Q
|
||||
W @IOF,"Submitting Your Report Request to Taskman..."
|
||||
S ZTIO=$$GET1^DIQ(53.69,DA_",",.06)_";132"
|
||||
S ZTDTH=$S($$GET1^DIQ(53.69,DA_",",.07,"I")]"":$$GET1^DIQ(53.69,DA_",",.07,"I"),1:$H)
|
||||
S ZTDESC="BCMA - "_$$GET1^DIQ(53.69,DA_",",.05)
|
||||
S ZTRTN="DQ^PSBO("_DA_")"
|
||||
F I="PSBDFN","PSBTYPE" S ZTSAVE(I)=""
|
||||
I $G(PSBORDNM)]"" S ZTSAVE("PSBORDNM")=""
|
||||
D ^%ZTLOAD
|
||||
I $D(ZTSK) S ^TMP("PSBO",$J,1)="0^Report queued. (Task #"_ZTSK_")"
|
||||
E S ^TMP("PSBO",$J,1)="-1^Task Rejected."
|
||||
Q
|
||||
;
|
||||
LIST(XLIST) ; Place List Criteria into subfile #53.692 (multiple)
|
||||
F XL1=$O(XLIST("")):1:$O(XLIST("B"),-1) Q:+XL1="" D
|
||||
.I $P(XLIST(XL1),U)=PSBTYPE D
|
||||
..K PSBFDA,PSBRET,PSBIENX D CLEAN^DILF
|
||||
..S PSBIENX="+"_(XL1+1)_","_PSBIENS
|
||||
..D VAL^DIE(53.692,"+"_(XL1+1)_","_PSBIENS,.01,"F",$TR(XLIST(XL1),"^","~"),"PSBRET","PSBFDA")
|
||||
..D UPDATE^DIE("","PSBFDA","PSBIENX","PSBRET")
|
||||
Q
|
||||
;
|
||||
|
|
|
|||
|
|
@ -1,175 +1,175 @@
|
|||
PSBOMH1 ;BIRMINGHAM/EFC-MAH ;7:40 PM 30 Jan 2008
|
||||
;;3.0;BAR CODE MED ADMIN;**6,3,9,11,26,38,VWEHR1**;WorldVistA 30-Jan-08;Build 4
|
||||
;Per VHA Directive 2004-038, this routine should not be modified.
|
||||
;
|
||||
;Modified from FOIA VISTA,
|
||||
;Copyright 2008 WorldVistA. Licensed under the terms of the GNU
|
||||
;General Public License See attached copy of the License.
|
||||
;
|
||||
;This program is free software; you can redistribute it and/or modify
|
||||
;it under the terms of the GNU General Public License as published by
|
||||
;the Free Software Foundation; either version 2 of the License, or
|
||||
;(at your option) any later version.
|
||||
;
|
||||
;This program is distributed in the hope that it will be useful,
|
||||
;but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;GNU General Public License for more details.
|
||||
;
|
||||
;You should have received a copy of the GNU General Public License along
|
||||
;with this program; if not, write to the Free Software Foundation, Inc.,
|
||||
;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
|
||||
;
|
||||
; Reference/IA
|
||||
; ^DILF/2054
|
||||
; File 200/10060
|
||||
;
|
||||
EN ;
|
||||
; Load administrations
|
||||
S (PSBORD,PSBIEN,PSBR1,PSBADIEN,PSBABR)="",PSBDT=PSBSTRT
|
||||
K PSBTSA
|
||||
F S PSBDT=$O(^PSB(53.79,"AADT",DFN,PSBDT)) Q:'PSBDT!(PSBDT>PSBSTOP) D
|
||||
.F S PSBIEN=$O(^PSB(53.79,"AADT",DFN,PSBDT,PSBIEN)) Q:'PSBIEN Q:'$D(^PSB(53.79,PSBIEN)) L +^PSB(53.79,PSBIEN):3 I $P(^PSB(53.79,PSBIEN,0),U,9)]"" D L -^PSB(53.79,PSBIEN)
|
||||
..Q:'$P($G(^PSB(53.79,PSBIEN,0)),U,6) ; Bad IEN -no evnt dt
|
||||
..Q:$P(^PSB(53.79,PSBIEN,0),U,9)="N" ;NGiven
|
||||
..S PSBORD=$P($G(^PSB(53.79,PSBIEN,.1)),U,1)
|
||||
..; Continuous
|
||||
..D:$P($G(^PSB(53.79,PSBIEN,.1)),U,2)="C"
|
||||
...S X=PSBDT D H^%DTC S PSBWEEK=PSBAR(%H) D CLEAN^PSBVT,PSJ1^PSBVT($P(^PSB(53.79,PSBIEN,0),U,1),$P(^PSB(53.79,PSBIEN,.1),U,1))
|
||||
...I $P(^PSB(53.79,PSBIEN,0),U,6)'=PSBDT,'$$IVPTAB^PSBVDLU3(PSBOTYP,PSBIVT,PSBISYR,PSBCHEMT,PSBIVPSH) D D CLEAN^PSBVT Q ;chck IV audit
|
||||
....S PSBSIEN=PSBIEN
|
||||
....I $P(^PSB(53.79,PSBIEN,0),"^",10)]"" D BAGDTL^PSBRPC2(.PSBAUD,$P(^PSB(53.79,PSBIEN,0),U,10),$P(^PSB(53.79,PSBIEN,.1),U,1))
|
||||
....S PSBIEN=PSBSIEN K PSBSIEN
|
||||
....S X=0 F S X=$O(PSBAUD(X)) Q:X="" I $P(PSBAUD(X),U,3)="" K PSBAUD(X)
|
||||
....S X=0 F S X=$O(PSBAUD(X)) Q:X="" Q:$P(PSBAUD(X),U,1)=PSBDT
|
||||
....I X="" K PSBAUD Q
|
||||
....I '$D(PSBAUD(X)) K PSBAUD Q
|
||||
....S PSBS=$P(PSBAUD(X),U,3)
|
||||
....I PSBS="GIVEN",$P($G(PSBAUD(X-1)),U,3)="NOT GIVEN" Q
|
||||
....I PSBS="NOT GIVEN" Q
|
||||
....S PSBS=$S(PSBS="INFUSING":"I",PSBS="GIVEN":"G",PSBS="COMPLETED":"C",PSBS="HELD":"H",PSBS="REFUSED":"R",PSBS="REMOVED":"RM",PSBS="STOPPED":"S",PSBS["MISSING":"M",1:"NOACTION")
|
||||
....D PSBSTIV^PSBOMH2
|
||||
....S X=PSBDT_U_$P(PSBAUD(X),U,2)_U_PSBS_U_PSBIEN
|
||||
....S Y=$O(^TMP("PSB",$J,PSBWEEK,PSBORD,PSBDT\1,""),-1)+1
|
||||
....S ^TMP("PSB",$J,PSBWEEK,PSBORD,PSBDT\1,Y)=X
|
||||
....S ^TMP("PSB",$J,PSBWEEK,PSBORD,PSBDT\1,0)=Y
|
||||
....D PSBOUT($P((X),"^",1),$P((X),"^",2))
|
||||
....K PSBAUD
|
||||
...S PSBINIT=$$GET1^DIQ(53.79,PSBIEN_",","ACTION BY:INITIAL")
|
||||
...S PSBNAME=$$GET1^DIQ(53.79,PSBIEN_",","ACTION BY:NAME")
|
||||
...I PSBINIT="" S PSBINIT=99
|
||||
...;get instrc info - audt log
|
||||
...I $D(^PSB(53.79,PSBIEN,.9,$P(PSBDT,"."))) D
|
||||
....D INSTR^PSBOMH
|
||||
....S ^TMP("PSB",$J,"LEGEND",PSBINIT,PSBNAME)=""
|
||||
...I PSBINIT[99 S PSBINIT=""
|
||||
...I $P(^PSB(53.79,PSBIEN,0),U,9)="G",PSBDT=$P(^PSB(53.79,PSBIEN,0),U,6) D PSBCK1^PSBOMH2("A")
|
||||
...I $P(^PSB(53.79,PSBIEN,0),U,9)'="G",PSBDT=$P(^PSB(53.79,PSBIEN,0),U,6) D PSBCK1^PSBOMH2("B")
|
||||
...I PSBDT'=$P(^PSB(53.79,PSBIEN,0),U,6),$P(^PSB(53.79,PSBIEN,0),U,9)="RM" D
|
||||
....D DDAUD
|
||||
....S I="" F S I=$O(PSBTAR(I),-1) Q:I="" I $P(PSBTAR(I),U,1)=PSBDT D
|
||||
.....S PSBS=$P(PSBTAR(I),U,3)
|
||||
.....I PSBS="GIVEN",$P($G(PSBTAR(I-1)),U,3)="NOT GIVEN" Q ; canceled - not given
|
||||
.....I PSBS="NOT GIVEN" Q
|
||||
.....S PSBS=$S(PSBS="INFUSING":"I",PSBS="GIVEN":"G",PSBS="COMPLETED":"C",PSBS="HELD":"H",PSBS="REFUSED":"R",PSBS="REMOVED":"RM",PSBS="STOPPED":"S",PSBS["MISSING":"M",1:"NO ACTION")
|
||||
.....D PSBCTAR^PSBOMH2
|
||||
.....S X=$P(PSBTAR(I),U,1,2)_U_PSBS_U_PSBIEN
|
||||
...S Y=$O(^TMP("PSB",$J,PSBWEEK,PSBORD,PSBDT\1,""),-1)+1
|
||||
...S ^TMP("PSB",$J,PSBWEEK,PSBORD,PSBDT\1,Y)=X
|
||||
...S ^TMP("PSB",$J,PSBWEEK,PSBORD,PSBDT\1,0)=Y
|
||||
...D PSBOUT($P((X),"^",1),$P((X),"^",2))
|
||||
...Q
|
||||
..; 1-Time On Call or PRN
|
||||
..D:$P($G(^PSB(53.79,PSBIEN,.1)),U,2)'="C"
|
||||
...I PSBDT'=$$GET1^DIQ(53.79,PSBIEN_",",.06,"I") Q
|
||||
...S PSBINIT=$$GET1^DIQ(53.79,PSBIEN_",","ACTION BY:INITIAL")
|
||||
...S PSBNAME=$$GET1^DIQ(53.79,PSBIEN_",","ACTION BY:NAME")
|
||||
...I PSBINIT="" S PSBINIT=99
|
||||
...S (PSBXA,PSBM)=1,(PSBZ,PSBT,PSBFLG)=""
|
||||
...I $$GET1^DIQ(53.79,PSBIEN_",",.09)="REMOVED" D
|
||||
....F I=1:1 S PSBXA=$O(^PSB(53.79,PSBIEN,.9,PSBXA)) Q:PSBXA="" I PSBXA?1.3N S PSBZ=PSBZ+1,PSBT(PSBZ)=^PSB(53.79,PSBIEN,.9,PSBXA,0)
|
||||
....F S=1:1 Q:PSBM<1 S PSBM=PSBZ-S I (PSBM>0) I (PSBT(PSBM)["GIVEN") S PSBFLG="1" S PRELINE1=$P(PSBT(PSBM),"'",2)_" "_$$GET1^DIQ(53.79,PSBIEN_",",.04)_" "_$E($P(PSBT(PSBM),"'",4),1,3) Q
|
||||
...I $D(^PSB(53.79,PSBIEN,.9,$P(PSBDT,"."))) D
|
||||
....D INSTR^PSBOMH
|
||||
....S ^TMP("PSB",$J,"LEGEND",PSBINIT,PSBNAME)=""
|
||||
...I '$D(^PSB(53.79,PSBIEN,.9,$P(PSBDT,"."))) D PSBOUT(PSBDT,PSBINIT)
|
||||
...S PSBLINE1=$$GET1^DIQ(53.79,PSBIEN_",",.09)_" "_$$GET1^DIQ(53.79,PSBIEN_",",.06)_" "_PSBINIT_" "_$$GET1^DIQ(53.79,PSBIEN_",",.21),PSBLINE2=""
|
||||
...I PSBINIT[99 S PSBINIT=""
|
||||
...D:$P($G(^PSB(53.79,PSBIEN,.1)),U,2)="P"
|
||||
....I $P($G(^PSB(53.79,PSBIEN,.2)),U,2)="" S PSBLINE2=" Results: <No PRN Results On File>"
|
||||
....E D
|
||||
.....S PSBINIT=$$GET1^DIQ(53.79,PSBIEN_",","PRN EFFECTIVENESS ENTERED BY:INITIAL")
|
||||
.....S PSBNAME=$$GET1^DIQ(53.79,PSBIEN_",","PRN EFFECTIVENESS ENTERED BY:NAME")
|
||||
.....I PSBINIT="" S PSBINIT=99
|
||||
.....I $D(^PSB(53.79,PSBIEN,.9,$P(PSBDT,"."))) D
|
||||
......S PSBINIT=PSBINIT_"*",PSBNAME=PSBNAME_"/"_$P(^PSB(53.79,PSBIEN,.9,$P(PSBDT,"."),0),U,3)_" "_$$GET1^DIQ(53.79,PSBIEN_",",.24)
|
||||
......S ^TMP("PSB",$J,"LEGEND",PSBINIT,PSBNAME)=""
|
||||
.....I '$D(^PSB(53.79,PSBIEN,.9,$P(PSBDT,"."))) D
|
||||
......D:$D(^PSB(53.79,PSBIEN,.9,0))
|
||||
.......S (PSBXA2,PSBFG)=0,PSBEFFDT=$P(^PSB(53.79,PSBIEN,.2),U,4) F S PSBXA2=$O(^PSB(53.79,PSBIEN,.9,PSBXA2)) Q:+PSBXA2'>0 D Q:PSBFG=1
|
||||
........D:($P(^PSB(53.79,PSBIEN,.9,PSBXA2,0),U)=PSBEFFDT)&($P(^PSB(53.79,PSBIEN,.9,PSBXA2,0),U,3)["Instruct")&($P(^PSB(53.79,PSBIEN,.2),U,3)=$P(^PSB(53.79,PSBIEN,.9,PSBXA2,0),U,2))
|
||||
.........S PSBINIT=PSBINIT_"*",PSBNAME=PSBNAME_"/"_$P(^PSB(53.79,PSBIEN,.9,PSBXA2,0),U,3)_" "_$$GET1^DIQ(53.79,PSBIEN_",",.24)
|
||||
.........S ^TMP("PSB",$J,"LEGEND",PSBINIT,PSBNAME)="",PSBFG=1
|
||||
.....S PSBLINE2=" Results: "_$$GET1^DIQ(53.79,PSBIEN_",",.22)
|
||||
.....S PSBRTXTW=" Entered By "_PSBINIT_" on "_$$GET1^DIQ(53.79,PSBIEN_",",.24)
|
||||
.....I PSBINIT[99 S PSBINIT=""
|
||||
...S X=PSBDT D H^%DTC F PSBWEEK=PSBAR(%H):-7 Q:$D(^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",0))!('$D(PSBAR(PSBWEEK)))
|
||||
...S X=$O(^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",""),-1)+1
|
||||
...I PSBFLG="1" S ^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",X)=PRELINE1
|
||||
...S ^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",X+1)=PSBLINE1
|
||||
...I $G(PSBLINE2)]"" D
|
||||
....I $L(PSBLINE2)<90 S ^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",X+2)=PSBLINE2 S:$$GET1^DIQ(53.79,PSBIEN_",",.24)'="" ^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",X+3)=" "_PSBRTXTW
|
||||
....I $L(PSBLINE2)>90 D
|
||||
.....S ^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",X+2)=$E(PSBLINE2,1,90)
|
||||
.....S ^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",X+3)=" "_$E(PSBLINE2,91,161)
|
||||
.....I $L(PSBLINE2)'>161 S ^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",X+4)=" "_PSBRTXTW
|
||||
.....I $L(PSBLINE2)>161 S ^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",X+4)=" "_$E(PSBLINE2,162,200),^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",X+5)=" "_PSBRTXTW
|
||||
Q
|
||||
;
|
||||
DDAUD ; audits for dispen drugs
|
||||
;
|
||||
M PSBMLA=^PSB(53.79,PSBIEN)
|
||||
S PSBGA="" I $D(PSBMLA(.9,0)) D
|
||||
.F PSBX=1:1 Q:'$D(PSBMLA(.9,PSBX)) I ((PSBMLA(.9,PSBX,0)["ACTION STATUS")!(PSBMLA(.9,PSBX,0)["ADMINISTRATION STATUS")) D Q
|
||||
..I $D(PSBMLA(.9,PSBX-2,0)) D DT^DILF("ENPST",$P(PSBMLA(.9,PSBX-2,0),"'",2),.PSBDATE)
|
||||
..I '$D(PSBMLA(.9,PSBX-2,0)) S PSBDATE=$P(^PSB(53.79,PSBIEN,0),U,6)
|
||||
..S PSBTMP(10000000-PSBDATE,"B")=PSBDATE_U_$$INITIAL^PSBRPC2($P(PSBMLA(0),U,5))_U_$P(PSBMLA(.9,PSBX,0),"'",2)
|
||||
..S PSBGA=1
|
||||
.F PSBX=1:1 Q:'$D(PSBMLA(.9,PSBX)) I ((PSBMLA(.9,PSBX,0)["ACTION STATUS")!(PSBMLA(.9,PSBX,0)["ADMINISTRATION STATUS")) D
|
||||
..S PSBTMP(10000000-$P(PSBMLA(.9,PSBX,0),U,1),"B")=$P(PSBMLA(.9,PSBX,0),U,1)_U_$$INITIAL^PSBRPC2($P(PSBMLA(.9,PSBX,0),U,2))_U_$P($P(PSBMLA(.9,PSBX,0),U,3),"'",2)
|
||||
..S PSBGA=1
|
||||
I PSBGA'=1 S PSBTMP(10000000-$P(PSBMLA(0),U,6),"A")=$P(PSBMLA(0),U,6)_U_$$INITIAL^PSBRPC2($P(PSBMLA(0),U,7))
|
||||
S PSBQRY="PSBTMP",PSBCNT=1 F S PSBQRY=$Q(@PSBQRY) Q:PSBQRY="" D ; does comment go with action
|
||||
.;
|
||||
.;WV/EHR REVERSE $Q REPLACEMENT; SO 01/12/08 ;VWEHR1
|
||||
.;
|
||||
.;S PSBPQRY=$Q(@PSBQRY,-1)
|
||||
.S PSBPQRY=$$Q^VWUTIL($NA(@PSBQRY),-1)
|
||||
.;
|
||||
.;END CHANGE
|
||||
.;
|
||||
.I PSBPQRY="" S PSBTAR(PSBCNT)=@PSBQRY,PSBCNT=PSBCNT+1 Q ; no prev action
|
||||
.I $QS(PSBPQRY,2)="C" S PSBTAR(PSBCNT)=@PSBQRY,PSBCNT=PSBCNT+1 Q ; prev line = comment
|
||||
.I $QS(PSBQRY,2)="C",$E($P(@$Q(@PSBQRY,-1),U,1),1,12)=$E($P(@PSBQRY,U,1),1,12),$P(@$Q(@PSBQRY,-1),U,2)=$P(@PSBQRY,U,2) D Q
|
||||
..S X=$P(@PSBQRY,U,4) S:X[":" X=$P(X,":",2) S $P(PSBTAR(PSBCNT-1),U,4)=X Q
|
||||
.S PSBTAR(PSBCNT)=@PSBQRY,PSBCNT=PSBCNT+1
|
||||
Q
|
||||
;
|
||||
PSBOUT(PSBTET,PSBOT1) ;
|
||||
I '$D(^PSB(53.79,PSBIEN,.9,0)) D PSBENT^PSBOMH2(PSBOT1)
|
||||
S PSBIDA="" I $P(^PSB(53.79,PSBIEN,0),U,6)=PSBTET S PSBIDA=$P(^PSB(53.79,PSBIEN,0),U,7),PSBOT1=$P(^VA(200,PSBIDA,0),"^",2),PSBNAME=$P(^VA(200,PSBIDA,0),"^",1)
|
||||
S PSBXA1=0
|
||||
F S PSBXA1=$O(^PSB(53.79,PSBIEN,.9,PSBXA1)) Q:+PSBXA1'>0 I PSBXA1'=0 D Q:$G(PSBOT1)["*"
|
||||
.I $L(PSBXA1)<4 D
|
||||
..I $P(^PSB(53.79,PSBIEN,.9,PSBXA1,0),"^",1)=PSBTET D
|
||||
...S:$G(PSBIDA)="" PSBIDA=$P(^PSB(53.79,PSBIEN,.9,PSBXA1,0),"^",2),PSBOT1=$P(^VA(200,PSBIDA,0),"^",2),PSBNAME=$P(^VA(200,PSBIDA,0),"^",1)
|
||||
...I (PSBIDA=$P(^PSB(53.79,PSBIEN,.9,PSBXA1,0),"^",2)),$P(^PSB(53.79,PSBIEN,.9,PSBXA1,0),"^",3)["Instruct" D
|
||||
....S INSDD=$P(^PSB(53.79,PSBIEN,.9,PSBXA1,0),"^",1),Y=INSDD D DD^%DT S INSDD=Y
|
||||
....S PSBOT1=PSBOT1_"*",PSBNAME=PSBNAME_"/"_$P(^PSB(53.79,PSBIEN,.9,PSBXA1,0),U,3)_" "_INSDD
|
||||
I $G(PSBIDA)="",$P(^PSB(53.79,PSBIEN,0),U,4)=PSBTET D
|
||||
.S PSBIDA=$P(^PSB(53.79,PSBIEN,0),U,5),PSBOT1=$P(^VA(200,PSBIDA,0),"^",2),PSBNAME=$P(^VA(200,PSBIDA,0),"^",1)
|
||||
I $G(PSBNAME)="" D
|
||||
. S PSBIDA=$P(^PSB(53.79,PSBIEN,0),U,5),PSBOT1=$P(^VA(200,PSBIDA,0),"^",2),PSBNAME=$P(^VA(200,PSBIDA,0),"^",1)
|
||||
S ^TMP("PSB",$J,"LEGEND",$S($G(PSBOT1)="":99,1:PSBOT1),PSBNAME)=""
|
||||
Q
|
||||
;
|
||||
PSBOMH1 ;BIRMINGHAM/EFC-MAH ;7:40 PM 30 Jan 2008
|
||||
;;3.0;BAR CODE MED ADMIN;**6,3,9,11,26,38,VWEHR1**;WorldVistA 30-Jan-08
|
||||
;Per VHA Directive 2004-038, this routine should not be modified.
|
||||
;
|
||||
;Modified from FOIA VISTA,
|
||||
;Copyright 2008 WorldVistA. Licensed under the terms of the GNU
|
||||
;General Public License See attached copy of the License.
|
||||
;
|
||||
;This program is free software; you can redistribute it and/or modify
|
||||
;it under the terms of the GNU General Public License as published by
|
||||
;the Free Software Foundation; either version 2 of the License, or
|
||||
;(at your option) any later version.
|
||||
;
|
||||
;This program is distributed in the hope that it will be useful,
|
||||
;but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;GNU General Public License for more details.
|
||||
;
|
||||
;You should have received a copy of the GNU General Public License along
|
||||
;with this program; if not, write to the Free Software Foundation, Inc.,
|
||||
;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
|
||||
;
|
||||
; Reference/IA
|
||||
; ^DILF/2054
|
||||
; File 200/10060
|
||||
;
|
||||
EN ;
|
||||
; Load administrations
|
||||
S (PSBORD,PSBIEN,PSBR1,PSBADIEN,PSBABR)="",PSBDT=PSBSTRT
|
||||
K PSBTSA
|
||||
F S PSBDT=$O(^PSB(53.79,"AADT",DFN,PSBDT)) Q:'PSBDT!(PSBDT>PSBSTOP) D
|
||||
.F S PSBIEN=$O(^PSB(53.79,"AADT",DFN,PSBDT,PSBIEN)) Q:'PSBIEN Q:'$D(^PSB(53.79,PSBIEN)) L +^PSB(53.79,PSBIEN):3 I $P(^PSB(53.79,PSBIEN,0),U,9)]"" D L -^PSB(53.79,PSBIEN)
|
||||
..Q:'$P($G(^PSB(53.79,PSBIEN,0)),U,6) ; Bad IEN -no evnt dt
|
||||
..Q:$P(^PSB(53.79,PSBIEN,0),U,9)="N" ;NGiven
|
||||
..S PSBORD=$P($G(^PSB(53.79,PSBIEN,.1)),U,1)
|
||||
..; Continuous
|
||||
..D:$P($G(^PSB(53.79,PSBIEN,.1)),U,2)="C"
|
||||
...S X=PSBDT D H^%DTC S PSBWEEK=PSBAR(%H) D CLEAN^PSBVT,PSJ1^PSBVT($P(^PSB(53.79,PSBIEN,0),U,1),$P(^PSB(53.79,PSBIEN,.1),U,1))
|
||||
...I $P(^PSB(53.79,PSBIEN,0),U,6)'=PSBDT,'$$IVPTAB^PSBVDLU3(PSBOTYP,PSBIVT,PSBISYR,PSBCHEMT,PSBIVPSH) D D CLEAN^PSBVT Q ;chck IV audit
|
||||
....S PSBSIEN=PSBIEN
|
||||
....I $P(^PSB(53.79,PSBIEN,0),"^",10)]"" D BAGDTL^PSBRPC2(.PSBAUD,$P(^PSB(53.79,PSBIEN,0),U,10),$P(^PSB(53.79,PSBIEN,.1),U,1))
|
||||
....S PSBIEN=PSBSIEN K PSBSIEN
|
||||
....S X=0 F S X=$O(PSBAUD(X)) Q:X="" I $P(PSBAUD(X),U,3)="" K PSBAUD(X)
|
||||
....S X=0 F S X=$O(PSBAUD(X)) Q:X="" Q:$P(PSBAUD(X),U,1)=PSBDT
|
||||
....I X="" K PSBAUD Q
|
||||
....I '$D(PSBAUD(X)) K PSBAUD Q
|
||||
....S PSBS=$P(PSBAUD(X),U,3)
|
||||
....I PSBS="GIVEN",$P($G(PSBAUD(X-1)),U,3)="NOT GIVEN" Q
|
||||
....I PSBS="NOT GIVEN" Q
|
||||
....S PSBS=$S(PSBS="INFUSING":"I",PSBS="GIVEN":"G",PSBS="COMPLETED":"C",PSBS="HELD":"H",PSBS="REFUSED":"R",PSBS="REMOVED":"RM",PSBS="STOPPED":"S",PSBS["MISSING":"M",1:"NOACTION")
|
||||
....D PSBSTIV^PSBOMH2
|
||||
....S X=PSBDT_U_$P(PSBAUD(X),U,2)_U_PSBS_U_PSBIEN
|
||||
....S Y=$O(^TMP("PSB",$J,PSBWEEK,PSBORD,PSBDT\1,""),-1)+1
|
||||
....S ^TMP("PSB",$J,PSBWEEK,PSBORD,PSBDT\1,Y)=X
|
||||
....S ^TMP("PSB",$J,PSBWEEK,PSBORD,PSBDT\1,0)=Y
|
||||
....D PSBOUT($P((X),"^",1),$P((X),"^",2))
|
||||
....K PSBAUD
|
||||
...S PSBINIT=$$GET1^DIQ(53.79,PSBIEN_",","ACTION BY:INITIAL")
|
||||
...S PSBNAME=$$GET1^DIQ(53.79,PSBIEN_",","ACTION BY:NAME")
|
||||
...I PSBINIT="" S PSBINIT=99
|
||||
...;get instrc info - audt log
|
||||
...I $D(^PSB(53.79,PSBIEN,.9,$P(PSBDT,"."))) D
|
||||
....D INSTR^PSBOMH
|
||||
....S ^TMP("PSB",$J,"LEGEND",PSBINIT,PSBNAME)=""
|
||||
...I PSBINIT[99 S PSBINIT=""
|
||||
...I $P(^PSB(53.79,PSBIEN,0),U,9)="G",PSBDT=$P(^PSB(53.79,PSBIEN,0),U,6) D PSBCK1^PSBOMH2("A")
|
||||
...I $P(^PSB(53.79,PSBIEN,0),U,9)'="G",PSBDT=$P(^PSB(53.79,PSBIEN,0),U,6) D PSBCK1^PSBOMH2("B")
|
||||
...I PSBDT'=$P(^PSB(53.79,PSBIEN,0),U,6),$P(^PSB(53.79,PSBIEN,0),U,9)="RM" D
|
||||
....D DDAUD
|
||||
....S I="" F S I=$O(PSBTAR(I),-1) Q:I="" I $P(PSBTAR(I),U,1)=PSBDT D
|
||||
.....S PSBS=$P(PSBTAR(I),U,3)
|
||||
.....I PSBS="GIVEN",$P($G(PSBTAR(I-1)),U,3)="NOT GIVEN" Q ; canceled - not given
|
||||
.....I PSBS="NOT GIVEN" Q
|
||||
.....S PSBS=$S(PSBS="INFUSING":"I",PSBS="GIVEN":"G",PSBS="COMPLETED":"C",PSBS="HELD":"H",PSBS="REFUSED":"R",PSBS="REMOVED":"RM",PSBS="STOPPED":"S",PSBS["MISSING":"M",1:"NO ACTION")
|
||||
.....D PSBCTAR^PSBOMH2
|
||||
.....S X=$P(PSBTAR(I),U,1,2)_U_PSBS_U_PSBIEN
|
||||
...S Y=$O(^TMP("PSB",$J,PSBWEEK,PSBORD,PSBDT\1,""),-1)+1
|
||||
...S ^TMP("PSB",$J,PSBWEEK,PSBORD,PSBDT\1,Y)=X
|
||||
...S ^TMP("PSB",$J,PSBWEEK,PSBORD,PSBDT\1,0)=Y
|
||||
...D PSBOUT($P((X),"^",1),$P((X),"^",2))
|
||||
...Q
|
||||
..; 1-Time On Call or PRN
|
||||
..D:$P($G(^PSB(53.79,PSBIEN,.1)),U,2)'="C"
|
||||
...I PSBDT'=$$GET1^DIQ(53.79,PSBIEN_",",.06,"I") Q
|
||||
...S PSBINIT=$$GET1^DIQ(53.79,PSBIEN_",","ACTION BY:INITIAL")
|
||||
...S PSBNAME=$$GET1^DIQ(53.79,PSBIEN_",","ACTION BY:NAME")
|
||||
...I PSBINIT="" S PSBINIT=99
|
||||
...S (PSBXA,PSBM)=1,(PSBZ,PSBT,PSBFLG)=""
|
||||
...I $$GET1^DIQ(53.79,PSBIEN_",",.09)="REMOVED" D
|
||||
....F I=1:1 S PSBXA=$O(^PSB(53.79,PSBIEN,.9,PSBXA)) Q:PSBXA="" I PSBXA?1.3N S PSBZ=PSBZ+1,PSBT(PSBZ)=^PSB(53.79,PSBIEN,.9,PSBXA,0)
|
||||
....F S=1:1 Q:PSBM<1 S PSBM=PSBZ-S I (PSBM>0) I (PSBT(PSBM)["GIVEN") S PSBFLG="1" S PRELINE1=$P(PSBT(PSBM),"'",2)_" "_$$GET1^DIQ(53.79,PSBIEN_",",.04)_" "_$E($P(PSBT(PSBM),"'",4),1,3) Q
|
||||
...I $D(^PSB(53.79,PSBIEN,.9,$P(PSBDT,"."))) D
|
||||
....D INSTR^PSBOMH
|
||||
....S ^TMP("PSB",$J,"LEGEND",PSBINIT,PSBNAME)=""
|
||||
...I '$D(^PSB(53.79,PSBIEN,.9,$P(PSBDT,"."))) D PSBOUT(PSBDT,PSBINIT)
|
||||
...S PSBLINE1=$$GET1^DIQ(53.79,PSBIEN_",",.09)_" "_$$GET1^DIQ(53.79,PSBIEN_",",.06)_" "_PSBINIT_" "_$$GET1^DIQ(53.79,PSBIEN_",",.21),PSBLINE2=""
|
||||
...I PSBINIT[99 S PSBINIT=""
|
||||
...D:$P($G(^PSB(53.79,PSBIEN,.1)),U,2)="P"
|
||||
....I $P($G(^PSB(53.79,PSBIEN,.2)),U,2)="" S PSBLINE2=" Results: <No PRN Results On File>"
|
||||
....E D
|
||||
.....S PSBINIT=$$GET1^DIQ(53.79,PSBIEN_",","PRN EFFECTIVENESS ENTERED BY:INITIAL")
|
||||
.....S PSBNAME=$$GET1^DIQ(53.79,PSBIEN_",","PRN EFFECTIVENESS ENTERED BY:NAME")
|
||||
.....I PSBINIT="" S PSBINIT=99
|
||||
.....I $D(^PSB(53.79,PSBIEN,.9,$P(PSBDT,"."))) D
|
||||
......S PSBINIT=PSBINIT_"*",PSBNAME=PSBNAME_"/"_$P(^PSB(53.79,PSBIEN,.9,$P(PSBDT,"."),0),U,3)_" "_$$GET1^DIQ(53.79,PSBIEN_",",.24)
|
||||
......S ^TMP("PSB",$J,"LEGEND",PSBINIT,PSBNAME)=""
|
||||
.....I '$D(^PSB(53.79,PSBIEN,.9,$P(PSBDT,"."))) D
|
||||
......D:$D(^PSB(53.79,PSBIEN,.9,0))
|
||||
.......S (PSBXA2,PSBFG)=0,PSBEFFDT=$P(^PSB(53.79,PSBIEN,.2),U,4) F S PSBXA2=$O(^PSB(53.79,PSBIEN,.9,PSBXA2)) Q:+PSBXA2'>0 D Q:PSBFG=1
|
||||
........D:($P(^PSB(53.79,PSBIEN,.9,PSBXA2,0),U)=PSBEFFDT)&($P(^PSB(53.79,PSBIEN,.9,PSBXA2,0),U,3)["Instruct")&($P(^PSB(53.79,PSBIEN,.2),U,3)=$P(^PSB(53.79,PSBIEN,.9,PSBXA2,0),U,2))
|
||||
.........S PSBINIT=PSBINIT_"*",PSBNAME=PSBNAME_"/"_$P(^PSB(53.79,PSBIEN,.9,PSBXA2,0),U,3)_" "_$$GET1^DIQ(53.79,PSBIEN_",",.24)
|
||||
.........S ^TMP("PSB",$J,"LEGEND",PSBINIT,PSBNAME)="",PSBFG=1
|
||||
.....S PSBLINE2=" Results: "_$$GET1^DIQ(53.79,PSBIEN_",",.22)
|
||||
.....S PSBRTXTW=" Entered By "_PSBINIT_" on "_$$GET1^DIQ(53.79,PSBIEN_",",.24)
|
||||
.....I PSBINIT[99 S PSBINIT=""
|
||||
...S X=PSBDT D H^%DTC F PSBWEEK=PSBAR(%H):-7 Q:$D(^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",0))!('$D(PSBAR(PSBWEEK)))
|
||||
...S X=$O(^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",""),-1)+1
|
||||
...I PSBFLG="1" S ^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",X)=PRELINE1
|
||||
...S ^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",X+1)=PSBLINE1
|
||||
...I $G(PSBLINE2)]"" D
|
||||
....I $L(PSBLINE2)<90 S ^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",X+2)=PSBLINE2 S:$$GET1^DIQ(53.79,PSBIEN_",",.24)'="" ^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",X+3)=" "_PSBRTXTW
|
||||
....I $L(PSBLINE2)>90 D
|
||||
.....S ^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",X+2)=$E(PSBLINE2,1,90)
|
||||
.....S ^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",X+3)=" "_$E(PSBLINE2,91,161)
|
||||
.....I $L(PSBLINE2)'>161 S ^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",X+4)=" "_PSBRTXTW
|
||||
.....I $L(PSBLINE2)>161 S ^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",X+4)=" "_$E(PSBLINE2,162,200),^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",X+5)=" "_PSBRTXTW
|
||||
Q
|
||||
;
|
||||
DDAUD ; audits for dispen drugs
|
||||
;
|
||||
M PSBMLA=^PSB(53.79,PSBIEN)
|
||||
S PSBGA="" I $D(PSBMLA(.9,0)) D
|
||||
.F PSBX=1:1 Q:'$D(PSBMLA(.9,PSBX)) I ((PSBMLA(.9,PSBX,0)["ACTION STATUS")!(PSBMLA(.9,PSBX,0)["ADMINISTRATION STATUS")) D Q
|
||||
..I $D(PSBMLA(.9,PSBX-2,0)) D DT^DILF("ENPST",$P(PSBMLA(.9,PSBX-2,0),"'",2),.PSBDATE)
|
||||
..I '$D(PSBMLA(.9,PSBX-2,0)) S PSBDATE=$P(^PSB(53.79,PSBIEN,0),U,6)
|
||||
..S PSBTMP(10000000-PSBDATE,"B")=PSBDATE_U_$$INITIAL^PSBRPC2($P(PSBMLA(0),U,5))_U_$P(PSBMLA(.9,PSBX,0),"'",2)
|
||||
..S PSBGA=1
|
||||
.F PSBX=1:1 Q:'$D(PSBMLA(.9,PSBX)) I ((PSBMLA(.9,PSBX,0)["ACTION STATUS")!(PSBMLA(.9,PSBX,0)["ADMINISTRATION STATUS")) D
|
||||
..S PSBTMP(10000000-$P(PSBMLA(.9,PSBX,0),U,1),"B")=$P(PSBMLA(.9,PSBX,0),U,1)_U_$$INITIAL^PSBRPC2($P(PSBMLA(.9,PSBX,0),U,2))_U_$P($P(PSBMLA(.9,PSBX,0),U,3),"'",2)
|
||||
..S PSBGA=1
|
||||
I PSBGA'=1 S PSBTMP(10000000-$P(PSBMLA(0),U,6),"A")=$P(PSBMLA(0),U,6)_U_$$INITIAL^PSBRPC2($P(PSBMLA(0),U,7))
|
||||
S PSBQRY="PSBTMP",PSBCNT=1 F S PSBQRY=$Q(@PSBQRY) Q:PSBQRY="" D ; does comment go with action
|
||||
.;
|
||||
.;WV/EHR REVERSE $Q REPLACEMENT; SO 01/12/08 ;VWEHR1
|
||||
.;
|
||||
.;S PSBPQRY=$Q(@PSBQRY,-1)
|
||||
.S PSBPQRY=$$Q^VWUTIL($NA(@PSBQRY),-1)
|
||||
.;
|
||||
.;END CHANGE
|
||||
.;
|
||||
.I PSBPQRY="" S PSBTAR(PSBCNT)=@PSBQRY,PSBCNT=PSBCNT+1 Q ; no prev action
|
||||
.I $QS(PSBPQRY,2)="C" S PSBTAR(PSBCNT)=@PSBQRY,PSBCNT=PSBCNT+1 Q ; prev line = comment
|
||||
.I $QS(PSBQRY,2)="C",$E($P(@$Q(@PSBQRY,-1),U,1),1,12)=$E($P(@PSBQRY,U,1),1,12),$P(@$Q(@PSBQRY,-1),U,2)=$P(@PSBQRY,U,2) D Q
|
||||
..S X=$P(@PSBQRY,U,4) S:X[":" X=$P(X,":",2) S $P(PSBTAR(PSBCNT-1),U,4)=X Q
|
||||
.S PSBTAR(PSBCNT)=@PSBQRY,PSBCNT=PSBCNT+1
|
||||
Q
|
||||
;
|
||||
PSBOUT(PSBTET,PSBOT1) ;
|
||||
I '$D(^PSB(53.79,PSBIEN,.9,0)) D PSBENT^PSBOMH2(PSBOT1)
|
||||
S PSBIDA="" I $P(^PSB(53.79,PSBIEN,0),U,6)=PSBTET S PSBIDA=$P(^PSB(53.79,PSBIEN,0),U,7),PSBOT1=$P(^VA(200,PSBIDA,0),"^",2),PSBNAME=$P(^VA(200,PSBIDA,0),"^",1)
|
||||
S PSBXA1=0
|
||||
F S PSBXA1=$O(^PSB(53.79,PSBIEN,.9,PSBXA1)) Q:+PSBXA1'>0 I PSBXA1'=0 D Q:$G(PSBOT1)["*"
|
||||
.I $L(PSBXA1)<4 D
|
||||
..I $P(^PSB(53.79,PSBIEN,.9,PSBXA1,0),"^",1)=PSBTET D
|
||||
...S:$G(PSBIDA)="" PSBIDA=$P(^PSB(53.79,PSBIEN,.9,PSBXA1,0),"^",2),PSBOT1=$P(^VA(200,PSBIDA,0),"^",2),PSBNAME=$P(^VA(200,PSBIDA,0),"^",1)
|
||||
...I (PSBIDA=$P(^PSB(53.79,PSBIEN,.9,PSBXA1,0),"^",2)),$P(^PSB(53.79,PSBIEN,.9,PSBXA1,0),"^",3)["Instruct" D
|
||||
....S INSDD=$P(^PSB(53.79,PSBIEN,.9,PSBXA1,0),"^",1),Y=INSDD D DD^%DT S INSDD=Y
|
||||
....S PSBOT1=PSBOT1_"*",PSBNAME=PSBNAME_"/"_$P(^PSB(53.79,PSBIEN,.9,PSBXA1,0),U,3)_" "_INSDD
|
||||
I $G(PSBIDA)="",$P(^PSB(53.79,PSBIEN,0),U,4)=PSBTET D
|
||||
.S PSBIDA=$P(^PSB(53.79,PSBIEN,0),U,5),PSBOT1=$P(^VA(200,PSBIDA,0),"^",2),PSBNAME=$P(^VA(200,PSBIDA,0),"^",1)
|
||||
I $G(PSBNAME)="" D
|
||||
. S PSBIDA=$P(^PSB(53.79,PSBIEN,0),U,5),PSBOT1=$P(^VA(200,PSBIDA,0),"^",2),PSBNAME=$P(^VA(200,PSBIDA,0),"^",1)
|
||||
S ^TMP("PSB",$J,"LEGEND",$S($G(PSBOT1)="":99,1:PSBOT1),PSBNAME)=""
|
||||
Q
|
||||
;
|
||||
|
|
|
|||
|
|
@ -1,145 +1,145 @@
|
|||
PSBPOIV ;BIRMINGHAM/EFC-IV PARAMETER VALIDATION ;Mar 2004
|
||||
;;3.0;BAR CODE MED ADMIN;**2**;Mar 2004;Build 22
|
||||
;;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified.
|
||||
;
|
||||
; Reference/IA
|
||||
; ^DIC(42/2440
|
||||
; EN^PSJBCMA2/2830
|
||||
; VADPT/10061
|
||||
;
|
||||
;
|
||||
EN(PSBDFN,PSBORD) ;
|
||||
;
|
||||
S DFN=PSBDFN,(PSBMI,PSBMW,PSBMWC,PSBMAUD)=0,(PSBMIDT,PSBMIM)="",PSBONXS=PSBORD_"^"
|
||||
K ^TMP("PSBAR",$J) S ^TMP("PSBAR",$J,"W",0)=0
|
||||
D CLEAN^PSBVT,PSJ1^PSBVT(DFN,PSBORD)
|
||||
; get IV parameters for the current ward
|
||||
S PSBCSTR="^ADDITIVE^STRENGTH^BOTTLE^SOLUTION^VOLUME^INFUSION RATE^MED ROUTE^SCHEDULE^ADMIN TIME^REMARKS^OTHER PRINT INFO^PROVIDER^START DATE/TIME^STOP DATE/TIME^PROVIDER COMMENTS"
|
||||
D INP^VADPT S PSBWARD=$P(VAIN(4),"^"),PSBWDIV=PSBWARD D KVAR^VADPT
|
||||
I $G(PSBWARD)'="",$D(^PSB(53.66,"B",PSBWARD)) D ; if IV paramaters defined for ward use them
|
||||
.S PSBWARD=$O(^PSB(53.66,"B",PSBWARD,""))
|
||||
.S:$D(^PSB(53.66,PSBWARD,1,"B",PSBIVT)) PSBIVPAR=^PSB(53.66,PSBWARD,1,$O(^PSB(53.66,PSBWARD,1,"B",PSBIVT,""),-1),0)
|
||||
I '$D(PSBIVPAR) S PSBIVPAR=PSBIVT D ; if IV parameters not defined for ward get defaults for division
|
||||
.D:$D(PSBWDIV) ; Get the appropriate DIV for ward and DIVISIONAL IV PARAMETERS
|
||||
..S PSBWDIV=$$GET1^DIQ(42,PSBWDIV_",",.015,"I")
|
||||
..I $G(PSBWDIV)']"" S PSBWDIV="DIV"
|
||||
..E S PSBWDIV=$P($$SITE^VASITE(DT,PSBWDIV),U,1),PSBWDIV="DIV.`"_PSBWDIV
|
||||
..F X=2:1 Q:$P(PSBCSTR,U,X)="" S PSBIVPAR=PSBIVPAR_U_$P($P($$GET^XPAR(PSBWDIV,"PSBIV "_$P(PSBCSTR,U,X),PSBIVT,"B"),U,2),"-",1)
|
||||
..K PSBWDIV ; Kill temp variable.
|
||||
F PSBC1=1:1 Q:$P(PSBONXS,U,PSBC1)="" D ; process all orders
|
||||
.D CLEAN^PSBVT,PSJ1^PSBVT(DFN,$P(PSBONXS,U,PSBC1))
|
||||
.K PSBPONX2 I $G(PSBPONX)]"",$G(PSBPONX)["P" S PSBPONX2=PSBPONX D ; Must compare "active" orders for changes made - look beyond "pendings"
|
||||
..F D CLEAN^PSBVT,PSJ1^PSBVT(DFN,PSBPONX2) S PSBPONX2=PSBPONX Q:(PSBPONX2="")!(PSBPONX2'["P") ;
|
||||
..D CLEAN^PSBVT,PSJ1^PSBVT(DFN,$P(PSBONXS,U,PSBC1)) ; Refresh data
|
||||
..S:$D(PSBPONX2) PSBPONX=PSBPONX2 K PSBPONX2
|
||||
.Q:($L(U_PSBONXS,U_PSBPONX_U)-1)>0
|
||||
.I $G(PSBPONX)]"" S PSBONXS=PSBONXS_PSBPONX_U
|
||||
.K ^TMP("PSJ2",$J) S PSBMAUD=0 D EN^PSJBCMA2(PSBDFN,PSBONX,1) ; check IV parameters against activity log for this order when no "I"nvalid message
|
||||
.I PSBMI=0 F X=1:1 Q:'$D(^TMP("PSJ2",$J,X)) S PSBCHKV=U_$P(^TMP("PSJ2",$J,X,1),U,3)_U I PSBCSTR[PSBCHKV D MSG(PSBCHKV,$P(^TMP("PSJ2",$J,X,1),U,1)) S PSBMAUD=1
|
||||
.K ^TMP("PSJ2",$J)
|
||||
.I PSBMI=0,$G(PSBPONX)]"" D SAVEPAR,CHKORD ; check IV parameters against previous order when no "I"nvalid message
|
||||
.D CLEAN^PSBVT,PSJ1^PSBVT(DFN,$P(PSBONXS,U,PSBC1)) ; restore variable for this order
|
||||
.; okay - we have invalids and warnings through this order so process bags for this order
|
||||
.I '$D(PSBUIDA) Q ; got errors and warning but no bags printed for this order - go to the next
|
||||
.S PSBUID="" F S PSBUID=$O(PSBUIDA(PSBUID),-1) Q:PSBUID="" D
|
||||
..F PSBC2=1:1 S PSBMONX=$P(PSBONXS,U,PSBC2) Q:PSBMONX="" D ; check if bag is in 53.79
|
||||
...I $D(^PSB(53.79,"AUID",PSBDFN,PSBMONX,PSBUID)) D
|
||||
....S PSBIEN=$O(^PSB(53.79,"AUID",PSBDFN,PSBMONX,PSBUID,""))
|
||||
....S PSBPDT=$P(PSBLBLA(PSBUID),U,1),PSBLSTS=$P(PSBLBLA(PSBUID),3)
|
||||
....S $P(X,U,2)=$P(^PSB(53.79,PSBIEN,0),U,9) ; add action status
|
||||
....S $P(X,U,3)=$P(^PSB(53.79,PSBIEN,0),U,6) ; add action date/time
|
||||
....S $P(X,U,4)=$P(^PSB(53.79,PSBIEN,.1),U,1) ; add order ID was administered for
|
||||
..S $P(X,U,5)=PSBONX ; add order ID was printed for
|
||||
..S $P(X,U,6)=PSBOSTS ; add order status
|
||||
..S $P(X,U,7)=$P(PSBLBLA(PSBUID),U,1) ; add date/time ID was printed
|
||||
..S $P(X,U,8)=$P(PSBLBLA(PSBUID),U,3) ; add lable status from pharmacy
|
||||
..S $P(X,U,9)="" ; 9 open for later development
|
||||
..S $P(X,U,10)=PSBUIDA(PSBUID) ; add return from PSJ1
|
||||
..D BWAR
|
||||
..I PSBMW=1 S PSBMWS="W;" F I=1:1:^TMP("PSBAR",$J,"W",0) D S $P(X,U,1)=$P(PSBMWS,";",1,$L(PSBMWS,";")-1)
|
||||
...I $P(PSBLBLA(PSBUID),U,1)'>$P(^TMP("PSBAR",$J,"W",I),U,2) D
|
||||
....S:(PSBONX=$P(PSBONXS,U,1))&(PSBMAUD=1) PSBMWS=PSBMWS_I_";"
|
||||
....S:PSBONX'=$P(PSBONXS,U,1) PSBMWS=PSBMWS_I_";"
|
||||
..I PSBMIDT'="",$P(PSBLBLA(PSBUID),U,1)<PSBMIDT D
|
||||
...S:(PSBONX=$P(PSBONXS,U,1))&(PSBMAUD=1) $P(X,U,1)="I"
|
||||
...S:(PSBONX'=$P(PSBONXS,U,1)) $P(X,U,1)="I"
|
||||
..S ^TMP("PSBAR",$J,PSBUID)=X K X
|
||||
D CLEAN^PSBVT
|
||||
K PSBC1,PSBC2,PSBSCHV,PSBCSTR,PSBIVPAR,PSBMI,PSBMIDT,PSBMIM,PSBMONX,PSBMW,PSBSPAR,PSBUID,PSBWARD
|
||||
K PSBADA,PSBSOLA,PSBOTMP
|
||||
I ^TMP("PSBAR",$J,"W",0)=0 K ^TMP("PSBAR",$J,"W",0)
|
||||
D PSJ1^PSBVT(DFN,PSBORD) ; restore variables for calling order
|
||||
Q
|
||||
;
|
||||
SAVEPAR ; save parameters from current order
|
||||
K PSBOTMP
|
||||
I $D(PSBADA) M PSBOTMP("ADD")=PSBADA E S PSBOTMP("ADD")="" ; additive, strength, bottle
|
||||
I $D(PSBSOLA) M PSBOTMP("SOL")=PSBSOLA E S PSBOTMP("SOL")="" ; solution, volume,
|
||||
K PSBADA,PSBSOLA
|
||||
S PSBOTMP("INFUSION RATE")=$G(PSBIFR),PSBOTMP("MED ROUTE")=$G(PSBMR)
|
||||
S PSBOTMP("SCHEDULE")=$G(PSBSCH),PSBOTMP("ADMIN TIME")=$G(PSBADST)
|
||||
S PSBOTMP("REMARKS")=$G(PSBRMRK),PSBOTMP("OTHER PRINT INFO")=$G(PSBOTXT)
|
||||
S PSBOTMP("PROVIDER")=PSBMD,PSBOTMP("START DATE/TIME")=PSBOST
|
||||
S PSBOTMP("STOP DATE/TIME")=PSBOSP
|
||||
D CLEAN^PSBVT,PSJ1^PSBVT(DFN,$P(PSBONXS,U,PSBC1+1)) ; setup previous order variables
|
||||
Q
|
||||
;
|
||||
CHKORD ; check previous order against current order
|
||||
I $D(PSBADA)!($D(PSBOTMP("ADD"))) D CHKADD Q:PSBMI=1
|
||||
I $D(PSBSOLA)!($D(PSBOTMP("SOL"))) D CHKSOL Q:PSBMI=1
|
||||
I PSBIFR'=PSBOTMP("INFUSION RATE") D MSG("INFUSION RATE",PSBOSP) Q:PSBMI=1
|
||||
I PSBMR'=PSBOTMP("MED ROUTE") D MSG("MED ROUTE",PSBOSP) Q:PSBMI=1
|
||||
I PSBSCH'=PSBOTMP("SCHEDULE") D MSG("SCHEDULE",PSBOSP) Q:PSBMI=1
|
||||
I PSBADST'=PSBOTMP("ADMIN TIME") D MSG("ADMIN TIME",PSBOSP) Q:PSBMI=1
|
||||
I PSBRMRK'=PSBOTMP("REMARKS") D MSG("REMARKS",PSBOSP) Q:PSBMI=1
|
||||
I PSBOTXT'=PSBOTMP("OTHER PRINT INFO") D MSG("OTHER PRINT INFO",PSBOSP) Q:PSBMI=1
|
||||
I PSBMD'=PSBOTMP("PROVIDER") D MSG("PROVIDER",PSBOSP) Q:PSBMI=1
|
||||
I $E(PSBOST,1,10)'=$E(PSBOTMP("START DATE/TIME"),1,10) D MSG("START DATE/TIME",PSBOSP) Q:PSBMI=1
|
||||
I $E(PSBOSP,1,10)'=$E(PSBOTMP("STOP DATE/TIME"),1,10) D MSG("STOP DATE/TIME",PSBOSP)
|
||||
Q
|
||||
CHKADD ;
|
||||
N X,Y
|
||||
I '$D(PSBADA),'$D(PSBOTMP("ADD")) Q ; no additives
|
||||
I $O(PSBADA(""),-1)>$O(PSBOTMP("ADD",""),-1) D MSG("ADDITIVE",PSBOSP) Q ;previous order has addtives not in current order
|
||||
I $O(PSBADA(""),-1)<$O(PSBOTMP("ADD",""),-1) D MSG("ADDITIVE",PSBOSP) Q ;previous order missing additives in current order
|
||||
S X="" F S X=$O(PSBADA(X)) Q:X="" D Q ; check that additives, strength, and bottle are the same
|
||||
.I PSBADA(X)=PSBOTMP("ADD",X) Q ; everything the same
|
||||
.I $P(PSBADA(X),U,2)'=$P(PSBOTMP("ADD",X),U,2) D MSG("ADDITIVE",PSBOSP) Q
|
||||
.I $P(PSBADA(X),U,4)'=$P(PSBOTMP("ADD",X),U,4) D MSG("STRENGTH",PSBOSP) Q
|
||||
Q
|
||||
;
|
||||
CHKSOL ;
|
||||
N X,Y
|
||||
I '$D(PSBSOLA),'$D(PSBOTMP("SOL")) Q ; no solutions
|
||||
I $O(PSBSOLA(""),-1)>$O(PSBOTMP("SOL",""),-1) D MSG("SOLUTION",PSBOSP) Q ;previous order has solutions not in current order
|
||||
I $O(PSBSOLA(""),-1)<$O(PSBOTMP("SOL",""),-1) D MSG("SOLUTION",PSBOSP) Q ;previous order missing solutions in current order
|
||||
S X="" F S X=$O(PSBSOLA(X)) Q:X="" D Q ; check that solutions volume are the same
|
||||
.I PSBSOLA(X)=PSBOTMP("SOL",X) Q ; everything the same
|
||||
.I $P(PSBSOLA(X),U,2)'=$P(PSBOTMP("SOL",X),U,2) D MSG("SOLUTION",PSBOSP) Q
|
||||
.I $P(PSBSOLA(X),U,4)'=$P(PSBOTMP("SOL",X),U,4) D MSG("VOLUME",PSBOSP) Q
|
||||
Q
|
||||
;
|
||||
BWAR ;
|
||||
N X,Y,Z,PSBONX
|
||||
S X=^TMP("PSBAR",$J,"W",0)+1
|
||||
S Z="" F Z=1:1 S PSBONX=$P(PSBONXS,U,Z) Q:$G(PSBONX)="" D ; Display "Warning"s for changes
|
||||
.I '$D(PSBMWAR(PSBONX)) Q
|
||||
.S Y="" F S Y=$O(PSBMWAR(PSBONX,Y)) Q:Y'?.N1".".N D
|
||||
..S Z="",PSBYS="" F S Z=$O(PSBMWAR(PSBONX,Y,Z)) Q:Z="" S PSBYS=PSBYS_Z_";"
|
||||
..S PSBYS=$P(PSBYS,";",1,$L(PSBYS,";")-1)
|
||||
..S ^TMP("PSBAR",$J,"W",X)=PSBONX_U_Y_U_"2^The "_PSBYS_" was changed on",^TMP("PSBAR",$J,"W",0)=X,X=X+1
|
||||
.K PSBMWAR(PSBONX)
|
||||
Q
|
||||
;
|
||||
MSG(PSBMVAR,PSBDATE) ;
|
||||
I PSBMI=1 Q ;already have an invalid don't need anymore
|
||||
F Y=1:1 S PSBSPAR=$P(PSBCSTR,U,Y) I PSBSPAR=$TR(PSBMVAR,"^") D Q
|
||||
.I $P(PSBIVPAR,U,Y)="W" D
|
||||
..S PSBMVAR=$TR(PSBMVAR,"^")
|
||||
..I PSBMW=0 S PSBMW=1
|
||||
..S PSBMWC=PSBMWC+1,PSBMWM="2^The "_PSBSPAR_" has been changed."
|
||||
..I $D(PSBMWAR(PSBONX,PSBMVAR)) S PSBOLDT=$O(PSBMWAR(PSBONX,PSBMVAR,"")) I PSBOLDT<$E(PSBDATE,1,12) K PSBMWAR(PSBONX,PSBMVAR,PSBOLDT)
|
||||
..S PSBMWAR(PSBONX,PSBMVAR,$E(PSBDATE,1,12))=""
|
||||
..S PSBMWAR(PSBONX,$E(PSBDATE,1,12),PSBMVAR)=""
|
||||
.I $P(PSBIVPAR,U,Y)="I" S PSBMI=1,PSBMIDT=PSBDATE,PSBMIM="-1^IV invalid "_PSBSPAR_".",^TMP("PSBAR",$J,"I")=PSBONX_U_PSBMIDT_U_PSBMIM
|
||||
Q
|
||||
PSBPOIV ;BIRMINGHAM/EFC-IV PARAMETER VALIDATION ;Mar 2004
|
||||
;;3.0;BAR CODE MED ADMIN;;Mar 2004
|
||||
;
|
||||
; Reference/IA
|
||||
; ^DIC(42/1377
|
||||
; ^DIC(42/2440
|
||||
; EN^PSJCBMA1/2829
|
||||
; EN^PSJBCMA2/2830
|
||||
; DIQ(2/10035
|
||||
;
|
||||
EN(PSBDFN,PSBORD) ;
|
||||
;
|
||||
S DFN=PSBDFN,(PSBMI,PSBMW,PSBMWC,PSBMAUD)=0,(PSBMIDT,PSBMIM)="",PSBONXS=PSBORD_"^"
|
||||
K ^TMP("PSBAR",$J) S ^TMP("PSBAR",$J,"W",0)=0
|
||||
D CLEAN^PSBVT,PSJ1^PSBVT(DFN,PSBORD)
|
||||
; get IV parameters for the current ward
|
||||
S PSBCSTR="^ADDITIVE^STRENGTH^BOTTLE^SOLUTION^VOLUME^INFUSION RATE^MED ROUTE^SCHEDULE^ADMIN TIME^REMARKS^OTHER PRINT INFO^PROVIDER^START DATE/TIME^STOP DATE/TIME^PROVIDER COMMENTS"
|
||||
S PSBWARD=$$GET1^DIQ(2,PSBDFN_",",.1),PSBWARD=$$FIND1^DIC(42,"","X",PSBWARD),PSBWDIV=PSBWARD
|
||||
I $G(PSBWARD)'="",$D(^PSB(53.66,"B",PSBWARD)) D ; if IV paramaters defined for ward use them
|
||||
.S PSBWARD=$O(^PSB(53.66,"B",PSBWARD,""))
|
||||
.S:$D(^PSB(53.66,PSBWARD,1,"B",PSBIVT)) PSBIVPAR=^PSB(53.66,PSBWARD,1,$O(^PSB(53.66,PSBWARD,1,"B",PSBIVT,""),-1),0)
|
||||
I '$D(PSBIVPAR) S PSBIVPAR=PSBIVT D ; if IV parameters not defined for ward get defaults for division
|
||||
.D:$D(PSBWDIV) ; Get the appropriate DIV for ward and DIVISIONAL IV PARAMETERS
|
||||
..S PSBWDIV=$$GET1^DIQ(42,PSBWDIV_",",.015,"I"),PSBWDIV=$P($$SITE^VASITE(DT,PSBWDIV),U,1)
|
||||
..I $G(PSBWDIV)']"" S PSBWDIV="DIV"
|
||||
..E S PSBWDIV="DIV.`"_PSBWDIV
|
||||
..F X=2:1 Q:$P(PSBCSTR,U,X)="" S PSBIVPAR=PSBIVPAR_U_$P($P($$GET^XPAR(PSBWDIV,"PSBIV "_$P(PSBCSTR,U,X),PSBIVT,"B"),U,2),"-",1)
|
||||
..K PSBWDIV ; Kill temp variable.
|
||||
F PSBC1=1:1 Q:$P(PSBONXS,U,PSBC1)="" D ; process all orders
|
||||
.D CLEAN^PSBVT,PSJ1^PSBVT(DFN,$P(PSBONXS,U,PSBC1))
|
||||
.K PSBPONX2 I $G(PSBPONX)]"",$G(PSBPONX)["P" S PSBPONX2=PSBPONX D ; Must compare "active" orders for changes made - look beyond "pendings"
|
||||
..F D CLEAN^PSBVT,PSJ1^PSBVT(DFN,PSBPONX2) S PSBPONX2=PSBPONX Q:(PSBPONX2="")!(PSBPONX2'["P") ;
|
||||
..D CLEAN^PSBVT,PSJ1^PSBVT(DFN,$P(PSBONXS,U,PSBC1)) ; Refresh data
|
||||
..S:$D(PSBPONX2) PSBPONX=PSBPONX2 K PSBPONX2
|
||||
.Q:($L(U_PSBONXS,U_PSBPONX_U)-1)>0
|
||||
.I $G(PSBPONX)]"" S PSBONXS=PSBONXS_PSBPONX_U
|
||||
.K ^TMP("PSJ2",$J) S PSBMAUD=0 D EN^PSJBCMA2(PSBDFN,PSBONX,1) ; check IV parameters against activity log for this order when no "I"nvalid message
|
||||
.I PSBMI=0 F X=1:1 Q:'$D(^TMP("PSJ2",$J,X)) S PSBCHKV=U_$P(^TMP("PSJ2",$J,X,1),U,3)_U I PSBCSTR[PSBCHKV D MSG(PSBCHKV,$P(^TMP("PSJ2",$J,X,1),U,1)) S PSBMAUD=1
|
||||
.K ^TMP("PSJ2",$J)
|
||||
.I PSBMI=0,$G(PSBPONX)]"" D SAVEPAR,CHKORD ; check IV parameters against previous order when no "I"nvalid message
|
||||
.D CLEAN^PSBVT,PSJ1^PSBVT(DFN,$P(PSBONXS,U,PSBC1)) ; restore variable for this order
|
||||
.; okay - we have invalids and warnings through this order so process bags for this order
|
||||
.I '$D(PSBUIDA) Q ; got errors and warning but no bags printed for this order - go to the next
|
||||
.S PSBUID="" F S PSBUID=$O(PSBUIDA(PSBUID),-1) Q:PSBUID="" D
|
||||
..F PSBC2=1:1 S PSBMONX=$P(PSBONXS,U,PSBC2) Q:PSBMONX="" D ; check if bag is in 53.79
|
||||
...I $D(^PSB(53.79,"AUID",PSBDFN,PSBMONX,PSBUID)) D
|
||||
....S PSBIEN=$O(^PSB(53.79,"AUID",PSBDFN,PSBMONX,PSBUID,""))
|
||||
....S PSBPDT=$P(PSBLBLA(PSBUID),U,1),PSBLSTS=$P(PSBLBLA(PSBUID),3)
|
||||
....S $P(X,U,2)=$P(^PSB(53.79,PSBIEN,0),U,9) ; add action status
|
||||
....S $P(X,U,3)=$P(^PSB(53.79,PSBIEN,0),U,6) ; add action date/time
|
||||
....S $P(X,U,4)=$P(^PSB(53.79,PSBIEN,.1),U,1) ; add order ID was administered for
|
||||
..S $P(X,U,5)=PSBONX ; add order ID was printed for
|
||||
..S $P(X,U,6)=PSBOSTS ; add order status
|
||||
..S $P(X,U,7)=$P(PSBLBLA(PSBUID),U,1) ; add date/time ID was printed
|
||||
..S $P(X,U,8)=$P(PSBLBLA(PSBUID),U,3) ; add lable status from pharmacy
|
||||
..S $P(X,U,9)="" ; 9 open for later development
|
||||
..S $P(X,U,10)=PSBUIDA(PSBUID) ; add return from PSJ1
|
||||
..D BWAR
|
||||
..I PSBMW=1 S PSBMWS="W;" F I=1:1:^TMP("PSBAR",$J,"W",0) D S $P(X,U,1)=$P(PSBMWS,";",1,$L(PSBMWS,";")-1)
|
||||
...I $P(PSBLBLA(PSBUID),U,1)'>$P(^TMP("PSBAR",$J,"W",I),U,2) D
|
||||
....S:(PSBONX=$P(PSBONXS,U,1))&(PSBMAUD=1) PSBMWS=PSBMWS_I_";"
|
||||
....S:PSBONX'=$P(PSBONXS,U,1) PSBMWS=PSBMWS_I_";"
|
||||
..I PSBMIDT'="",$P(PSBLBLA(PSBUID),U,1)<PSBMIDT D
|
||||
...S:(PSBONX=$P(PSBONXS,U,1))&(PSBMAUD=1) $P(X,U,1)="I"
|
||||
...S:(PSBONX'=$P(PSBONXS,U,1)) $P(X,U,1)="I"
|
||||
..S ^TMP("PSBAR",$J,PSBUID)=X K X
|
||||
D CLEAN^PSBVT
|
||||
K PSBC1,PSBC2,PSBSCHV,PSBCSTR,PSBIVPAR,PSBMI,PSBMIDT,PSBMIM,PSBMONX,PSBMW,PSBSPAR,PSBUID,PSBWARD
|
||||
K PSBADA,PSBSOLA,PSBOTMP
|
||||
I ^TMP("PSBAR",$J,"W",0)=0 K ^TMP("PSBAR",$J,"W",0)
|
||||
D PSJ1^PSBVT(DFN,PSBORD) ; restore variables for calling order
|
||||
Q
|
||||
;
|
||||
SAVEPAR ; save parameters from current order
|
||||
K PSBOTMP
|
||||
I $D(PSBADA) M PSBOTMP("ADD")=PSBADA E S PSBOTMP("ADD")="" ; additive, strength, bottle
|
||||
I $D(PSBSOLA) M PSBOTMP("SOL")=PSBSOLA E S PSBOTMP("SOL")="" ; solution, volume,
|
||||
K PSBADA,PSBSOLA
|
||||
S PSBOTMP("INFUSION RATE")=$G(PSBIFR),PSBOTMP("MED ROUTE")=$G(PSBMR)
|
||||
S PSBOTMP("SCHEDULE")=$G(PSBSCH),PSBOTMP("ADMIN TIME")=$G(PSBADST)
|
||||
S PSBOTMP("REMARKS")=$G(PSBRMRK),PSBOTMP("OTHER PRINT INFO")=$G(PSBOTXT)
|
||||
S PSBOTMP("PROVIDER")=PSBMD,PSBOTMP("START DATE/TIME")=PSBOST
|
||||
S PSBOTMP("STOP DATE/TIME")=PSBOSP
|
||||
D CLEAN^PSBVT,PSJ1^PSBVT(DFN,$P(PSBONXS,U,PSBC1+1)) ; setup previous order variables
|
||||
Q
|
||||
;
|
||||
CHKORD ; check previous order against current order
|
||||
I $D(PSBADA)!($D(PSBOTMP("ADD"))) D CHKADD Q:PSBMI=1
|
||||
I $D(PSBSOLA)!($D(PSBOTMP("SOL"))) D CHKSOL Q:PSBMI=1
|
||||
I PSBIFR'=PSBOTMP("INFUSION RATE") D MSG("INFUSION RATE",PSBOSP) Q:PSBMI=1
|
||||
I PSBMR'=PSBOTMP("MED ROUTE") D MSG("MED ROUTE",PSBOSP) Q:PSBMI=1
|
||||
I PSBSCH'=PSBOTMP("SCHEDULE") D MSG("SCHEDULE",PSBOSP) Q:PSBMI=1
|
||||
I PSBADST'=PSBOTMP("ADMIN TIME") D MSG("ADMIN TIME",PSBOSP) Q:PSBMI=1
|
||||
I PSBRMRK'=PSBOTMP("REMARKS") D MSG("REMARKS",PSBOSP) Q:PSBMI=1
|
||||
I PSBOTXT'=PSBOTMP("OTHER PRINT INFO") D MSG("OTHER PRINT INFO",PSBOSP) Q:PSBMI=1
|
||||
I PSBMD'=PSBOTMP("PROVIDER") D MSG("PROVIDER",PSBOSP) Q:PSBMI=1
|
||||
I $E(PSBOST,1,10)'=$E(PSBOTMP("START DATE/TIME"),1,10) D MSG("START DATE/TIME",PSBOSP) Q:PSBMI=1
|
||||
I $E(PSBOSP,1,10)'=$E(PSBOTMP("STOP DATE/TIME"),1,10) D MSG("STOP DATE/TIME",PSBOSP)
|
||||
Q
|
||||
CHKADD ;
|
||||
N X,Y
|
||||
I '$D(PSBADA),'$D(PSBOTMP("ADD")) Q ; no additives
|
||||
I $O(PSBADA(""),-1)>$O(PSBOTMP("ADD",""),-1) D MSG("ADDITIVE",PSBOSP) Q ;previous order has addtives not in current order
|
||||
I $O(PSBADA(""),-1)<$O(PSBOTMP("ADD",""),-1) D MSG("ADDITIVE",PSBOSP) Q ;previous order missing additives in current order
|
||||
S X="" F S X=$O(PSBADA(X)) Q:X="" D Q ; check that additives, strength, and bottle are the same
|
||||
.I PSBADA(X)=PSBOTMP("ADD",X) Q ; everything the same
|
||||
.I $P(PSBADA(X),U,2)'=$P(PSBOTMP("ADD",X),U,2) D MSG("ADDITIVE",PSBOSP) Q
|
||||
.I $P(PSBADA(X),U,4)'=$P(PSBOTMP("ADD",X),U,4) D MSG("STRENGTH",PSBOSP) Q
|
||||
Q
|
||||
;
|
||||
CHKSOL ;
|
||||
N X,Y
|
||||
I '$D(PSBSOLA),'$D(PSBOTMP("SOL")) Q ; no solutions
|
||||
I $O(PSBSOLA(""),-1)>$O(PSBOTMP("SOL",""),-1) D MSG("SOLUTION",PSBOSP) Q ;previous order has solutions not in current order
|
||||
I $O(PSBSOLA(""),-1)<$O(PSBOTMP("SOL",""),-1) D MSG("SOLUTION",PSBOSP) Q ;previous order missing solutions in current order
|
||||
S X="" F S X=$O(PSBSOLA(X)) Q:X="" D Q ; check that solutions volume are the same
|
||||
.I PSBSOLA(X)=PSBOTMP("SOL",X) Q ; everything the same
|
||||
.I $P(PSBSOLA(X),U,2)'=$P(PSBOTMP("SOL",X),U,2) D MSG("SOLUTION",PSBOSP) Q
|
||||
.I $P(PSBSOLA(X),U,4)'=$P(PSBOTMP("SOL",X),U,4) D MSG("VOLUME",PSBOSP) Q
|
||||
Q
|
||||
;
|
||||
BWAR ;
|
||||
N X,Y,Z,PSBONX
|
||||
S X=^TMP("PSBAR",$J,"W",0)+1
|
||||
S Z="" F Z=1:1 S PSBONX=$P(PSBONXS,U,Z) Q:$G(PSBONX)="" D ; Display "Warning"s for changes
|
||||
.I '$D(PSBMWAR(PSBONX)) Q
|
||||
.S Y="" F S Y=$O(PSBMWAR(PSBONX,Y)) Q:Y'?.N1".".N D
|
||||
..S Z="",PSBYS="" F S Z=$O(PSBMWAR(PSBONX,Y,Z)) Q:Z="" S PSBYS=PSBYS_Z_";"
|
||||
..S PSBYS=$P(PSBYS,";",1,$L(PSBYS,";")-1)
|
||||
..S ^TMP("PSBAR",$J,"W",X)=PSBONX_U_Y_U_"2^The "_PSBYS_" was changed on",^TMP("PSBAR",$J,"W",0)=X,X=X+1
|
||||
.K PSBMWAR(PSBONX)
|
||||
Q
|
||||
;
|
||||
MSG(PSBMVAR,PSBDATE) ;
|
||||
I PSBMI=1 Q ;already have an invalid don't need anymore
|
||||
F Y=1:1 S PSBSPAR=$P(PSBCSTR,U,Y) I PSBSPAR=$TR(PSBMVAR,"^") D Q
|
||||
.I $P(PSBIVPAR,U,Y)="W" D
|
||||
..S PSBMVAR=$TR(PSBMVAR,"^")
|
||||
..I PSBMW=0 S PSBMW=1
|
||||
..S PSBMWC=PSBMWC+1,PSBMWM="2^The "_PSBSPAR_" has been changed."
|
||||
..I $D(PSBMWAR(PSBONX,PSBMVAR)) S PSBOLDT=$O(PSBMWAR(PSBONX,PSBMVAR,"")) I PSBOLDT<$E(PSBDATE,1,12) K PSBMWAR(PSBONX,PSBMVAR,PSBOLDT)
|
||||
..S PSBMWAR(PSBONX,PSBMVAR,$E(PSBDATE,1,12))=""
|
||||
..S PSBMWAR(PSBONX,$E(PSBDATE,1,12),PSBMVAR)=""
|
||||
.I $P(PSBIVPAR,U,Y)="I" S PSBMI=1,PSBMIDT=PSBDATE,PSBMIM="-1^IV invalid "_PSBSPAR_".",^TMP("PSBAR",$J,"I")=PSBONX_U_PSBMIDT_U_PSBMIM
|
||||
Q
|
||||
|
|
|
|||
|
|
@ -1,137 +1,137 @@
|
|||
PSBRPC2 ;BIRMINGHAM/EFC-BCMA RPC BROKER CALLS ;7:42 PM 30 Jan 2008
|
||||
;;3.0;BAR CODE MED ADMIN;**6,3,16,32,WVEHR1**;WorldVistA 30-Jan-08;Build 4
|
||||
;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified.
|
||||
;
|
||||
;Modified from FOIA VISTA,
|
||||
;Copyright 2008 WorldVistA. Licensed under the terms of the GNU
|
||||
;General Public License See attached copy of the License.
|
||||
;
|
||||
;This program is free software; you can redistribute it and/or modify
|
||||
;it under the terms of the GNU General Public License as published by
|
||||
;the Free Software Foundation; either version 2 of the License, or
|
||||
;(at your option) any later version.
|
||||
;
|
||||
;This program is distributed in the hope that it will be useful,
|
||||
;but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;GNU General Public License for more details.
|
||||
;
|
||||
;You should have received a copy of the GNU General Public License along
|
||||
;with this program; if not, write to the Free Software Foundation, Inc.,
|
||||
;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
|
||||
;
|
||||
; Reference/IA
|
||||
; File 50/221
|
||||
; File 52.6/436
|
||||
; File 52.7/437
|
||||
; File 200/10060
|
||||
GETOHIST(RESULTS,DFN,PSBORD) ;
|
||||
S RESULTS=$NAME(^TMP("PSB",$J)),PSB=0 K ^TMP("PSB",$J)
|
||||
S ^TMP("PSB",$J,0)=1,^TMP("PSB",$J,1)="-1^No History On File"
|
||||
D NOW^%DTC S PSBNOW=$P(%,".",1),PSBNOWZ=%
|
||||
D EN^PSBPOIV(DFN,PSBORD)
|
||||
S PSBUID=DFN_"V"_99999 F S PSBUID=$O(^TMP("PSBAR",$J,PSBUID),-1) Q:PSBUID="" D
|
||||
.S PSBUIDS=^TMP("PSBAR",$J,PSBUID)
|
||||
.I ((PSBOSTS="D")!(PSBOSTS="E")),$P(PSBUIDS,U,2)'="I",$P(PSBUIDS,U,2)'="S" Q ; only want the infusing bag on a dc'ed order
|
||||
.I (PSBOSTS="A"),(PSBOSP<PSBNOWZ),$P(PSBUIDS,U,2)'="I",$P(PSBUIDS,U,2)'="S" S PSBOSTS="E" Q ; only want the infusing bag on an expired order
|
||||
.I $P(PSBUIDS,U,2)'="" D Q ; get orders from med log (53.79)
|
||||
..S PSBMLOR=$P(PSBUIDS,U,4),PSBIEN=$O(^PSB(53.79,"AUID",DFN,PSBMLOR,PSBUID,""))
|
||||
..S PSBLADT=$P(^PSB(53.79,PSBIEN,0),U,6)
|
||||
..S PSBLASTS=$P(^PSB(53.79,PSBIEN,0),U,9)
|
||||
..I PSBLASTS="M",$P(PSBUIDS,U,8)'="" Q
|
||||
..S PSBINJS=$P(^PSB(53.79,PSBIEN,.1),U,6)
|
||||
..S PSB=PSB+1,^TMP("PSB",$J,PSB)=PSBORD_U_PSBUID_U_PSBIEN_U_PSBLADT_U_PSBLASTS_U_PSBINJS
|
||||
..F PSBL=1:1 Q:'$D(^PSB(53.79,PSBIEN,.6,PSBL,0)) S PSB=PSB+1,^TMP("PSB",$J,PSB)="ADD^"_^PSB(53.79,PSBIEN,.6,PSBL,0)
|
||||
..F PSBL=1:1 Q:'$D(^PSB(53.79,PSBIEN,.7,PSBL,0)) S PSB=PSB+1,^TMP("PSB",$J,PSB)="SOL^"_^PSB(53.79,PSBIEN,.7,PSBL,0)
|
||||
..S PSB=PSB+1,^TMP("PSB",$J,PSB)="END"
|
||||
.I $P(PSBUIDS,U,1)="I" Q ; IV parameters say bag is invalid
|
||||
.I $P(PSBUIDS,U,8)'="",$P(PSBUIDS,U,2)'="I",$P(PSBUIDS,U,2)'="S" Q ; label has been reprinted/distroyed etc. - bag is not infusing or stopped
|
||||
.S PSB=PSB+1,^TMP("PSB",$J,PSB)=$P(PSBUIDS,U,5)_U_PSBUID_U_U_PSBNOW_U_"A"
|
||||
.S PSBUIDP=$P(PSBUIDS,U,10,999)
|
||||
.F Y=3:1 S PSBMEDTY=$P(PSBUIDP,U,Y) Q:PSBMEDTY="" D
|
||||
..D CLEAN^PSBVT,PSJ1^PSBVT(DFN,$P(PSBUIDS,U,5))
|
||||
..I $P(PSBMEDTY,";",1)="ADD" F Z=1:1 S PSBAD=$G(PSBADA(Z)) Q:PSBAD="" I $P(PSBADA(Z),U,2)=$P(PSBMEDTY,";",2) S PSB=PSB+1,^TMP("PSB",$J,PSB)=PSBADA(Z) Q
|
||||
..I $P(PSBMEDTY,";",1)="SOL" F Z=1:1 S PSBSOL=$G(PSBSOLA(Z)) Q:PSBSOL="" I $P(PSBSOLA(Z),U,2)=$P(PSBMEDTY,";",2) S PSB=PSB+1,^TMP("PSB",$J,PSB)=PSBSOLA(Z) Q
|
||||
.D CLEAN^PSBVT,PSJ1^PSBVT(DFN,PSBORD)
|
||||
.S PSB=PSB+1,^TMP("PSB",$J,PSB)="END"
|
||||
F II=1:1 S I=$P(PSBONXS,U,II) Q:I="" D ; get ward stocks
|
||||
.S PSBUID="" F S PSBUID=$O(^PSB(53.79,"AUID",DFN,I,PSBUID)) Q:PSBUID="" D
|
||||
..I PSBUID'["WS" Q ; not a ward stock
|
||||
..S PSBIEN=$O(^PSB(53.79,"AUID",DFN,I,PSBUID,""))
|
||||
..S PSBLADT=$P(^PSB(53.79,PSBIEN,0),U,6)
|
||||
..S PSBLASTS=$P(^PSB(53.79,PSBIEN,0),U,9)
|
||||
..I PSBOSTS="D",PSBLASTS'="I",PSBLASTS'="S" Q ; want "not completed" on DC'ed orders
|
||||
..I (PSBOSTS="A"),(PSBOSP<PSBNOWZ),PSBLASTS'="I",PSBLASTS'="S" Q
|
||||
..S PSBINJS=$P(^PSB(53.79,PSBIEN,.1),U,6)
|
||||
..S PSB=PSB+1,^TMP("PSB",$J,PSB)=PSBORD_U_PSBUID_U_PSBIEN_U_PSBLADT_U_PSBLASTS_U_PSBINJS
|
||||
..F PSBL=1:1 Q:'$D(^PSB(53.79,PSBIEN,.6,PSBL,0)) S PSB=PSB+1,^TMP("PSB",$J,PSB)="ADD^"_^PSB(53.79,PSBIEN,.6,PSBL,0)
|
||||
..F PSBL=1:1 Q:'$D(^PSB(53.79,PSBIEN,.7,PSBL,0)) S PSB=PSB+1,^TMP("PSB",$J,PSB)="SOL^"_^PSB(53.79,PSBIEN,.7,PSBL,0)
|
||||
..S PSB=PSB+1,^TMP("PSB",$J,PSB)="END"
|
||||
S ^TMP("PSB",$J,0)=PSB
|
||||
K ^TMP("PSBAR",$J)
|
||||
Q
|
||||
;
|
||||
BAGDTL(RESULTS,PSBUID,PSBORD) ; bag detail
|
||||
I $G(DFN)="" S DFN=+PSBUID
|
||||
S (PSBIEN,X)="" F S X=$O(^PSB(53.79,"AUID",DFN,X)) Q:X="" S:$D(^PSB(53.79,"AUID",DFN,X,PSBUID)) PSBIEN=$O(^PSB(53.79,"AUID",DFN,X,PSBUID,"")) Q:PSBIEN]""
|
||||
I PSBIEN'>0 S RESULTS(0)=1,RESULTS(1)="-1^No History On File" Q
|
||||
M PSBMLA=^PSB(53.79,PSBIEN)
|
||||
S X=$P(^PSB(53.79,PSBIEN,0),U,9)
|
||||
S PSBLAC=$S(X="I":"INFUSING",X="G":"GIVEN",X="C":"COMPLETE",X="H":"HELD",X="R":"REFUSED",X="RM":"REMOVED",X="S":"STOPPED",X="M":"MISSING",1:"NO ACTION")
|
||||
; comments
|
||||
S PSBX="0" F S PSBX=$O(PSBMLA(.3,PSBX)) Q:PSBX="" S PSBTMP(10000000-$P(PSBMLA(.3,PSBX,0),U,3),"C")=$P(PSBMLA(.3,PSBX,0),U,3)_U_$$INITIAL($P(PSBMLA(.3,PSBX,0),U,2))_U_U_$P(PSBMLA(.3,PSBX,0),U,1)
|
||||
; audit
|
||||
S PSBGA="" I $D(PSBMLA(.9,0)) D
|
||||
.S PSBX="0" F S PSBX=$O(PSBMLA(.9,PSBX)) Q:PSBX="" I ((PSBMLA(.9,PSBX,0)["ACTION STATUS")!(PSBMLA(.9,PSBX,0)["ADMINISTRATION STATUS")) D Q
|
||||
..S PSBDATE=$P(PSBMLA(0),U,4) I (PSBX-2)>0 D DT^DILF("ENPST",$P(PSBMLA(.9,PSBX-2,0),"'",2),.PSBDATE)
|
||||
..S PSBTMP(10000000-PSBDATE,"B")=PSBDATE_U_$$INITIAL($P(PSBMLA(0),U,5))_U_$P(PSBMLA(.9,PSBX,0),"'",2)
|
||||
..S PSBGA=1
|
||||
.S PSBX="0" F S PSBX=$O(PSBMLA(.9,PSBX)) Q:PSBX="" I ((PSBMLA(.9,PSBX,0)["ACTION STATUS")!(PSBMLA(.9,PSBX,0)["ADMINISTRATION STATUS")) D
|
||||
..S PSBTMP(10000000-$P(PSBMLA(.9,PSBX,0),U,1),"B")=$P(PSBMLA(.9,PSBX,0),U,1)_U_$$INITIAL($P(PSBMLA(.9,PSBX,0),U,2))_U_$P($P(PSBMLA(.9,PSBX,0),U,3),"'",2)
|
||||
..S PSBGA=1
|
||||
I PSBGA'=1 S PSBTMP(10000000-$P(PSBMLA(0),U,6),"A")=$P(PSBMLA(0),U,6)_U_$$INITIAL($P(PSBMLA(0),U,7))_U_PSBLAC
|
||||
S PSBQRY="PSBTMP",PSBCNT=1 F S PSBQRY=$Q(@PSBQRY) Q:PSBQRY="" D ; does comment go with action
|
||||
.S PSBPQRY=$Q(@PSBQRY,-1)
|
||||
.I PSBPQRY="" S RESULTS(PSBCNT)=@PSBQRY,PSBCNT=PSBCNT+1 Q ; no previous action
|
||||
.I $QS(PSBPQRY,2)="C" S RESULTS(PSBCNT)=@PSBQRY,PSBCNT=PSBCNT+1 Q ; previous line is a comment
|
||||
.I $QS(PSBQRY,2)="C",$E($P(@$Q(@PSBQRY,-1),U,1),1,12)=$E($P(@PSBQRY,U,1),1,12),$P(@$Q(@PSBQRY,-1),U,2)=$P(@PSBQRY,U,2) S X=$P(@PSBQRY,U,4),$P(RESULTS(PSBCNT-1),U,4)=X Q
|
||||
.S RESULTS(PSBCNT)=@PSBQRY,PSBCNT=PSBCNT+1
|
||||
S RESULTS(0)=PSBCNT-1
|
||||
K PSBMLA,PSBIEN,PSBTMP,PSBQRY
|
||||
Q
|
||||
;
|
||||
INITIAL(PSBDUZ) ;
|
||||
Q $$GET1^DIQ(200,PSBDUZ,"INITIAL")
|
||||
SCANMED(RESULTS,PSBDIEN,PSBTAB) ; Lookup Medication
|
||||
;
|
||||
; RPC: PSB SCANMED
|
||||
;
|
||||
; Description:
|
||||
; Does a lookup on file 50 returns -1 on invalid lookup or
|
||||
; IEN^DrugName on success
|
||||
;
|
||||
D NOW^%DTC S PSBDT=%
|
||||
S PSBCNT=0
|
||||
I $L(PSBDIEN)>40 S PSBDIEN=$E(PSBDIEN,1,40)
|
||||
S RESULTS(PSBCNT)=1
|
||||
S PSBCNT=PSBCNT+1,RESULTS(PSBCNT)="-1^Invalid Medication Lookup"
|
||||
I $$GET^XPAR("DIV","PSB ROBOT RX"),PSBDIEN?1"3"15N!(PSBDIEN?1"3"17N),123[$E(PSBDIEN,12) S PSBDIEN=$E(PSBDIEN,2,11)
|
||||
I PSBTAB="UDTAB" D Q
|
||||
.S X=$$FIND1^DIC(50,"","AX",PSBDIEN,"B^C")
|
||||
.I X<1 Q
|
||||
.E S RESULTS(PSBCNT)="DD"_U_X_U_$$GET1^DIQ(50,X_",",.01)
|
||||
;
|
||||
; IV/IVPB ward stock scan
|
||||
;
|
||||
S PSBDIEN=$$FIND1^DIC(50,"","AX",PSBDIEN,"B^C") I PSBDIEN<1 Q
|
||||
S PSBOIT=$$GET1^DIQ(50,PSBDIEN,"PHARMACY ORDERABLE ITEM","I")
|
||||
I $D(^PSDRUG("A527",PSBDIEN)) S X="" F S X=$O(^PSDRUG("A527",PSBDIEN,X)) Q:X="" D
|
||||
.S PSBINACT=$$GET1^DIQ(52.7,X,8,"I") I PSBINACT]"",PSBINACT'>PSBDT Q
|
||||
.S RESULTS(PSBCNT)="SOL"_U_X_U_$$GET1^DIQ(50,PSBDIEN_",",.01),PSBCNT=PSBCNT+1,RESULTS(0)=PSBCNT-1
|
||||
I $D(^PSDRUG("A526",PSBDIEN)) S X="" F S X=$O(^PSDRUG("A526",PSBDIEN,X)) Q:X="" D
|
||||
.S PSBINACT=$$GET1^DIQ(52.6,X,12,"I") I PSBINACT]"",PSBINACT'>PSBDT Q
|
||||
.S RESULTS(PSBCNT)="ADD"_U_X_U_$$GET1^DIQ(50,PSBDIEN_",",.01),PSBCNT=PSBCNT+1,RESULTS(0)=PSBCNT-1
|
||||
;
|
||||
I PSBTAB="PBTAB",$$FIND1^DIC(50,"","AX",PSBDIEN,"B^C")'<1 S X=$$FIND1^DIC(50,"","AX",PSBDIEN,"B^C"),RESULTS(PSBCNT)="DD"_U_X_U_$$GET1^DIQ(50,X_",",.01),PSBCNT=PSBCNT+1,RESULTS(0)=PSBCNT-1
|
||||
Q
|
||||
;
|
||||
PSBRPC2 ;BIRMINGHAM/EFC-BCMA RPC BROKER CALLS ;7:42 PM 30 Jan 2008
|
||||
;;3.0;BAR CODE MED ADMIN;**6,3,16,32,WVEHR1**;WorldVistA 30-Jan-08
|
||||
;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified.
|
||||
;
|
||||
;Modified from FOIA VISTA,
|
||||
;Copyright 2008 WorldVistA. Licensed under the terms of the GNU
|
||||
;General Public License See attached copy of the License.
|
||||
;
|
||||
;This program is free software; you can redistribute it and/or modify
|
||||
;it under the terms of the GNU General Public License as published by
|
||||
;the Free Software Foundation; either version 2 of the License, or
|
||||
;(at your option) any later version.
|
||||
;
|
||||
;This program is distributed in the hope that it will be useful,
|
||||
;but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;GNU General Public License for more details.
|
||||
;
|
||||
;You should have received a copy of the GNU General Public License along
|
||||
;with this program; if not, write to the Free Software Foundation, Inc.,
|
||||
;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
|
||||
;
|
||||
; Reference/IA
|
||||
; File 50/221
|
||||
; File 52.6/436
|
||||
; File 52.7/437
|
||||
; File 200/10060
|
||||
GETOHIST(RESULTS,DFN,PSBORD) ;
|
||||
S RESULTS=$NAME(^TMP("PSB",$J)),PSB=0 K ^TMP("PSB",$J)
|
||||
S ^TMP("PSB",$J,0)=1,^TMP("PSB",$J,1)="-1^No History On File"
|
||||
D NOW^%DTC S PSBNOW=$P(%,".",1),PSBNOWZ=%
|
||||
D EN^PSBPOIV(DFN,PSBORD)
|
||||
S PSBUID=DFN_"V"_99999 F S PSBUID=$O(^TMP("PSBAR",$J,PSBUID),-1) Q:PSBUID="" D
|
||||
.S PSBUIDS=^TMP("PSBAR",$J,PSBUID)
|
||||
.I ((PSBOSTS="D")!(PSBOSTS="E")),$P(PSBUIDS,U,2)'="I",$P(PSBUIDS,U,2)'="S" Q ; only want the infusing bag on a dc'ed order
|
||||
.I (PSBOSTS="A"),(PSBOSP<PSBNOWZ),$P(PSBUIDS,U,2)'="I",$P(PSBUIDS,U,2)'="S" S PSBOSTS="E" Q ; only want the infusing bag on an expired order
|
||||
.I $P(PSBUIDS,U,2)'="" D Q ; get orders from med log (53.79)
|
||||
..S PSBMLOR=$P(PSBUIDS,U,4),PSBIEN=$O(^PSB(53.79,"AUID",DFN,PSBMLOR,PSBUID,""))
|
||||
..S PSBLADT=$P(^PSB(53.79,PSBIEN,0),U,6)
|
||||
..S PSBLASTS=$P(^PSB(53.79,PSBIEN,0),U,9)
|
||||
..I PSBLASTS="M",$P(PSBUIDS,U,8)'="" Q
|
||||
..S PSBINJS=$P(^PSB(53.79,PSBIEN,.1),U,6)
|
||||
..S PSB=PSB+1,^TMP("PSB",$J,PSB)=PSBORD_U_PSBUID_U_PSBIEN_U_PSBLADT_U_PSBLASTS_U_PSBINJS
|
||||
..F PSBL=1:1 Q:'$D(^PSB(53.79,PSBIEN,.6,PSBL,0)) S PSB=PSB+1,^TMP("PSB",$J,PSB)="ADD^"_^PSB(53.79,PSBIEN,.6,PSBL,0)
|
||||
..F PSBL=1:1 Q:'$D(^PSB(53.79,PSBIEN,.7,PSBL,0)) S PSB=PSB+1,^TMP("PSB",$J,PSB)="SOL^"_^PSB(53.79,PSBIEN,.7,PSBL,0)
|
||||
..S PSB=PSB+1,^TMP("PSB",$J,PSB)="END"
|
||||
.I $P(PSBUIDS,U,1)="I" Q ; IV parameters say bag is invalid
|
||||
.I $P(PSBUIDS,U,8)'="",$P(PSBUIDS,U,2)'="I",$P(PSBUIDS,U,2)'="S" Q ; label has been reprinted/distroyed etc. - bag is not infusing or stopped
|
||||
.S PSB=PSB+1,^TMP("PSB",$J,PSB)=$P(PSBUIDS,U,5)_U_PSBUID_U_U_PSBNOW_U_"A"
|
||||
.S PSBUIDP=$P(PSBUIDS,U,10,999)
|
||||
.F Y=3:1 S PSBMEDTY=$P(PSBUIDP,U,Y) Q:PSBMEDTY="" D
|
||||
..D CLEAN^PSBVT,PSJ1^PSBVT(DFN,$P(PSBUIDS,U,5))
|
||||
..I $P(PSBMEDTY,";",1)="ADD" F Z=1:1 S PSBAD=$G(PSBADA(Z)) Q:PSBAD="" I $P(PSBADA(Z),U,2)=$P(PSBMEDTY,";",2) S PSB=PSB+1,^TMP("PSB",$J,PSB)=PSBADA(Z) Q
|
||||
..I $P(PSBMEDTY,";",1)="SOL" F Z=1:1 S PSBSOL=$G(PSBSOLA(Z)) Q:PSBSOL="" I $P(PSBSOLA(Z),U,2)=$P(PSBMEDTY,";",2) S PSB=PSB+1,^TMP("PSB",$J,PSB)=PSBSOLA(Z) Q
|
||||
.D CLEAN^PSBVT,PSJ1^PSBVT(DFN,PSBORD)
|
||||
.S PSB=PSB+1,^TMP("PSB",$J,PSB)="END"
|
||||
F II=1:1 S I=$P(PSBONXS,U,II) Q:I="" D ; get ward stocks
|
||||
.S PSBUID="" F S PSBUID=$O(^PSB(53.79,"AUID",DFN,I,PSBUID)) Q:PSBUID="" D
|
||||
..I PSBUID'["WS" Q ; not a ward stock
|
||||
..S PSBIEN=$O(^PSB(53.79,"AUID",DFN,I,PSBUID,""))
|
||||
..S PSBLADT=$P(^PSB(53.79,PSBIEN,0),U,6)
|
||||
..S PSBLASTS=$P(^PSB(53.79,PSBIEN,0),U,9)
|
||||
..I PSBOSTS="D",PSBLASTS'="I",PSBLASTS'="S" Q ; want "not completed" on DC'ed orders
|
||||
..I (PSBOSTS="A"),(PSBOSP<PSBNOWZ),PSBLASTS'="I",PSBLASTS'="S" Q
|
||||
..S PSBINJS=$P(^PSB(53.79,PSBIEN,.1),U,6)
|
||||
..S PSB=PSB+1,^TMP("PSB",$J,PSB)=PSBORD_U_PSBUID_U_PSBIEN_U_PSBLADT_U_PSBLASTS_U_PSBINJS
|
||||
..F PSBL=1:1 Q:'$D(^PSB(53.79,PSBIEN,.6,PSBL,0)) S PSB=PSB+1,^TMP("PSB",$J,PSB)="ADD^"_^PSB(53.79,PSBIEN,.6,PSBL,0)
|
||||
..F PSBL=1:1 Q:'$D(^PSB(53.79,PSBIEN,.7,PSBL,0)) S PSB=PSB+1,^TMP("PSB",$J,PSB)="SOL^"_^PSB(53.79,PSBIEN,.7,PSBL,0)
|
||||
..S PSB=PSB+1,^TMP("PSB",$J,PSB)="END"
|
||||
S ^TMP("PSB",$J,0)=PSB
|
||||
K ^TMP("PSBAR",$J)
|
||||
Q
|
||||
;
|
||||
BAGDTL(RESULTS,PSBUID,PSBORD) ; bag detail
|
||||
I $G(DFN)="" S DFN=+PSBUID
|
||||
S (PSBIEN,X)="" F S X=$O(^PSB(53.79,"AUID",DFN,X)) Q:X="" S:$D(^PSB(53.79,"AUID",DFN,X,PSBUID)) PSBIEN=$O(^PSB(53.79,"AUID",DFN,X,PSBUID,"")) Q:PSBIEN]""
|
||||
I PSBIEN'>0 S RESULTS(0)=1,RESULTS(1)="-1^No History On File" Q
|
||||
M PSBMLA=^PSB(53.79,PSBIEN)
|
||||
S X=$P(^PSB(53.79,PSBIEN,0),U,9)
|
||||
S PSBLAC=$S(X="I":"INFUSING",X="G":"GIVEN",X="C":"COMPLETE",X="H":"HELD",X="R":"REFUSED",X="RM":"REMOVED",X="S":"STOPPED",X="M":"MISSING",1:"NO ACTION")
|
||||
; comments
|
||||
S PSBX="0" F S PSBX=$O(PSBMLA(.3,PSBX)) Q:PSBX="" S PSBTMP(10000000-$P(PSBMLA(.3,PSBX,0),U,3),"C")=$P(PSBMLA(.3,PSBX,0),U,3)_U_$$INITIAL($P(PSBMLA(.3,PSBX,0),U,2))_U_U_$P(PSBMLA(.3,PSBX,0),U,1)
|
||||
; audit
|
||||
S PSBGA="" I $D(PSBMLA(.9,0)) D
|
||||
.S PSBX="0" F S PSBX=$O(PSBMLA(.9,PSBX)) Q:PSBX="" I ((PSBMLA(.9,PSBX,0)["ACTION STATUS")!(PSBMLA(.9,PSBX,0)["ADMINISTRATION STATUS")) D Q
|
||||
..S PSBDATE=$P(PSBMLA(0),U,4) I (PSBX-2)>0 D DT^DILF("ENPST",$P(PSBMLA(.9,PSBX-2,0),"'",2),.PSBDATE)
|
||||
..S PSBTMP(10000000-PSBDATE,"B")=PSBDATE_U_$$INITIAL($P(PSBMLA(0),U,5))_U_$P(PSBMLA(.9,PSBX,0),"'",2)
|
||||
..S PSBGA=1
|
||||
.S PSBX="0" F S PSBX=$O(PSBMLA(.9,PSBX)) Q:PSBX="" I ((PSBMLA(.9,PSBX,0)["ACTION STATUS")!(PSBMLA(.9,PSBX,0)["ADMINISTRATION STATUS")) D
|
||||
..S PSBTMP(10000000-$P(PSBMLA(.9,PSBX,0),U,1),"B")=$P(PSBMLA(.9,PSBX,0),U,1)_U_$$INITIAL($P(PSBMLA(.9,PSBX,0),U,2))_U_$P($P(PSBMLA(.9,PSBX,0),U,3),"'",2)
|
||||
..S PSBGA=1
|
||||
I PSBGA'=1 S PSBTMP(10000000-$P(PSBMLA(0),U,6),"A")=$P(PSBMLA(0),U,6)_U_$$INITIAL($P(PSBMLA(0),U,7))_U_PSBLAC
|
||||
S PSBQRY="PSBTMP",PSBCNT=1 F S PSBQRY=$Q(@PSBQRY) Q:PSBQRY="" D ; does comment go with action
|
||||
.S PSBPQRY=$Q(@PSBQRY,-1)
|
||||
.I PSBPQRY="" S RESULTS(PSBCNT)=@PSBQRY,PSBCNT=PSBCNT+1 Q ; no previous action
|
||||
.I $QS(PSBPQRY,2)="C" S RESULTS(PSBCNT)=@PSBQRY,PSBCNT=PSBCNT+1 Q ; previous line is a comment
|
||||
.I $QS(PSBQRY,2)="C",$E($P(@$Q(@PSBQRY,-1),U,1),1,12)=$E($P(@PSBQRY,U,1),1,12),$P(@$Q(@PSBQRY,-1),U,2)=$P(@PSBQRY,U,2) S X=$P(@PSBQRY,U,4),$P(RESULTS(PSBCNT-1),U,4)=X Q
|
||||
.S RESULTS(PSBCNT)=@PSBQRY,PSBCNT=PSBCNT+1
|
||||
S RESULTS(0)=PSBCNT-1
|
||||
K PSBMLA,PSBIEN,PSBTMP,PSBQRY
|
||||
Q
|
||||
;
|
||||
INITIAL(PSBDUZ) ;
|
||||
Q $$GET1^DIQ(200,PSBDUZ,"INITIAL")
|
||||
SCANMED(RESULTS,PSBDIEN,PSBTAB) ; Lookup Medication
|
||||
;
|
||||
; RPC: PSB SCANMED
|
||||
;
|
||||
; Description:
|
||||
; Does a lookup on file 50 returns -1 on invalid lookup or
|
||||
; IEN^DrugName on success
|
||||
;
|
||||
D NOW^%DTC S PSBDT=%
|
||||
S PSBCNT=0
|
||||
I $L(PSBDIEN)>40 S PSBDIEN=$E(PSBDIEN,1,40)
|
||||
S RESULTS(PSBCNT)=1
|
||||
S PSBCNT=PSBCNT+1,RESULTS(PSBCNT)="-1^Invalid Medication Lookup"
|
||||
I $$GET^XPAR("DIV","PSB ROBOT RX"),PSBDIEN?1"3"15N!(PSBDIEN?1"3"17N),123[$E(PSBDIEN,12) S PSBDIEN=$E(PSBDIEN,2,11)
|
||||
I PSBTAB="UDTAB" D Q
|
||||
.S X=$$FIND1^DIC(50,"","AX",PSBDIEN,"B^C")
|
||||
.I X<1 Q
|
||||
.E S RESULTS(PSBCNT)="DD"_U_X_U_$$GET1^DIQ(50,X_",",.01)
|
||||
;
|
||||
; IV/IVPB ward stock scan
|
||||
;
|
||||
S PSBDIEN=$$FIND1^DIC(50,"","AX",PSBDIEN,"B^C") I PSBDIEN<1 Q
|
||||
S PSBOIT=$$GET1^DIQ(50,PSBDIEN,"PHARMACY ORDERABLE ITEM","I")
|
||||
I $D(^PSDRUG("A527",PSBDIEN)) S X="" F S X=$O(^PSDRUG("A527",PSBDIEN,X)) Q:X="" D
|
||||
.S PSBINACT=$$GET1^DIQ(52.7,X,8,"I") I PSBINACT]"",PSBINACT'>PSBDT Q
|
||||
.S RESULTS(PSBCNT)="SOL"_U_X_U_$$GET1^DIQ(50,PSBDIEN_",",.01),PSBCNT=PSBCNT+1,RESULTS(0)=PSBCNT-1
|
||||
I $D(^PSDRUG("A526",PSBDIEN)) S X="" F S X=$O(^PSDRUG("A526",PSBDIEN,X)) Q:X="" D
|
||||
.S PSBINACT=$$GET1^DIQ(52.6,X,12,"I") I PSBINACT]"",PSBINACT'>PSBDT Q
|
||||
.S RESULTS(PSBCNT)="ADD"_U_X_U_$$GET1^DIQ(50,PSBDIEN_",",.01),PSBCNT=PSBCNT+1,RESULTS(0)=PSBCNT-1
|
||||
;
|
||||
I PSBTAB="PBTAB",$$FIND1^DIC(50,"","AX",PSBDIEN,"B^C")'<1 S X=$$FIND1^DIC(50,"","AX",PSBDIEN,"B^C"),RESULTS(PSBCNT)="DD"_U_X_U_$$GET1^DIQ(50,X_",",.01),PSBCNT=PSBCNT+1,RESULTS(0)=PSBCNT-1
|
||||
Q
|
||||
;
|
||||
|
|
|
|||
|
|
@ -1,58 +1,58 @@
|
|||
DGBTCE ;ALB/SCK - BENEFICIARY TRAVEL CLAIM RE-ENTER/EDIT; 12/15/92 06/04/93
|
||||
;;1.0;Beneficiary Travel;**2,14**;September 25, 2001;Build 7
|
||||
Q
|
||||
SCREEN ;
|
||||
D QUIT^DGBTCE1
|
||||
D SCREEN^DGBTEE1 Q:'$D(^DGBT(392,DGBTDT,0)) I DGBTTOUT=-1 S DGBTTOUT=1 Q
|
||||
I $D(DGBTOACT) I DGBTOACT'=DGBTACCT S DGBTVAR(0)=^DGBT(392,DGBTDT,0) D FILE
|
||||
S (DGBTMAL,DGBTFAB,DGBTME,DGBTCP,DGBTFLAG,DGBTDE,DGBTDCV,DGBTDCM,DGBTDPV,DGBTDPM)=0
|
||||
S:$G(DGBTACCT)'>0 DGBTACCT=$P($G(DGBTVAR(0)),U,6)
|
||||
S DGBTAP=VADM(1),DIE="^DGBT(392,",DA=DGBTDT,DR=$S(DGBTACCT=4:"42//"_DGBTAP,DGBTACCT=5:"43;S DGBTCP=X;42//"_DGBTAP,1:"44")
|
||||
D ^DIE K DIE,DQ,DR I $D(DTOUT)!($D(Y)) S DGBTTOUT=1 Q
|
||||
I DGBTACCT=4!(DGBTACCT=5) S:$D(^DGBT(392,DGBTDT,"M")) DGBTWAY=$P(^("M"),"^"),DGBTMILE=$P(^("M"),"^",2) S:$D(^DGBT(392,DGBTDT,"D")) DGBTCITY=$P(^("D"),"^",4),DGBTSTAT=$P(^("D"),"^",5)
|
||||
S DGBTDIV=$P($G(^DGBT(392,DA,0)),U,11),DGBTRMK=$S($D(DGBTREC):$$DICLKUP^DGBTUTL(DGBTREC,DGBTDIV,4),1:"")
|
||||
S DIE="^DGBT(392,",DA=DGBTDT
|
||||
S DR="3////"_DGBTELIG_";6////"_DGBTACTN_";21;I X="""" S Y=24;22;I X="""" S Y=24;23;24;24.1;24.2;25;I X="""" S Y=28;26;I X="""" S Y=28;27;28;28.1;28.2"
|
||||
D ^DIE K DIE I $D(DTOUT)!($D(Y)) S DGBTTOUT=1 Q
|
||||
W:DGBTRMK]"" !!,*7,"MILEAGE REMARKS: ",DGBTRMK,!
|
||||
I DGBTACCT=4!(DGBTACCT=5) D Q:$G(DGBTTOUT)
|
||||
. S DR="31//;S DGBTOWRT=X;32//;S DGBTML=X"
|
||||
. I DGBTACCT=5&(DGBTCP=1) S DGBTMR=DGBTMR1
|
||||
. S DIE="^DGBT(392,",DA=DGBTDT
|
||||
. D ^DIE K DIE,DQ,DR I $D(DTOUT)!($D(Y)) S DGBTTOUT=1
|
||||
DIE1 ;
|
||||
S DGBTMLT=$S($D(DGBTVAR("M"))&((DGBTACCT=4)!(DGBTACCT=5)):$J((DGBTOWRT*DGBTML*DGBTMR),0,2),1:""),$P(^DGBT(392,DGBTDT,"M"),"^",3)=DGBTMLT,$P(DGBTVAR("M"),"^",3)=DGBTMLT
|
||||
;
|
||||
S DIE="^DGBT(392,",DA=DGBTDT
|
||||
I 'DGBTCORE D
|
||||
. S DR="I DGBTACCT=4!(DGBTACCT=5) S Y=""@1"";41;7;@1;I DGBTMLFB=0 S Y=""@2"";34//;S DGBTMAL=X;35//;S DGBTFAB=X;@2;8//;S DGBTME=X"
|
||||
I DGBTCORE S DR="" D
|
||||
. S DR(1,392,1)="I DGBTACCT=4!(DGBTACCT=5) S Y=""@1"";41;@3;14;S DGBTCSL=$$AFTER^DGBTCSL(392,D0,X,$G(DGBTPRV)) S:DGBTCSL<1 Y=""@3"" W:DGBTCSL<1 "" Required"" K DGBTPRV,DGBTCSL;"
|
||||
. S DR(1,392,2)="@1;I DGBTMLFB=0 S Y=""@2"";34//;S DGBTMAL=X;35//;S DGBTFAB=X;@2;8//;S DGBTME=X"
|
||||
DIE3 ;
|
||||
D ^DIE K DIE,DQ,DR I $D(DTOUT)!($D(Y)) S DGBTTOUT=1 Q
|
||||
;
|
||||
TCOST ;CALCULATE TOTAL COST AND MONTHLY CUM. DEDUCTIBLE
|
||||
MLFB ;
|
||||
S DGBTMAF=$S(DGBTMLFB:DGBTMAL+DGBTFAB,1:0),DGBTMETC=DGBTME+$S($D(DGBTMAL):DGBTMAL,1:0)
|
||||
I DGBTACCT'=4&(DGBTACCT'=5) S DGBTPA=DGBTMAF+DGBTME G CONT
|
||||
I $D(DGBTMLT) S DGBTTC=$S(DGBTMLT+DGBTMAF'>DGBTMETC:DGBTMLT+DGBTMAF,DGBTMLT+DGBTMAF>DGBTMETC&(DGBTME>0):DGBTMETC,DGBTME'>0:DGBTMLT+DGBTMAF,1:DGBTMETC)
|
||||
I DGBTACCT=5 S DGBTDE=0 S DGBTPA=$S((DGBTMLT+DGBTMAF)'=0:DGBTTC,1:DGBTMETC) G CONT
|
||||
DED ;
|
||||
F I=$E(DGBTDT,1,5)_"00.2399":0 S I=$O(^DGBT(392,"C",DFN,I)) Q:'I!($E(I,1,5)>$E(DGBTDT,1,5)) I I'=DGBTDT S DGBTDCM=DGBTDCM+($P(^DGBT(392,I,0),"^",9))
|
||||
I $D(^DG(43.1,$O(^DG(43.1,(9999999.99999-DGBTDT))),"BT")) S DGBTRATE=^("BT"),DGBTDPV=$P(DGBTRATE,"^"),DGBTDPM=$P(DGBTRATE,"^",2),DGBTMR=$P(DGBTRATE,"^",3)
|
||||
I $D(^DGBT(392,DGBTDT,"M")) S:$P(^("M"),"^")=1 DGBTDPV=DGBTDPV/2 I DGBTWAY'=$P(^("M"),"^")!(DGBTMILE'=$P(^("M"),"^",2)) I $D(^DGBT(392,DGBTDT,0)) S $P(^(0),"^",9)="" K ^DGBT(392,"AD",$P(^(0),"^",2),$E(DGBTDT,2,5),DGBTDT)
|
||||
S DGBTDRM=DGBTDPM-DGBTDCM
|
||||
S DGBTDCV=$S(DGBTDCM'<DGBTDPM:0,DGBTDRM'<DGBTDPV&(DGBTTC'<DGBTDPV):DGBTDPV,DGBTDRM'<DGBTDPV&(DGBTTC'>DGBTDPV):DGBTTC,DGBTDRM'>DGBTDPV&(DGBTTC'>DGBTDRM):DGBTTC,DGBTDRM'>DGBTDPV&(DGBTTC'<DGBTDRM):DGBTDRM,1:0)
|
||||
DED1 ;
|
||||
S DR="I $P(^DGBT(392,DGBTDT,0),""^"",9)]"""" S Y=""@9"";9///"_DGBTDCV_";@9;9;S DGBTDE=X S:DGBTDE>DGBTTC DGBTDE=DGBTTC,DGBTFLAG=2 S:DGBTDE>DGBTDRM DGBTDE=DGBTDRM,DGBTFLAG=1"
|
||||
DIE4 ;
|
||||
S DIE="^DGBT(392,",DA=DGBTDT D ^DIE K DIE,DQ,DR I $D(DTOUT)!($D(Y)) S DGBTTOUT=1 Q
|
||||
CONT ;
|
||||
D CONT^DGBTCE1
|
||||
Q
|
||||
FILE ; Reset values if account changes
|
||||
S DGBTVAR(0)=$P(DGBTVAR(0),"^",1,6)_"^^0^^"_$S($L(DGBTVAR(0),"^")>10:$P(DGBTVAR(0),"^",10,$L(DGBTVAR(0),"^")),1:""),DGBTVAR("A")="^"_$P(DGBTVAR("A"),"^",2)_"^^^"_$S($L(DGBTVAR("A"),"^")>4:$P(DGBTVAR("A"),"^",5,$L(DGBTVAR("A"),"^")),1:"")
|
||||
I DGBTACCT<4 S DGBTVAR("M")="^^^"_$S($L(DGBTVAR("M"),"^")>3:$P(DGBTVAR("M"),"^",4,$L(DGBTVAR("M"),"^")),1:"")
|
||||
S ^DGBT(392,DGBTDT,0)=DGBTVAR(0),^("A")=DGBTVAR("A") S:DGBTACCT<4 ^("M")=DGBTVAR("M") S DA=DGBTDT,DIK="^DGBT(392," D IX^DIK
|
||||
Q
|
||||
DGBTCE ;ALB/SCK - BENEFICIARY TRAVEL CLAIM RE-ENTER/EDIT; 12/15/92 06/04/93
|
||||
;;1.0;Beneficiary Travel;**2**;September 25, 2001
|
||||
Q
|
||||
SCREEN ;
|
||||
D QUIT^DGBTCE1
|
||||
D SCREEN^DGBTEE1 Q:'$D(^DGBT(392,DGBTDT,0)) I DGBTTOUT=-1 S DGBTTOUT=1 Q
|
||||
I $D(DGBTOACT) I DGBTOACT'=DGBTACCT S DGBTVAR(0)=^DGBT(392,DGBTDT,0) D FILE
|
||||
S (DGBTMAL,DGBTFAB,DGBTME,DGBTCP,DGBTFLAG,DGBTDE,DGBTDCV,DGBTDCM,DGBTDPV,DGBTDPM)=0
|
||||
S:$G(DGBTACCT)'>0 DGBTACCT=$P($G(DGBTVAR(0)),U,6)
|
||||
S DGBTAP=VADM(1),DIE="^DGBT(392,",DA=DGBTDT,DR=$S(DGBTACCT=4:"42//"_DGBTAP,DGBTACCT=5:"43;S DGBTCP=X;42//"_DGBTAP,1:"44")
|
||||
D ^DIE K DIE,DQ,DR I $D(DTOUT)!($D(Y)) S DGBTTOUT=1 Q
|
||||
I DGBTACCT=4!(DGBTACCT=5) S:$D(^DGBT(392,DGBTDT,"M")) DGBTWAY=$P(^("M"),"^"),DGBTMILE=$P(^("M"),"^",2) S:$D(^DGBT(392,DGBTDT,"D")) DGBTCITY=$P(^("D"),"^",4),DGBTSTAT=$P(^("D"),"^",5)
|
||||
S DGBTDIV=$P($G(^DGBT(392,DA,0)),U,11),DGBTRMK=$S($D(DGBTREC):$$DICLKUP^DGBTUTL(DGBTREC,DGBTDIV,4),1:"")
|
||||
S DIE="^DGBT(392,",DA=DGBTDT
|
||||
S DR="3////"_DGBTELIG_";6////"_DGBTACTN_";21;I X="""" S Y=24;22;I X="""" S Y=24;23;24;24.1;24.2;25;I X="""" S Y=28;26;I X="""" S Y=28;27;28;28.1;28.2"
|
||||
D ^DIE K DIE I $D(DTOUT)!($D(Y)) S DGBTTOUT=1 Q
|
||||
W:DGBTRMK]"" !!,*7,"MILEAGE REMARKS: ",DGBTRMK,!
|
||||
I DGBTACCT=4!(DGBTACCT=5) D Q:$G(DGBTTOUT)
|
||||
. S DR="31//;S DGBTOWRT=X;32//;S DGBTML=X"
|
||||
. I DGBTACCT=5&(DGBTCP=1) S DGBTMR=DGBTMR1
|
||||
. S DIE="^DGBT(392,",DA=DGBTDT
|
||||
. D ^DIE K DIE,DQ,DR I $D(DTOUT)!($D(Y)) S DGBTTOUT=1
|
||||
DIE1 ;
|
||||
S DGBTMLT=$S($D(DGBTVAR("M"))&((DGBTACCT=4)!(DGBTACCT=5)):DGBTOWRT*DGBTML*DGBTMR,1:""),$P(^DGBT(392,DGBTDT,"M"),"^",3)=DGBTMLT,$P(DGBTVAR("M"),"^",3)=DGBTMLT
|
||||
;
|
||||
S DIE="^DGBT(392,",DA=DGBTDT
|
||||
I 'DGBTCORE D
|
||||
. S DR="I DGBTACCT=4!(DGBTACCT=5) S Y=""@1"";41;7;@1;I DGBTMLFB=0 S Y=""@2"";34//;S DGBTMAL=X;35//;S DGBTFAB=X;@2;8//;S DGBTME=X"
|
||||
I DGBTCORE S DR="" D
|
||||
. S DR(1,392,1)="I DGBTACCT=4!(DGBTACCT=5) S Y=""@1"";41;@3;14;S DGBTCSL=$$AFTER^DGBTCSL(392,D0,X,$G(DGBTPRV)) S:DGBTCSL<1 Y=""@3"" W:DGBTCSL<1 "" Required"" K DGBTPRV,DGBTCSL;"
|
||||
. S DR(1,392,2)="@1;I DGBTMLFB=0 S Y=""@2"";34//;S DGBTMAL=X;35//;S DGBTFAB=X;@2;8//;S DGBTME=X"
|
||||
DIE3 ;
|
||||
D ^DIE K DIE,DQ,DR I $D(DTOUT)!($D(Y)) S DGBTTOUT=1 Q
|
||||
;
|
||||
TCOST ;CALCULATE TOTAL COST AND MONTHLY CUM. DEDUCTIBLE
|
||||
MLFB ;
|
||||
S DGBTMAF=$S(DGBTMLFB:DGBTMAL+DGBTFAB,1:0),DGBTMETC=DGBTME+$S($D(DGBTMAL):DGBTMAL,1:0)
|
||||
I DGBTACCT'=4&(DGBTACCT'=5) S DGBTPA=DGBTMAF+DGBTME G CONT
|
||||
I $D(DGBTMLT) S DGBTTC=$S(DGBTMLT+DGBTMAF'>DGBTMETC:DGBTMLT+DGBTMAF,DGBTMLT+DGBTMAF>DGBTMETC&(DGBTME>0):DGBTMETC,DGBTME'>0:DGBTMLT+DGBTMAF,1:DGBTMETC)
|
||||
I DGBTACCT=5 S DGBTDE=0 S DGBTPA=$S((DGBTMLT+DGBTMAF)'=0:DGBTTC,1:DGBTMETC) G CONT
|
||||
DED ;
|
||||
F I=$E(DGBTDT,1,5)_"00.2399":0 S I=$O(^DGBT(392,"C",DFN,I)) Q:'I!($E(I,1,5)>$E(DGBTDT,1,5)) I I'=DGBTDT S DGBTDCM=DGBTDCM+($P(^DGBT(392,I,0),"^",9))
|
||||
I $D(^DG(43.1,$O(^DG(43.1,(9999999.99999-DGBTDT))),"BT")) S DGBTRATE=^("BT"),DGBTDPV=$P(DGBTRATE,"^"),DGBTDPM=$P(DGBTRATE,"^",2),DGBTMR=$P(DGBTRATE,"^",3)
|
||||
I $D(^DGBT(392,DGBTDT,"M")) S:$P(^("M"),"^")=1 DGBTDPV=DGBTDPV/2 I DGBTWAY'=$P(^("M"),"^")!(DGBTMILE'=$P(^("M"),"^",2)) I $D(^DGBT(392,DGBTDT,0)) S $P(^(0),"^",9)="" K ^DGBT(392,"AD",$P(^(0),"^",2),$E(DGBTDT,2,5),DGBTDT)
|
||||
S DGBTDRM=DGBTDPM-DGBTDCM
|
||||
S DGBTDCV=$S(DGBTDCM'<DGBTDPM:0,DGBTDRM'<DGBTDPV&(DGBTTC'<DGBTDPV):DGBTDPV,DGBTDRM'<DGBTDPV&(DGBTTC'>DGBTDPV):DGBTTC,DGBTDRM'>DGBTDPV&(DGBTTC'>DGBTDRM):DGBTTC,DGBTDRM'>DGBTDPV&(DGBTTC'<DGBTDRM):DGBTDRM,1:0)
|
||||
DED1 ;
|
||||
S DR="I $P(^DGBT(392,DGBTDT,0),""^"",9)]"""" S Y=""@9"";9///"_DGBTDCV_";@9;9;S DGBTDE=X S:DGBTDE>DGBTTC DGBTDE=DGBTTC,DGBTFLAG=2 S:DGBTDE>DGBTDRM DGBTDE=DGBTDRM,DGBTFLAG=1"
|
||||
DIE4 ;
|
||||
S DIE="^DGBT(392,",DA=DGBTDT D ^DIE K DIE,DQ,DR I $D(DTOUT)!($D(Y)) S DGBTTOUT=1 Q
|
||||
CONT ;
|
||||
D CONT^DGBTCE1
|
||||
Q
|
||||
FILE ; Reset values if account changes
|
||||
S DGBTVAR(0)=$P(DGBTVAR(0),"^",1,6)_"^^0^^"_$S($L(DGBTVAR(0),"^")>10:$P(DGBTVAR(0),"^",10,$L(DGBTVAR(0),"^")),1:""),DGBTVAR("A")="^"_$P(DGBTVAR("A"),"^",2)_"^^^"_$S($L(DGBTVAR("A"),"^")>4:$P(DGBTVAR("A"),"^",5,$L(DGBTVAR("A"),"^")),1:"")
|
||||
I DGBTACCT<4 S DGBTVAR("M")="^^^"_$S($L(DGBTVAR("M"),"^")>3:$P(DGBTVAR("M"),"^",4,$L(DGBTVAR("M"),"^")),1:"")
|
||||
S ^DGBT(392,DGBTDT,0)=DGBTVAR(0),^("A")=DGBTVAR("A") S:DGBTACCT<4 ^("M")=DGBTVAR("M") S DA=DGBTDT,DIK="^DGBT(392," D IX^DIK
|
||||
Q
|
||||
|
|
|
|||
|
|
@ -1,59 +1,58 @@
|
|||
DGBTCR ;ALB/SCK - BENEFICIARY TRAVEL FORM 70-3542d VARIABLES; 2/7/88@08:00 ;6/11/93@09:30
|
||||
;;1.0;Beneficiary Travel;**7,14**;September 25, 2001;Build 7
|
||||
;Modification of AIVBTPRT / pmg / GRAND ISLAND ; 07 Jul 88 12:02 PM
|
||||
START Q:'$D(DGBTDT)
|
||||
S DGBTVAR(0)=$G(^DGBT(392,+DGBTDT,0)),DGBTACCT=$P($G(^DGBT(392.3,+$P(DGBTVAR(0),"^",6),0)),"^",5)
|
||||
Q:DGBTACCT'>3
|
||||
W !!,*7,"This needs to be printed at 132 columns"
|
||||
S DGPGM="PRINT^DGBTCR",DGVAR="DGBTDT"
|
||||
S %ZIS="PMQ" D ^%ZIS G QUIT:POP
|
||||
I $D(IO("Q")) D QUE G QUIT
|
||||
D PRINT
|
||||
QUIT ;
|
||||
D:'$D(ZTQUEUED) ^%ZISC
|
||||
K DGPGM,DGVAR,VADAT,VADATE,I,X,X2,DGBTVAR,DGBTCC,DGBTDIV,DGBTDOB,DGBTINS,DGBTINS1,DGBTINS2,DGBTCNA,DGBTCSZ,DGBTCNU,DGBTTCTY,DGBTFCTY,DGBTDT,DGBTACCT,DFN,Y
|
||||
K DGBTM6,DGBTM7,DGBTM8,DGBTM9,DGBTM10,DGBTM11,DGBTM12,DGBTM13,DGBTM14,DGBTM15,DGBTM16,DGBTM17,DGBTRATE,DGBTSCP,DGBTSSN,DGBTST
|
||||
Q
|
||||
PRINT ;
|
||||
U IO D SET,PRINT^DGBTCR1,PRINT^DGBTCR2,KVAR^VADPT
|
||||
Q
|
||||
SET S DFN=$P(^DGBT(392,DGBTDT,0),"^",2) D 6^VADPT S (DGBTFCTY,DGBTTCTY)=""
|
||||
NODES F I=0,"A","D","M","R","T" S DGBTVAR(I)=$S($D(^DGBT(392,DGBTDT,I)):^(I),1:"")
|
||||
I $D(^DG(43.1,$O(^DG(43.1,(9999999.99999-DGBTDT))),"BT")) S DGBTRATE=^("BT"),DGBTM7=$S($P(DGBTVAR("A"),"^",3)=1:$P(DGBTRATE,"^",5),1:$P(DGBTRATE,"^",3))
|
||||
I $P(DGBTVAR("D"),"^",4)]"" S DGBTCNA=$P(DGBTVAR("D"),"^",4) D CITY I DGBTCSZ[DGBTCNA D
|
||||
. S DGBTCSZ=DGBTCNA_", "_$S(+$P(DGBTVAR("D"),"^",5)>0:$P(^DIC(5,$P(DGBTVAR("D"),"^",5),0),U,2),1:"")_" "
|
||||
. S Y=$P(DGBTVAR("D"),U,6),Y=$E(Y,1,5)_$S($E(Y,6,9)]"":"-"_$E(Y,6,9),1:""),DGBTCSZ=DGBTCSZ_Y,DGBTFCTY=DGBTCSZ
|
||||
I $P(DGBTVAR("T"),"^",4)]"" S DGBTCNA=$P(DGBTVAR("T"),U,4) D CITY^DGBTCR S:DGBTCSZ[DGBTCNA DGBTCSZ=DGBTCNA_", "_$S(+$P(DGBTVAR("T"),"^",5)>0:$P(^DIC(5,$P(DGBTVAR("T"),"^",5),0),U,2),1:"")_" "_$P(DGBTVAR("T"),U,6) S DGBTTCTY=DGBTCSZ
|
||||
DIV S DGBTDIV=$P(DGBTVAR(0),"^",11) I +DGBTDIV S DGBTDIV=$P(^DG(40.8,DGBTDIV,0),"^",7) S (DGBTCC,DGBTST)=""
|
||||
I $D(^DIC(4,+DGBTDIV,0)) S DGBTINS=^(0),DGBTINS1=$S($D(^DIC(4,DGBTDIV,1)):^(1),1:""),DGBTINS2=$S(DGBTINS1]"":$P(DGBTINS1,"^",3)_",",1:"UNSPECIFIED")_" "_$S($D(^DIC(5,+$P(DGBTINS,U,2),0)):$P(^(0),U,2),1:"")_" "_$P(DGBTINS1,"^",4)
|
||||
I VAPA(5)&(VAPA(7)) S DGBTCC=$S($D(^DIC(5,+VAPA(5),1,+VAPA(7),0)):$P(^(0),"^",3),1:""),DGBTST=$P(^DIC(5,+VAPA(5),0),"^",2)
|
||||
;S DGBTSSN=$P($P(VADM(2),"^",2),"-")_" "_$P($P(VADM(2),"^",2),"-",2)_" "_$P($P(VADM(2),"^",2),"-",3),DGBTDOB=$E(VADM(3),4,7)_$E(VADM(3),2,3)
|
||||
D PID^VADPT6 S DGBTSSN=VA("PID"),DGBTDOB=$E(VADM(3),4,7)_($E(VADM(3),1,3)+1700)
|
||||
S DGBTSCP=$S($L($P(VAEL(3),"^",2)<3):"0",1:"")_$P(VAEL(3),"^",2)
|
||||
MILES S DGBTM6=$P(DGBTVAR("M"),"^")*$P(DGBTVAR("M"),"^",2)
|
||||
N X3
|
||||
S X2="2$",X=DGBTM6*DGBTM7 D COMMA^%DTC S DGBTM8=X
|
||||
S X=$P(DGBTVAR("M"),"^",4) D COMMA^%DTC S DGBTM9=X
|
||||
S X=$P(DGBTVAR("M"),"^",5) D COMMA^%DTC S DGBTM10=X
|
||||
S X=DGBTM6*DGBTM7+$P(DGBTVAR("M"),"^",4)+$P(DGBTVAR("M"),"^",5) D COMMA^%DTC S DGBTM11=X
|
||||
S X2="3$",X=DGBTM7 D COMMA^%DTC S DGBTM7=X
|
||||
S X2="2$" ;Reset edit mask to 2 decimal positions for rest of report
|
||||
S X=$P(DGBTVAR(0),"^",8) D COMMA^%DTC S DGBTM12=X
|
||||
S X=$P(DGBTVAR("M"),"^",4)+$P(DGBTVAR(0),"^",8) D COMMA^%DTC S DGBTM13=X
|
||||
S X=$P(DGBTVAR(0),"^",10) D COMMA^%DTC S DGBTM14=X
|
||||
S X=$P(DGBTVAR(0),"^",9) D COMMA^%DTC S $P(DGBTM14,"^",2)=X
|
||||
CERT S VADAT("W")=DGBTDT D ^VADATE S DGBTM15=VADATE("E")
|
||||
S X=$S($P(^DG(43,1,"BT"),"^")'="":$P(^DG(43,1,"BT"),"^"),1:DUZ),DGBTM16=$P($P(^VA(200,X,0),",",2),"^")_" "_$P(^VA(200,X,0),",")_$S($P(^DG(43,1,"BT"),"^")'="":"",1:", DESIGNEE OF CERTIFYING OFFICIAL") K X
|
||||
S DGBTM17=$P($P(DGBTVAR("A"),"^",2),",",2)_" "_$P($P(DGBTVAR("A"),"^",2),",")
|
||||
Q
|
||||
CITY S DGBTCSZ=DGBTCNA
|
||||
S:VAPA(5)'="" DGBTCNU=$O(^DGBT(392.1,"ACS",DGBTCNA,+VAPA(5),0))
|
||||
I $D(DGBTCNU),(DGBTCNU'="") S DGBTCSZ=$P(^DGBT(392.1,DGBTCNU,0),"^")_", "_($P(^DIC(5,+VAPA(5),0),"^",2))_" "_($P(^DGBT(392.1,DGBTCNU,0),"^",4))
|
||||
Q
|
||||
QUE ;
|
||||
N I
|
||||
S ZTRTN="PRINT^DGBTCR",ZTDESC="VA FORM 70-3542d"
|
||||
F I="DFN","DGBTDT","DGBTFCTY","DGBTTCTY" S ZTSAVE(I)=""
|
||||
D ^%ZTLOAD W:$D(ZTSK) !,"TASK #",ZTSK
|
||||
D HOME^%ZIS K IO("Q")
|
||||
Q
|
||||
DGBTCR ;ALB/SCK - BENEFICIARY TRAVEL FORM 70-3542d VARIABLES; 2/7/88@08:00 ;6/11/93@09:30
|
||||
;;1.0;Beneficiary Travel;**7**;September 25, 2001
|
||||
;Modification of AIVBTPRT / pmg / GRAND ISLAND ; 07 Jul 88 12:02 PM
|
||||
START Q:'$D(DGBTDT)
|
||||
S DGBTVAR(0)=$G(^DGBT(392,+DGBTDT,0)),DGBTACCT=$P($G(^DGBT(392.3,+$P(DGBTVAR(0),"^",6),0)),"^",5)
|
||||
Q:DGBTACCT'>3
|
||||
W !!,*7,"This needs to be printed at 132 columns"
|
||||
S DGPGM="PRINT^DGBTCR",DGVAR="DGBTDT"
|
||||
S %ZIS="PMQ" D ^%ZIS G QUIT:POP
|
||||
I $D(IO("Q")) D QUE G QUIT
|
||||
D PRINT
|
||||
QUIT ;
|
||||
D:'$D(ZTQUEUED) ^%ZISC
|
||||
K DGPGM,DGVAR,VADAT,VADATE,I,X,X2,DGBTVAR,DGBTCC,DGBTDIV,DGBTDOB,DGBTINS,DGBTINS1,DGBTINS2,DGBTCNA,DGBTCSZ,DGBTCNU,DGBTTCTY,DGBTFCTY,DGBTDT,DGBTACCT,DFN,Y
|
||||
K DGBTM6,DGBTM7,DGBTM8,DGBTM9,DGBTM10,DGBTM11,DGBTM12,DGBTM13,DGBTM14,DGBTM15,DGBTM16,DGBTM17,DGBTRATE,DGBTSCP,DGBTSSN,DGBTST
|
||||
Q
|
||||
PRINT ;
|
||||
U IO D SET,PRINT^DGBTCR1,PRINT^DGBTCR2,KVAR^VADPT
|
||||
Q
|
||||
SET S DFN=$P(^DGBT(392,DGBTDT,0),"^",2) D 6^VADPT S (DGBTFCTY,DGBTTCTY)=""
|
||||
NODES F I=0,"A","D","M","R","T" S DGBTVAR(I)=$S($D(^DGBT(392,DGBTDT,I)):^(I),1:"")
|
||||
I $D(^DG(43.1,$O(^DG(43.1,(9999999.99999-DGBTDT))),"BT")) S DGBTRATE=^("BT"),DGBTM7=$S($P(DGBTVAR("A"),"^",3)=1:$P(DGBTRATE,"^",5),1:$P(DGBTRATE,"^",3))
|
||||
I $P(DGBTVAR("D"),"^",4)]"" S DGBTCNA=$P(DGBTVAR("D"),"^",4) D CITY I DGBTCSZ[DGBTCNA D
|
||||
. S DGBTCSZ=DGBTCNA_", "_$S(+$P(DGBTVAR("D"),"^",5)>0:$P(^DIC(5,$P(DGBTVAR("D"),"^",5),0),U,2),1:"")_" "
|
||||
. S Y=$P(DGBTVAR("D"),U,6),Y=$E(Y,1,5)_$S($E(Y,6,9)]"":"-"_$E(Y,6,9),1:""),DGBTCSZ=DGBTCSZ_Y,DGBTFCTY=DGBTCSZ
|
||||
I $P(DGBTVAR("T"),"^",4)]"" S DGBTCNA=$P(DGBTVAR("T"),U,4) D CITY^DGBTCR S:DGBTCSZ[DGBTCNA DGBTCSZ=DGBTCNA_", "_$S(+$P(DGBTVAR("T"),"^",5)>0:$P(^DIC(5,$P(DGBTVAR("T"),"^",5),0),U,2),1:"")_" "_$P(DGBTVAR("T"),U,6) S DGBTTCTY=DGBTCSZ
|
||||
DIV S DGBTDIV=$P(DGBTVAR(0),"^",11) I +DGBTDIV S DGBTDIV=$P(^DG(40.8,DGBTDIV,0),"^",7) S (DGBTCC,DGBTST)=""
|
||||
I $D(^DIC(4,+DGBTDIV,0)) S DGBTINS=^(0),DGBTINS1=$S($D(^DIC(4,DGBTDIV,1)):^(1),1:""),DGBTINS2=$S(DGBTINS1]"":$P(DGBTINS1,"^",3)_",",1:"UNSPECIFIED")_" "_$S($D(^DIC(5,+$P(DGBTINS,U,2),0)):$P(^(0),U,2),1:"")_" "_$P(DGBTINS1,"^",4)
|
||||
I VAPA(5)&(VAPA(7)) S DGBTCC=$S($D(^DIC(5,+VAPA(5),1,+VAPA(7),0)):$P(^(0),"^",3),1:""),DGBTST=$P(^DIC(5,+VAPA(5),0),"^",2)
|
||||
;S DGBTSSN=$P($P(VADM(2),"^",2),"-")_" "_$P($P(VADM(2),"^",2),"-",2)_" "_$P($P(VADM(2),"^",2),"-",3),DGBTDOB=$E(VADM(3),4,7)_$E(VADM(3),2,3)
|
||||
D PID^VADPT6 S DGBTSSN=VA("PID"),DGBTDOB=$E(VADM(3),4,7)_($E(VADM(3),1,3)+1700)
|
||||
S DGBTSCP=$S($L($P(VAEL(3),"^",2)<3):"0",1:"")_$P(VAEL(3),"^",2)
|
||||
MILES S DGBTM6=$P(DGBTVAR("M"),"^")*$P(DGBTVAR("M"),"^",2)
|
||||
N X3
|
||||
S X2="2$",X=DGBTM6*DGBTM7 D COMMA^%DTC S DGBTM8=X
|
||||
S X=$P(DGBTVAR("M"),"^",4) D COMMA^%DTC S DGBTM9=X
|
||||
S X=$P(DGBTVAR("M"),"^",5) D COMMA^%DTC S DGBTM10=X
|
||||
S X=DGBTM6*DGBTM7+$P(DGBTVAR("M"),"^",4)+$P(DGBTVAR("M"),"^",5) D COMMA^%DTC S DGBTM11=X
|
||||
S X=DGBTM7 D COMMA^%DTC S DGBTM7=X
|
||||
S X=$P(DGBTVAR(0),"^",8) D COMMA^%DTC S DGBTM12=X
|
||||
S X=$P(DGBTVAR("M"),"^",4)+$P(DGBTVAR(0),"^",8) D COMMA^%DTC S DGBTM13=X
|
||||
S X=$P(DGBTVAR(0),"^",10) D COMMA^%DTC S DGBTM14=X
|
||||
S X=$P(DGBTVAR(0),"^",9) D COMMA^%DTC S $P(DGBTM14,"^",2)=X
|
||||
CERT S VADAT("W")=DGBTDT D ^VADATE S DGBTM15=VADATE("E")
|
||||
S X=$S($P(^DG(43,1,"BT"),"^")'="":$P(^DG(43,1,"BT"),"^"),1:DUZ),DGBTM16=$P($P(^VA(200,X,0),",",2),"^")_" "_$P(^VA(200,X,0),",")_$S($P(^DG(43,1,"BT"),"^")'="":"",1:", DESIGNEE OF CERTIFYING OFFICIAL") K X
|
||||
S DGBTM17=$P($P(DGBTVAR("A"),"^",2),",",2)_" "_$P($P(DGBTVAR("A"),"^",2),",")
|
||||
Q
|
||||
CITY S DGBTCSZ=DGBTCNA
|
||||
S:VAPA(5)'="" DGBTCNU=$O(^DGBT(392.1,"ACS",DGBTCNA,+VAPA(5),0))
|
||||
I $D(DGBTCNU),(DGBTCNU'="") S DGBTCSZ=$P(^DGBT(392.1,DGBTCNU,0),"^")_", "_($P(^DIC(5,+VAPA(5),0),"^",2))_" "_($P(^DGBT(392.1,DGBTCNU,0),"^",4))
|
||||
Q
|
||||
QUE ;
|
||||
N I
|
||||
S ZTRTN="PRINT^DGBTCR",ZTDESC="VA FORM 70-3542d"
|
||||
F I="DFN","DGBTDT","DGBTFCTY","DGBTTCTY" S ZTSAVE(I)=""
|
||||
D ^%ZTLOAD W:$D(ZTSK) !,"TASK #",ZTSK
|
||||
D HOME^%ZIS K IO("Q")
|
||||
Q
|
||||
|
|
|
|||
|
|
@ -1,55 +1,55 @@
|
|||
DGBTEE ;ALB/SCK - BENEFICIARY TRAVEL ENTER/EDIT; 12/3/92@1600
|
||||
;;1.0;Beneficiary Travel;**2,14**;September 25, 2001;Build 7
|
||||
Q
|
||||
SCREEN ;
|
||||
D SCREEN^DGBTEE1 Q:DGBTTOUT=-1!(DGBTTOUT=1) Q:'$D(^DGBT(392,DGBTDT,0))
|
||||
; The following section of code moved to DGBTEE2 for space problems
|
||||
D STUFF^DGBTEE2
|
||||
MILES ; get miles between dep. and dest. using function call to DGBTUTL
|
||||
K X,DGBTREC S (DGBTOWRT,DGBTML,DGBTMLT)=""
|
||||
I DGBTFR4]""&((DGBTACCT=4)!(DGBTACCT=5)) I $D(^DGBT(392.1,"ACS",DGBTFR4,+VAPA(5))) D
|
||||
. S X=$O(^(+VAPA(5),0)) ; naked ref. refers to file #392.1, "ACS", city. Full reference on line MILES+2^DGBTEE, ^DGBTE(392.1,"ACS",DGBTFR4,+VAPA(5)
|
||||
. ; function $$miles passes city's record# and div name to function, mileage value is returned
|
||||
. I X'="" S DGBTREC=X,DGBTML=$$MILES^DGBTUTL(DGBTREC,DGBTDV1),DGBTOWRT="ROUND TRIP" K X
|
||||
S (DGBTMAL,DGBTFAB,DGBTME,DGBTCP,DGBTFLAG,DGBTDCV,DGBTDE,DGBTDCM,DGBTDPV,DGBTDPM)=0
|
||||
DIE1 ; stuff from,to address, meals, ferry's/bridges
|
||||
Q:'$D(^DGBT(392,DGBTDT,0))
|
||||
S DIE="^DGBT(392,",DA=DGBTDT,DR=$S(DGBTACCT=4:"42//"_DGBTAP,DGBTACCT=5:"43;S DGBTCP=X;42//"_DGBTAP,1:"44")
|
||||
D ^DIE I X=""!(X="^") S DGBTTOUT=-1 Q
|
||||
S DR="21////^S X=DGBTFR1;22////^S X=DGBTFR2;23////^S X=DGBTFR3;24////^S X=DGBTFR4;25////^S X=DGBTTO1;26////^S X=DGBTTO2;27////^S X=DGBTTO3;28////^S X=DGBTTO4;34////^S X=DGBTMAL;35////^S X=DGBTFAB"
|
||||
D ^DIE I X=""!(X="^") S DGBTTOUT=-1 Q
|
||||
; function $$diclkup passes the city's record #, div name, and a flag for remarks (4), remarks or a null are returned
|
||||
I DGBTACCT=4!(DGBTACCT=5) D
|
||||
. W !!,"Please wait, Checking Mileage ..."
|
||||
. S DGBTRMK=$S($D(DGBTREC):$$DICLKUP^DGBTUTL(DGBTREC,DGBTDV1,4),1:"") I $D(DGBTDEF),DGBTDEF S DGBTRMK="DEFAULT MILEAGE USED"
|
||||
. I DGBTRMK]"" W !,*7,"MILEAGE REMARKS: ",DGBTRMK,!
|
||||
EDIT ; display trip type, mileage
|
||||
I DGBTACCT=4!(DGBTACCT=5) S DR="32//"_DGBTML_";S DGBTML=X;31//"_DGBTOWRT_";S DGBTOWRT=X;" D ^DIE I X=""!(X="^") S DGBTTOUT=-1 Q
|
||||
S:DGBTACCT=5&(DGBTCP=1) DGBTMR=DGBTMR1 S DGBTMLT=DGBTOWRT*DGBTML*DGBTMR,DGBTMLT=$J(DGBTMLT,0,2),DR="33///"_DGBTMLT
|
||||
D ^DIE I X=""!(X="^") S DGBTTOUT=-1 Q
|
||||
DIE2 ; stuff eligibility data, SC%, acct. type
|
||||
S DIE("NO^")="12345" S:'$D(DGBTCD) DGBTCD=""
|
||||
I 'DGBTCORE D
|
||||
. S DR="3////"_DGBTELIG_";4////"_DGBTSCP_";5///"_DGBTCD_";6////"_DGBTACTN_";I DGBTACCT=4!(DGBTACCT=5) S Y=""@1"";41;7;@1;I DGBTMLFB=0 S Y=""@2"";34;S DGBTMAL=X;35;S DGBTFAB=X;@2"
|
||||
I DGBTCORE D
|
||||
. S DR(1,392,1)="3////"_DGBTELIG_";4////"_DGBTSCP_";5///"_DGBTCD_";6////"_DGBTACTN_";I DGBTACCT=4!(DGBTACCT=5) S Y=""@1"";41;"
|
||||
. S DR(1,392,2)="@3;14;S DGBTCSL=$$AFTER^DGBTCSL(392,D0,X,$G(DGBTPRV)) S:DGBTCSL<1 Y=""@3"" W:DGBTCSL<1 "" Required"" K DGBTPRV,DGBTCSL;@1;I DGBTMLFB=0 S Y=""@2"";34;S DGBTMAL=X;35;S DGBTFAB=X;@2"
|
||||
DIE3 ; get most econ. cost
|
||||
D ^DIE K DR I X=""!(X="^") S DGBTTOUT=-1 Q
|
||||
; function $$diclkup passes the city's record #, division name, and flag for MEC (3), the MEC is returned
|
||||
S:$D(DGBTREC) DGBTME=$$DICLKUP^DGBTUTL(DGBTREC,DGBTDV1,3) S:DGBTME="" DGBTME=0 S DR="8//"_DGBTME_";S DGBTME=X"
|
||||
D ^DIE I X=""!(X="^") S DGBTTOUT=-1 G EXIT
|
||||
TCOST ; calculate total cost and monthly cum. deductable
|
||||
MLFB ;
|
||||
S DGBTMAF=$S(DGBTMLFB:DGBTMAL+DGBTFAB,1:0),DGBTMETC=DGBTME+$S($D(DGBTMAL):DGBTMAL,1:0)
|
||||
I DGBTACCT'=4&(DGBTACCT'=5) S DGBTPA=DGBTMAF+DGBTME G CONT
|
||||
I $D(DGBTMLT) S DGBTTC=$S(DGBTMLT+DGBTMAF'>DGBTMETC:DGBTMLT+DGBTMAF,DGBTMLT+DGBTMAF>DGBTMETC&(DGBTME>0):DGBTMETC,DGBTME'>0:DGBTMLT+DGBTMAF,1:DGBTMETC)
|
||||
I DGBTACCT=5 S DGBTDE=0 S DGBTPA=$S((DGBTMLT+DGBTMAF)'=0:DGBTTC,1:DGBTMETC) G CONT
|
||||
; the following section of code moved to DGBTEE2 for space reasons
|
||||
D DED^DGBTEE2
|
||||
DIE4 ; display deductable amount
|
||||
D ^DIE I X=""!(X="^") S DGBTTOUT=-1 Q
|
||||
CONT ;
|
||||
D CONT^DGBTCE1 Q
|
||||
EXIT ;
|
||||
K DGBTDV1,DGBTRMK Q
|
||||
DGBTEE ;ALB/SCK - BENEFICIARY TRAVEL ENTER/EDIT; 12/3/92@1600
|
||||
;;1.0;Beneficiary Travel;**2**;September 25, 2001
|
||||
Q
|
||||
SCREEN ;
|
||||
D SCREEN^DGBTEE1 Q:DGBTTOUT=-1!(DGBTTOUT=1) Q:'$D(^DGBT(392,DGBTDT,0))
|
||||
; The following section of code moved to DGBTEE2 for space problems
|
||||
D STUFF^DGBTEE2
|
||||
MILES ; get miles between dep. and dest. using function call to DGBTUTL
|
||||
K X,DGBTREC S (DGBTOWRT,DGBTML,DGBTMLT)=""
|
||||
I DGBTFR4]""&((DGBTACCT=4)!(DGBTACCT=5)) I $D(^DGBT(392.1,"ACS",DGBTFR4,+VAPA(5))) D
|
||||
. S X=$O(^(+VAPA(5),0)) ; naked ref. refers to file #392.1, "ACS", city. Full reference on line MILES+2^DGBTEE, ^DGBTE(392.1,"ACS",DGBTFR4,+VAPA(5)
|
||||
. ; function $$miles passes city's record# and div name to function, mileage value is returned
|
||||
. I X'="" S DGBTREC=X,DGBTML=$$MILES^DGBTUTL(DGBTREC,DGBTDV1),DGBTOWRT="ROUND TRIP" K X
|
||||
S (DGBTMAL,DGBTFAB,DGBTME,DGBTCP,DGBTFLAG,DGBTDCV,DGBTDE,DGBTDCM,DGBTDPV,DGBTDPM)=0
|
||||
DIE1 ; stuff from,to address, meals, ferry's/bridges
|
||||
Q:'$D(^DGBT(392,DGBTDT,0))
|
||||
S DIE="^DGBT(392,",DA=DGBTDT,DR=$S(DGBTACCT=4:"42//"_DGBTAP,DGBTACCT=5:"43;S DGBTCP=X;42//"_DGBTAP,1:"44")
|
||||
D ^DIE I X=""!(X="^") S DGBTTOUT=-1 Q
|
||||
S DR="21////^S X=DGBTFR1;22////^S X=DGBTFR2;23////^S X=DGBTFR3;24////^S X=DGBTFR4;25////^S X=DGBTTO1;26////^S X=DGBTTO2;27////^S X=DGBTTO3;28////^S X=DGBTTO4;34////^S X=DGBTMAL;35////^S X=DGBTFAB"
|
||||
D ^DIE I X=""!(X="^") S DGBTTOUT=-1 Q
|
||||
; function $$diclkup passes the city's record #, div name, and a flag for remarks (4), remarks or a null are returned
|
||||
I DGBTACCT=4!(DGBTACCT=5) D
|
||||
. W !!,"Please wait, Checking Mileage ..."
|
||||
. S DGBTRMK=$S($D(DGBTREC):$$DICLKUP^DGBTUTL(DGBTREC,DGBTDV1,4),1:"") I $D(DGBTDEF),DGBTDEF S DGBTRMK="DEFAULT MILEAGE USED"
|
||||
. I DGBTRMK]"" W !,*7,"MILEAGE REMARKS: ",DGBTRMK,!
|
||||
EDIT ; display trip type, mileage
|
||||
I DGBTACCT=4!(DGBTACCT=5) S DR="32//"_DGBTML_";S DGBTML=X;31//"_DGBTOWRT_";S DGBTOWRT=X;" D ^DIE I X=""!(X="^") S DGBTTOUT=-1 Q
|
||||
S:DGBTACCT=5&(DGBTCP=1) DGBTMR=DGBTMR1 S DGBTMLT=DGBTOWRT*DGBTML*DGBTMR,DR="33///"_DGBTMLT
|
||||
D ^DIE I X=""!(X="^") S DGBTTOUT=-1 Q
|
||||
DIE2 ; stuff eligibility data, SC%, acct. type
|
||||
S DIE("NO^")="12345" S:'$D(DGBTCD) DGBTCD=""
|
||||
I 'DGBTCORE D
|
||||
. S DR="3////"_DGBTELIG_";4////"_DGBTSCP_";5///"_DGBTCD_";6////"_DGBTACTN_";I DGBTACCT=4!(DGBTACCT=5) S Y=""@1"";41;7;@1;I DGBTMLFB=0 S Y=""@2"";34;S DGBTMAL=X;35;S DGBTFAB=X;@2"
|
||||
I DGBTCORE D
|
||||
. S DR(1,392,1)="3////"_DGBTELIG_";4////"_DGBTSCP_";5///"_DGBTCD_";6////"_DGBTACTN_";I DGBTACCT=4!(DGBTACCT=5) S Y=""@1"";41;"
|
||||
. S DR(1,392,2)="@3;14;S DGBTCSL=$$AFTER^DGBTCSL(392,D0,X,$G(DGBTPRV)) S:DGBTCSL<1 Y=""@3"" W:DGBTCSL<1 "" Required"" K DGBTPRV,DGBTCSL;@1;I DGBTMLFB=0 S Y=""@2"";34;S DGBTMAL=X;35;S DGBTFAB=X;@2"
|
||||
DIE3 ; get most econ. cost
|
||||
D ^DIE K DR I X=""!(X="^") S DGBTTOUT=-1 Q
|
||||
; function $$diclkup passes the city's record #, division name, and flag for MEC (3), the MEC is returned
|
||||
S:$D(DGBTREC) DGBTME=$$DICLKUP^DGBTUTL(DGBTREC,DGBTDV1,3) S:DGBTME="" DGBTME=0 S DR="8//"_DGBTME_";S DGBTME=X"
|
||||
D ^DIE I X=""!(X="^") S DGBTTOUT=-1 G EXIT
|
||||
TCOST ; calculate total cost and monthly cum. deductable
|
||||
MLFB ;
|
||||
S DGBTMAF=$S(DGBTMLFB:DGBTMAL+DGBTFAB,1:0),DGBTMETC=DGBTME+$S($D(DGBTMAL):DGBTMAL,1:0)
|
||||
I DGBTACCT'=4&(DGBTACCT'=5) S DGBTPA=DGBTMAF+DGBTME G CONT
|
||||
I $D(DGBTMLT) S DGBTTC=$S(DGBTMLT+DGBTMAF'>DGBTMETC:DGBTMLT+DGBTMAF,DGBTMLT+DGBTMAF>DGBTMETC&(DGBTME>0):DGBTMETC,DGBTME'>0:DGBTMLT+DGBTMAF,1:DGBTMETC)
|
||||
I DGBTACCT=5 S DGBTDE=0 S DGBTPA=$S((DGBTMLT+DGBTMAF)'=0:DGBTTC,1:DGBTMETC) G CONT
|
||||
; the following section of code moved to DGBTEE2 for space reasons
|
||||
D DED^DGBTEE2
|
||||
DIE4 ; display deductable amount
|
||||
D ^DIE I X=""!(X="^") S DGBTTOUT=-1 Q
|
||||
CONT ;
|
||||
D CONT^DGBTCE1 Q
|
||||
EXIT ;
|
||||
K DGBTDV1,DGBTRMK Q
|
||||
|
|
|
|||
|
|
@ -1,64 +1,64 @@
|
|||
DGBTEE1 ;ALB/SCK - BENEFICIARY TRAVEL ENTER/EDIT CHECK; 12/7/92 3/19/93
|
||||
;;1.0;Beneficiary Travel;**14**;September 25, 2001;Build 7
|
||||
Q
|
||||
SCREEN ; called by dgbtee,dgbtce
|
||||
Q:'$D(^DGBT(392,DGBTDT,0))
|
||||
K DGBTVAR F I=0,"A","D","M","R","T" S DGBTVAR(I)=$S($D(^DGBT(392,DGBTDT,I)):^(I),1:"") ; ref file #392, claims
|
||||
W @IOF S DGBTFLAG=0
|
||||
I '$D(^DG(43,1,"BT"))!('$D(^DG(43.1,$O(^DG(43.1,(9999999.99999-DGBTDT))),"BT"))) W !!,"Module has not been properly initialized - to continue you should first complete",!,"the parameters" Q
|
||||
W !?16,"Beneficiary Travel Claim Information <Enter/Edit>"
|
||||
D PID^VADPT6
|
||||
W !!?8,"Name: ",VADM(1),?40,"PT ID: ",VA("PID"),?64,"DOB: ",$P(VADM(3),"^",2),!
|
||||
START ; ask date/time, and division
|
||||
K DIC,^TMP("DGBT",$J),X
|
||||
S DIE="^DGBT(392,",DIE("NO^")="OUTOK"
|
||||
S DR=".01;S (DGBTDT,VADAT(""W""))=X D ^VADATE S DGBTDTI=VADATE(""I""),DGBTDTE=VADATE(""E"") K VADAT,VADATE I '$D(DGBTMD) S Y=""@1"";11;@1"
|
||||
S DIDEL=392 ; allows users to delete BT claims
|
||||
D ^DIE K DIE,DIDEL,DQ,DR I $D(DTOUT)!($D(Y)) S DGBTTOUT=-1 Q
|
||||
K X
|
||||
I '$D(^DGBT(392,DGBTDT,0)) Q
|
||||
I $D(^DGBT(392,DGBTDT,0)) L ^DGBT(392,DGBTDT):2 I '$T W !?5,"Another user is editing this entry.",*7 S DGBTTOUT=1 G QUIT
|
||||
; set rates and build eligibilities in DGBTEE2
|
||||
D RATES^DGBTEE2
|
||||
ELIG1 ; select eligibility from those available in TMP list
|
||||
I '$O(VAEL(1,0)) S DGBTELIG=+VAEL(1) G ESET1
|
||||
S DIR("A")="Select ELIGIBILITY",DIR("B")=$S($P(^DGBT(392,DGBTDT,0),"^",3):$P(^DIC(8,$P(^DGBT(392,DGBTDT,0),"^",3),0),"^"),VAEL(1):$P(VAEL(1),"^",2),1:"")
|
||||
S DIR(0)="F",DIR("?")="^D ELIST^DGBTEE2"
|
||||
D ^DIR K DIR I $D(DUOUT) W !?3,"SORRY, '^' NOT ALLOWED!!" G ELIG1
|
||||
I $D(DTOUT) S DGBTTOUT=-1 Q
|
||||
S:Y="" DGBTELIG=$S($P(^DGBT(392,DGBTDT,0),"^",3):$P(^(0),"^",3),1:+VAEL(1)) ; ref file #392, claims
|
||||
I X["@" W !,"ELIGIBILITY REQUIRED." G ELIG1
|
||||
I Y?1A.E F I=0:0 S I=$O(^TMP("DGBT",$J,I)) Q:'I I $E($P(^(I),"^",2),1,$L(X))=X S XX=Y,Y=I G ESET ; ref ^TMP file for eligibility
|
||||
I +Y?1N.N S Y=+Y F I=0:0 S I=$O(^TMP("DGBT",$J,I)) Q:'I I +$P(^(I),"^")=Y S XX=Y,Y=I G ESET ; ref ^TMP file for eligibility
|
||||
ECHOZ ;
|
||||
W !!,"Choose by NUMBER the primary eligibility or other entitled eligibilities",!
|
||||
I DGBTCT>1 F I=0:0 S I=$O(^TMP("DGBT",$J,I)) Q:'I W !?5,I,?10,$P(^TMP("DGBT",$J,I),"^",2)
|
||||
K DIR,X S DIR("A")="Choose 1-"_DGBTCT,DIR(0)="NO^1:"_DGBTCT,DIR("?")="Enter choice from those displayed"
|
||||
D ^DIR K DIR G:$D(DIRUT) ELIG1 S XX=Y
|
||||
I '$D(^TMP("DGBT",$J,Y)) W " ?? ",!,"Select ELIGIBILITY: " G ECHOZ
|
||||
ESET ;
|
||||
S:$D(Y) DGBTELIG=$S($D(^TMP("DGBT",$J,Y)):+^TMP("DGBT",$J,Y),'$D(XX):Y,1:+VAEL(1))
|
||||
W:Y]"" ?30,$E($P(^DIC(8,+DGBTELIG,0),"^"),$S($D(XX):($L(XX)+1),1:1),99)
|
||||
ESET1 ;
|
||||
S DGBTSCP=$S($P(^DIC(8,DGBTELIG,0),"^",9)=1&(+VAEL(3)):$P(VAEL(3),"^",2),$P(^DIC(8,DGBTELIG,0),"^",9)=3&(+VAEL(3)):$P(VAEL(3),"^",2),1:"")
|
||||
CERT ; stuff of certification date if appropriate
|
||||
; naked global ref file #392.2, certification file.
|
||||
I $P(VAEL(3),"^") S DGBTCD="" I VAEL(3)&($P(VAEL(3),"^",2)'>29) S DGBTIDT=9999999.99999-DGBTDT F I=0:0 S I=$O(^DGBT(392.2,"C",DFN,I)) Q:'I I I'>DGBTIDT&($P(^DGBT(392.2,I,0),"^",3)) S DGBTCD=$P(^(0),"^")
|
||||
ACCT ; allowed to select only valid active accounts
|
||||
S DGBTOACT=$S('$D(^DGBT(392.3,+$P(DGBTVAR(0),"^",6),0)):0,1:+$P(^DGBT(392.3,$P(DGBTVAR(0),"^",6),0),"^",5))
|
||||
K X S (DIC("B"),X)=$S(+$P(DGBTVAR(0),"^",6):$P(^DGBT(392.3,$P(DGBTVAR(0),"^",6),0),"^"),1:$$DEFLT1) S DIC("A")="Select ACCOUNT: "
|
||||
S DIC="^DGBT(392.3,",DIC(0)="AEQMZ",DIC("S")="I $P(^(0),U,3)'>DGBTDT&('$P(^(0),U,4)!($P(^(0),U,4)'<DGBTDT))"
|
||||
D ^DIC K DIC I $D(DTOUT) S DGBTTOUT=-1 K DTOUT Q
|
||||
I Y'>0 W !,"ACCOUNT IS REQUIRED!!" G ACCT
|
||||
S DGBTACTN=$P(Y,"^"),DGBTACCT=$P(Y(0),"^",5)
|
||||
; if account is ALL OTHER - stuff in mileage info
|
||||
I $D(DGBTVAR("M")) S DGBTML=$P(DGBTVAR("M"),"^",2),DGBTOWRT=$P(DGBTVAR("M"),"^"),DGBTMLT=$J((DGBTML*DGBTOWRT*DGBTMR),0,2)
|
||||
QUIT ;
|
||||
K A,C,I,IA,J,X,XX,^TMP("DGBT",$J),DGBTDIV,DGBTIDT,DGBTCT
|
||||
Q
|
||||
;
|
||||
DEFLT1() ;
|
||||
N REC,Y
|
||||
S REC="0" F S REC=$O(^DGBT(392.3,REC)) Q:'REC D Q:$D(Y)
|
||||
. S:$P(^DGBT(392.3,REC,0),U,5)=4&($P(^(0),U,3)'>DGBTDT&('$P(^(0),U,4)!($P(^(0),U,4)'<DGBTDT))) Y=$P(^(0),U,1)
|
||||
Q $G(Y)
|
||||
DGBTEE1 ;ALB/SCK - BENEFICIARY TRAVEL ENTER/EDIT CHECK; 12/7/92 3/19/93
|
||||
;;1.0;Beneficiary Travel;;September 25, 2001
|
||||
Q
|
||||
SCREEN ; called by dgbtee,dgbtce
|
||||
Q:'$D(^DGBT(392,DGBTDT,0))
|
||||
K DGBTVAR F I=0,"A","D","M","R","T" S DGBTVAR(I)=$S($D(^DGBT(392,DGBTDT,I)):^(I),1:"") ; ref file #392, claims
|
||||
W @IOF S DGBTFLAG=0
|
||||
I '$D(^DG(43,1,"BT"))!('$D(^DG(43.1,$O(^DG(43.1,(9999999.99999-DGBTDT))),"BT"))) W !!,"Module has not been properly initialized - to continue you should first complete",!,"the parameters" Q
|
||||
W !?16,"Beneficiary Travel Claim Information <Enter/Edit>"
|
||||
D PID^VADPT6
|
||||
W !!?8,"Name: ",VADM(1),?40,"PT ID: ",VA("PID"),?64,"DOB: ",$P(VADM(3),"^",2),!
|
||||
START ; ask date/time, and division
|
||||
K DIC,^TMP("DGBT",$J),X
|
||||
S DIE="^DGBT(392,",DIE("NO^")="OUTOK"
|
||||
S DR=".01;S (DGBTDT,VADAT(""W""))=X D ^VADATE S DGBTDTI=VADATE(""I""),DGBTDTE=VADATE(""E"") K VADAT,VADATE I '$D(DGBTMD) S Y=""@1"";11;@1"
|
||||
S DIDEL=392 ; allows users to delete BT claims
|
||||
D ^DIE K DIE,DIDEL,DQ,DR I $D(DTOUT)!($D(Y)) S DGBTTOUT=-1 Q
|
||||
K X
|
||||
I '$D(^DGBT(392,DGBTDT,0)) Q
|
||||
I $D(^DGBT(392,DGBTDT,0)) L ^DGBT(392,DGBTDT):2 I '$T W !?5,"Another user is editing this entry.",*7 S DGBTTOUT=1 G QUIT
|
||||
; set rates and build eligibilities in DGBTEE2
|
||||
D RATES^DGBTEE2
|
||||
ELIG1 ; select eligibility from those available in TMP list
|
||||
I '$O(VAEL(1,0)) S DGBTELIG=+VAEL(1) G ESET1
|
||||
S DIR("A")="Select ELIGIBILITY",DIR("B")=$S($P(^DGBT(392,DGBTDT,0),"^",3):$P(^DIC(8,$P(^DGBT(392,DGBTDT,0),"^",3),0),"^"),VAEL(1):$P(VAEL(1),"^",2),1:"")
|
||||
S DIR(0)="F",DIR("?")="^D ELIST^DGBTEE2"
|
||||
D ^DIR K DIR I $D(DUOUT) W !?3,"SORRY, '^' NOT ALLOWED!!" G ELIG1
|
||||
I $D(DTOUT) S DGBTTOUT=-1 Q
|
||||
S:Y="" DGBTELIG=$S($P(^DGBT(392,DGBTDT,0),"^",3):$P(^(0),"^",3),1:+VAEL(1)) ; ref file #392, claims
|
||||
I X["@" W !,"ELIGIBILITY REQUIRED." G ELIG1
|
||||
I Y?1A.E F I=0:0 S I=$O(^TMP("DGBT",$J,I)) Q:'I I $E($P(^(I),"^",2),1,$L(X))=X S XX=Y,Y=I G ESET ; ref ^TMP file for eligibility
|
||||
I +Y?1N.N S Y=+Y F I=0:0 S I=$O(^TMP("DGBT",$J,I)) Q:'I I +$P(^(I),"^")=Y S XX=Y,Y=I G ESET ; ref ^TMP file for eligibility
|
||||
ECHOZ ;
|
||||
W !!,"Choose by NUMBER the primary eligibility or other entitled eligibilities",!
|
||||
I DGBTCT>1 F I=0:0 S I=$O(^TMP("DGBT",$J,I)) Q:'I W !?5,I,?10,$P(^TMP("DGBT",$J,I),"^",2)
|
||||
K DIR,X S DIR("A")="Choose 1-"_DGBTCT,DIR(0)="NO^1:"_DGBTCT,DIR("?")="Enter choice from those displayed"
|
||||
D ^DIR K DIR G:$D(DIRUT) ELIG1 S XX=Y
|
||||
I '$D(^TMP("DGBT",$J,Y)) W " ?? ",!,"Select ELIGIBILITY: " G ECHOZ
|
||||
ESET ;
|
||||
S:$D(Y) DGBTELIG=$S($D(^TMP("DGBT",$J,Y)):+^TMP("DGBT",$J,Y),'$D(XX):Y,1:+VAEL(1))
|
||||
W:Y]"" ?30,$E($P(^DIC(8,+DGBTELIG,0),"^"),$S($D(XX):($L(XX)+1),1:1),99)
|
||||
ESET1 ;
|
||||
S DGBTSCP=$S($P(^DIC(8,DGBTELIG,0),"^",9)=1&(+VAEL(3)):$P(VAEL(3),"^",2),$P(^DIC(8,DGBTELIG,0),"^",9)=3&(+VAEL(3)):$P(VAEL(3),"^",2),1:"")
|
||||
CERT ; stuff of certification date if appropriate
|
||||
; naked global ref file #392.2, certification file.
|
||||
I $P(VAEL(3),"^") S DGBTCD="" I VAEL(3)&($P(VAEL(3),"^",2)'>29) S DGBTIDT=9999999.99999-DGBTDT F I=0:0 S I=$O(^DGBT(392.2,"C",DFN,I)) Q:'I I I'>DGBTIDT&($P(^DGBT(392.2,I,0),"^",3)) S DGBTCD=$P(^(0),"^")
|
||||
ACCT ; allowed to select only valid active accounts
|
||||
S DGBTOACT=$S('$D(^DGBT(392.3,+$P(DGBTVAR(0),"^",6),0)):0,1:+$P(^DGBT(392.3,$P(DGBTVAR(0),"^",6),0),"^",5))
|
||||
K X S (DIC("B"),X)=$S(+$P(DGBTVAR(0),"^",6):$P(^DGBT(392.3,$P(DGBTVAR(0),"^",6),0),"^"),1:$$DEFLT1) S DIC("A")="Select ACCOUNT: "
|
||||
S DIC="^DGBT(392.3,",DIC(0)="AEQMZ",DIC("S")="I $P(^(0),U,3)'>DGBTDT&('$P(^(0),U,4)!($P(^(0),U,4)'<DGBTDT))"
|
||||
D ^DIC K DIC I $D(DTOUT) S DGBTTOUT=-1 K DTOUT Q
|
||||
I Y'>0 W !,"ACCOUNT IS REQUIRED!!" G ACCT
|
||||
S DGBTACTN=$P(Y,"^"),DGBTACCT=$P(Y(0),"^",5)
|
||||
; if account is ALL OTHER - stuff in mileage info
|
||||
I $D(DGBTVAR("M")) S DGBTML=$P(DGBTVAR("M"),"^",2),DGBTOWRT=$P(DGBTVAR("M"),"^"),DGBTMLT=DGBTML*DGBTOWRT*DGBTMR
|
||||
QUIT ;
|
||||
K A,C,I,IA,J,X,XX,^TMP("DGBT",$J),DGBTDIV,DGBTIDT,DGBTCT
|
||||
Q
|
||||
;
|
||||
DEFLT1() ;
|
||||
N REC,Y
|
||||
S REC="0" F S REC=$O(^DGBT(392.3,REC)) Q:'REC D Q:$D(Y)
|
||||
. S:$P(^DGBT(392.3,REC,0),U,5)=4&($P(^(0),U,3)'>DGBTDT&('$P(^(0),U,4)!($P(^(0),U,4)'<DGBTDT))) Y=$P(^(0),U,1)
|
||||
Q $G(Y)
|
||||
|
|
|
|||
|
|
@ -1,62 +1,60 @@
|
|||
DGBTEF1 ;ALB/SCK - BENEFICIARY TRAVEL UPDATE PARAMETERS INTO FILES ;12/14/92 3/12/93
|
||||
;;1.0;Beneficiary Travel;**2,14**;September 25, 2001;Build 7
|
||||
RATES ;enter/edit bene travel parameters;option DGBT BENE TRAVEL RATES
|
||||
S DA=1,DR="720;723;721",DIE="^DG(43," D ^DIE G QUIT:X="^"!($D(DTOUT))!($D(Y)) K DA,DE,DQ,DR,DIE
|
||||
Q ;This Q was added under direction of CBO to remove site's ability to edit rates
|
||||
W !!,"New travel rates are determined each fiscal year. The rates should be",!,"entered each year with the effective date of Oct 1.",!
|
||||
W !,"Changing values for the current or past fiscal years could result in changes",!,"to the claims already entered.",!
|
||||
DATE ; change deductible rates for FY
|
||||
Q ;This Q was added under direction of CBO to remove site's ability to edit rates
|
||||
S DIR("A")="Select EFFECTIVE DATE",DIR(0)="DO^^E",DIR("?")="^D HELP1^DGBTEF1"
|
||||
D ^DIR K DIR G QUIT:$D(DIRUT) G HELP:$E(Y,4,7)'="1001" S X=+Y
|
||||
S DIC="^DG(43.1,",DIC(0)="ELQMZ"
|
||||
D ^DIC G QUIT:Y'>0 S DA=+Y
|
||||
S DGBTN=$S('$D(^DG(43.1,DA,"BT")):"",1:^DG(43.1,DA,"BT"))
|
||||
S:$D(DGBTN)&($P(DGBTN,"^")]"") DIR("B")=$P(DGBTN,"^")
|
||||
S DGBTDEDV=$$DEDUCT(6,"VISIT") G:DGBTDEDV<0 QUIT1
|
||||
S DIE="^DG(43.1,",DR="30.01///^S X=DGBTDEDV"
|
||||
D ^DIE
|
||||
S:$D(DGBTN)&($P(DGBTN,"^",2)]"") DIR("B")=$P(DGBTN,"^",2)
|
||||
S DGBTDEDM=$$DEDUCT(18,"MONTH") G:DGBTDEDM<0 QUIT1
|
||||
S DIE="^DG(43.1,",DR="30.02///^S X=DGBTDEDM"
|
||||
D ^DIE
|
||||
S DR="30.03;30.05;30.04",DIE="^DG(43.1,"
|
||||
D ^DIE G QUIT1
|
||||
ACCT ; change activation/inactivation dates for accounts
|
||||
W !!,"ACCOUNT TYPES are determined by Fiscal Service and have a direct impact",!,"on the type of questions asked in the Beneficiary Travel CLAIM ENTER/EDIT",!,"option."
|
||||
W !,"DO NOT add to this file unless so instructed by Fiscal Service.",!
|
||||
TYPE ; select account to edit
|
||||
S DIR("A")="Select ACCOUNT",DIR("?")="^D HELP2^DGBTEF1",DIR(0)="FO"
|
||||
D ^DIR K DIR G QUIT:$D(DIRUT) S X=Y
|
||||
S DIC="^DGBT(392.3,",DIC(0)="ELQMZ"
|
||||
D ^DIC G TYPE:Y'>0
|
||||
S DA=+Y,DR="2:4",DIE="^DGBT(392.3," D ^DIE G TYPE
|
||||
NWACT ;enter/edit account file (392.3);option DGBT BENE TRAVEL ACCOUNT
|
||||
W !!?3,"You are about to enter/edit Bene Travel account types. Although",!?3,"this process is now decentralized, changes and additions should be",!?3,"made with extreme care.",!
|
||||
S DIR(0)="Y",DIR("A")="Are you sure you wish to continue",DIR("B")="No" D ^DIR K DIR I $D(DTOUT)!($D(DUOUT))!('Y) G QUIT1
|
||||
ED ; edit data for new account
|
||||
W ! K X,DA
|
||||
S (DIE,DIC)="^DGBT(392.3,",DIC(0)="AEQLMZ",DLAYGO=392.3,DIC("DR")=""
|
||||
D ^DIC K DIC G:$D(DTOUT)!$D(DUOUT)!(X="") QUIT1 G:Y'>0 ED
|
||||
S DR="2///"_$P(Y(0)," ",1)_";3;4;5" ; account number now stuffed, not asked
|
||||
S DA=+Y L ^DGBT(392.3,DA):2 E W !?5,"Another user is editing this entry.",*7 G ED
|
||||
S DIE("NO^")=1
|
||||
D ^DIE L K DR,DIE,DIE("NO^")
|
||||
W ! S DIR(0)="Y",DIR("A")="Would you like to Enter/Edit another ACCOUNT",DIR("B")="Yes"
|
||||
D ^DIR K DIR G:$D(DTOUT)!($D(DUOUT))!(Y=0) QUIT1 G ED
|
||||
QUIT1 ;
|
||||
K DIR,DTOUT,DI,D0,DUOUT,DIRUT,DGBTN,DGBTDEDV,DGBTDEDM
|
||||
QUIT ;
|
||||
K %DT,DA,DIC,DIE,DIE("NO^"),DR,X,Y Q
|
||||
DEDUCT(LIMIT,TYPE) ; enter new deductble value
|
||||
DEDCT1 S DIR(0)="FAO",DIR("A")="ENTER DEDUCTIBLE AMOUNT/"_TYPE_": "
|
||||
S DIR("?")="Type a dollar amount between 0 and "_LIMIT_" with up to 2 decimal places."
|
||||
D ^DIR K DIR I $D(DUOUT)!($D(DTOUT))!(Y']"") S Y=-1 G DEDUCTQ
|
||||
S:Y["$" Y=$P(Y,"$",2)
|
||||
I Y'?.N,Y'?.N1".".N K X,Y,DIR G DEDCT1
|
||||
I Y>(LIMIT+.001) W " -- Deductible exceeds limit." K X,Y,DIR G DEDCT1
|
||||
DEDUCTQ Q (+Y)
|
||||
;
|
||||
HELP W !!,"The effective date must start on the fiscal year, Oct 1.",! G DATE
|
||||
HELP1 S DIC="^DG(43.1,",DIC(0)="QMZ",X="?" D ^DIC K DIC Q
|
||||
HELP2 S DIC="^DGBT(392.3,",DIC(0)="QMZ",X="?" D ^DIC K DIC Q
|
||||
DGBTEF1 ;ALB/SCK - BENEFICIARY TRAVEL UPDATE PARAMETERS INTO FILES ;12/14/92 3/12/93
|
||||
;;1.0;Beneficiary Travel;**2**;September 25, 2001
|
||||
RATES ;enter/edit bene travel parameters;option DGBT BENE TRAVEL RATES
|
||||
S DA=1,DR="720;723;721",DIE="^DG(43," D ^DIE G QUIT:X="^"!($D(DTOUT))!($D(Y)) K DA,DE,DQ,DR,DIE
|
||||
W !!,"New travel rates are determined each fiscal year. The rates should be",!,"entered each year with the effective date of Oct 1.",!
|
||||
W !,"Changing values for the current or past fiscal years could result in changes",!,"to the claims already entered.",!
|
||||
DATE ; change deductible rates for FY
|
||||
S DIR("A")="Select EFFECTIVE DATE",DIR(0)="DO^^E",DIR("?")="^D HELP1^DGBTEF1"
|
||||
D ^DIR K DIR G QUIT:$D(DIRUT) G HELP:$E(Y,4,7)'="1001" S X=+Y
|
||||
S DIC="^DG(43.1,",DIC(0)="ELQMZ"
|
||||
D ^DIC G QUIT:Y'>0 S DA=+Y
|
||||
S DGBTN=$S('$D(^DG(43.1,DA,"BT")):"",1:^DG(43.1,DA,"BT"))
|
||||
S:$D(DGBTN)&($P(DGBTN,"^")]"") DIR("B")=$P(DGBTN,"^")
|
||||
S DGBTDEDV=$$DEDUCT(6,"VISIT") G:DGBTDEDV<0 QUIT1
|
||||
S DIE="^DG(43.1,",DR="30.01///^S X=DGBTDEDV"
|
||||
D ^DIE
|
||||
S:$D(DGBTN)&($P(DGBTN,"^",2)]"") DIR("B")=$P(DGBTN,"^",2)
|
||||
S DGBTDEDM=$$DEDUCT(18,"MONTH") G:DGBTDEDM<0 QUIT1
|
||||
S DIE="^DG(43.1,",DR="30.02///^S X=DGBTDEDM"
|
||||
D ^DIE
|
||||
S DR="30.03;30.05;30.04",DIE="^DG(43.1,"
|
||||
D ^DIE G QUIT1
|
||||
ACCT ; change activation/inactivation dates for accounts
|
||||
W !!,"ACCOUNT TYPES are determined by Fiscal Service and have a direct impact",!,"on the type of questions asked in the Beneficiary Travel CLAIM ENTER/EDIT",!,"option."
|
||||
W !,"DO NOT add to this file unless so instructed by Fiscal Service.",!
|
||||
TYPE ; select account to edit
|
||||
S DIR("A")="Select ACCOUNT",DIR("?")="^D HELP2^DGBTEF1",DIR(0)="FO"
|
||||
D ^DIR K DIR G QUIT:$D(DIRUT) S X=Y
|
||||
S DIC="^DGBT(392.3,",DIC(0)="ELQMZ"
|
||||
D ^DIC G TYPE:Y'>0
|
||||
S DA=+Y,DR="2:4",DIE="^DGBT(392.3," D ^DIE G TYPE
|
||||
NWACT ;enter/edit account file (392.3);option DGBT BENE TRAVEL ACCOUNT
|
||||
W !!?3,"You are about to enter/edit Bene Travel account types. Although",!?3,"this process is now decentralized, changes and additions should be",!?3,"made with extreme care.",!
|
||||
S DIR(0)="Y",DIR("A")="Are you sure you wish to continue",DIR("B")="No" D ^DIR K DIR I $D(DTOUT)!($D(DUOUT))!('Y) G QUIT1
|
||||
ED ; edit data for new account
|
||||
W ! K X,DA
|
||||
S (DIE,DIC)="^DGBT(392.3,",DIC(0)="AEQLMZ",DLAYGO=392.3,DIC("DR")=""
|
||||
D ^DIC K DIC G:$D(DTOUT)!$D(DUOUT)!(X="") QUIT1 G:Y'>0 ED
|
||||
S DR="2///"_$P(Y(0)," ",1)_";3;4;5" ; account number now stuffed, not asked
|
||||
S DA=+Y L ^DGBT(392.3,DA):2 E W !?5,"Another user is editing this entry.",*7 G ED
|
||||
S DIE("NO^")=1
|
||||
D ^DIE L K DR,DIE,DIE("NO^")
|
||||
W ! S DIR(0)="Y",DIR("A")="Would you like to Enter/Edit another ACCOUNT",DIR("B")="Yes"
|
||||
D ^DIR K DIR G:$D(DTOUT)!($D(DUOUT))!(Y=0) QUIT1 G ED
|
||||
QUIT1 ;
|
||||
K DIR,DTOUT,DI,D0,DUOUT,DIRUT,DGBTN,DGBTDEDV,DGBTDEDM
|
||||
QUIT ;
|
||||
K %DT,DA,DIC,DIE,DIE("NO^"),DR,X,Y Q
|
||||
DEDUCT(LIMIT,TYPE) ; enter new deductble value
|
||||
DEDCT1 S DIR(0)="FAO",DIR("A")="ENTER DEDUCTIBLE AMOUNT/"_TYPE_": "
|
||||
S DIR("?")="Type a dollar amount between 0 and "_LIMIT_" with up to 2 decimal places."
|
||||
D ^DIR K DIR I $D(DUOUT)!($D(DTOUT))!(Y']"") S Y=-1 G DEDUCTQ
|
||||
S:Y["$" Y=$P(Y,"$",2)
|
||||
I Y'?.N,Y'?.N1".".N K X,Y,DIR G DEDCT1
|
||||
I Y>(LIMIT+.001) W " -- Deductible exceeds limit." K X,Y,DIR G DEDCT1
|
||||
DEDUCTQ Q (+Y)
|
||||
;
|
||||
HELP W !!,"The effective date must start on the fiscal year, Oct 1.",! G DATE
|
||||
HELP1 S DIC="^DG(43.1,",DIC(0)="QMZ",X="?" D ^DIC K DIC Q
|
||||
HELP2 S DIC="^DGBT(392.3,",DIC(0)="QMZ",X="?" D ^DIC K DIC Q
|
||||
|
|
|
|||
|
|
@ -1,276 +1,270 @@
|
|||
RORHL09 ;HOIFO/BH - HL7 OUTPATIENT DATA: PV1,OBR,OBX ; 3/13/06 9:24am
|
||||
;;1.5;CLINICAL CASE REGISTRIES;**1,5**;Feb 17, 2006;Build 10
|
||||
;
|
||||
; 11/29/2007 BAY/KAM ROR*1.5*5 Rem Call 218601 Correct Outpatient
|
||||
; CPTs not transmitting to the AAC
|
||||
;
|
||||
; This routine uses the following IAs:
|
||||
;
|
||||
; #93 Get stop code from the file #44 (controlled)
|
||||
; #1889 Use of the ENCEVENT^PXKENC API
|
||||
; #1995 $$CODEC^ICPTCOD (supported)
|
||||
; #2309 Read access to the 'AA' x-ref in VISIT file (#9000010)
|
||||
; #3990 $$CODEC^ICDCODE (supported)
|
||||
; #10060 Read access to the file #200 (supported)
|
||||
; #2438 Access to the file #40.8 (field #1) (controlled)
|
||||
;
|
||||
Q
|
||||
;
|
||||
;***** PROCESSES DIAGNOSIS CODES
|
||||
DIAGS() ;
|
||||
N DIAG,IEN,K5,OID,REC,TMP
|
||||
S OID="OICD9"_RORCS_"Diagnosis"_RORCS_"VA080"
|
||||
S K5=""
|
||||
F S K5=$O(^TMP("PXKENC",$J,RORIEN,"POV",K5)) Q:K5="" D
|
||||
. S REC=^TMP("PXKENC",$J,RORIEN,"POV",K5,0)
|
||||
. S IEN=+$P(REC,U) Q:IEN'>0
|
||||
. ;---
|
||||
. S DIAG=$$CODEC^ICDCODE(IEN)
|
||||
. D:DIAG'<0 SETOBX(OID,DIAG)
|
||||
Q 0
|
||||
;
|
||||
;***** OUTPATIENT DATA SEGMENT BUILDER
|
||||
;
|
||||
; RORDFN DFN of Patient Record in File #2
|
||||
;
|
||||
; .DXDTS Reference to a local variable where the
|
||||
; data extraction time frames are stored.
|
||||
;
|
||||
; RORTY Set to either "PV1" or "OBR"
|
||||
;
|
||||
; The ^TMP("PXKENC",$J) and ^TMP("RORHL08",$J) global nodes are
|
||||
; used by this function.
|
||||
;
|
||||
; Return Values:
|
||||
; <0 Error Code
|
||||
; 0 Ok
|
||||
; >0 Non-fatal error(s)
|
||||
;
|
||||
EN1(RORDFN,DXDTS,RORTY) ;
|
||||
N ERRCNT,PIEN,PV1CNT,RC
|
||||
S (ERRCNT,RC)=0
|
||||
;
|
||||
;--- PV1 Segments
|
||||
I RORTY="PV1" K ^TMP("PXKENC",$J),^TMP("RORHL09",$J) D
|
||||
. N IDX,INVDT,ROREND
|
||||
. S (IDX,PV1CNT)=0
|
||||
. F S IDX=$O(DXDTS(2,IDX)) Q:IDX'>0 D Q:RC<0
|
||||
. . S INVDT=9999999-$$FMADD^XLFDT($P(DXDTS(2,IDX),U)\1,-1)
|
||||
. . S ROREND=9999999-$P(DXDTS(2,IDX),U,2)
|
||||
. . F S INVDT=$O(^AUPNVSIT("AA",RORDFN,INVDT),-1) Q:'INVDT!(INVDT'>ROREND) D
|
||||
. . . S PIEN=""
|
||||
. . . F S PIEN=$O(^AUPNVSIT("AA",RORDFN,INVDT,PIEN),-1) Q:'PIEN D
|
||||
. . . . S TMP=$$PV1(PIEN,RORDFN)
|
||||
. . . . I TMP Q:TMP<0 S ERRCNT=ERRCNT+TMP
|
||||
. . . . ;--- Reference for the corresponding OBR segment
|
||||
. . . . S:TMP'="S" PV1CNT=PV1CNT+1,^TMP("RORHL09",$J,PV1CNT)=PIEN
|
||||
;
|
||||
;--- OBR and OBX Segments
|
||||
I RORTY="OBR" D K ^TMP("PXKENC",$J),^TMP("RORHL09",$J)
|
||||
. S PV1CNT=0
|
||||
. F S PV1CNT=$O(^TMP("RORHL09",$J,PV1CNT)) Q:PV1CNT'>0 D
|
||||
. . S PIEN=+$G(^TMP("RORHL09",$J,PV1CNT)) Q:PIEN'>0
|
||||
. . ;---
|
||||
. . S TMP=$$OBR(PIEN,RORDFN)
|
||||
. . I TMP Q:TMP<0 S ERRCNT=ERRCNT+TMP
|
||||
. . ;---
|
||||
. . S TMP=$$OBX(PIEN,RORDFN)
|
||||
. . I TMP Q:TMP<0 S ERRCNT=ERRCNT+TMP
|
||||
;
|
||||
;--- Check for errors
|
||||
Q $S(RC<0:RC,1:ERRCNT)
|
||||
;
|
||||
;***** OBR SEGMENT BUILDER (OUTPATIENT)
|
||||
;
|
||||
; RORIEN IEN of file #9000010
|
||||
; RORDFN DFN of Patient Record in File #2
|
||||
;
|
||||
; Return Values:
|
||||
; <0 Error Code
|
||||
; 0 Ok
|
||||
; >0 Non-fatal error(s)
|
||||
;
|
||||
OBR(RORIEN,RORDFN) ;
|
||||
N CS,ERRCNT,RC,RORSEG,STN,TMP,VST0
|
||||
S (ERRCNT,RC)=0
|
||||
D ECH^RORHL7(.CS)
|
||||
;
|
||||
S VST0=$G(^TMP("PXKENC",$J,RORIEN,"VST",RORIEN,0))
|
||||
;
|
||||
;--- Initialize the segment
|
||||
S RORSEG(0)="OBR"
|
||||
;
|
||||
;--- OBR-3 - Order Number (IEN in the VISIT file #9000010)
|
||||
S RORSEG(3)=RORIEN
|
||||
;
|
||||
;--- OBR-4 - Universal Service ID
|
||||
S RORSEG(4)="OP"_CS_"Outpatient"_CS_"C4"
|
||||
;
|
||||
;--- OBR-7 - Observation Date/Time (Visit Date/Time) *KEY*
|
||||
S TMP=$$FMTHL7^XLFDT($P(VST0,U))
|
||||
Q:TMP'>0 $$ERROR^RORERR(-100,,,,"No visit date","ENCEVENT^PXKENC")
|
||||
S RORSEG(7)=TMP
|
||||
;
|
||||
;--- OBR-24 - Diagnostic Service ID
|
||||
S RORSEG(24)="PHY"
|
||||
;
|
||||
;--- OBR-44 - Division
|
||||
S RORSEG(44)=$$SITE^RORUTL03(CS)
|
||||
S TMP=+$P(VST0,U,6) ; LOC. OF ENCOUNTER (.06)
|
||||
I TMP>0 D
|
||||
. S TMP=$$NS^XUAF4(TMP),STN=$P(TMP,U,2)
|
||||
. S:STN'="" RORSEG(44)=STN_CS_$P(TMP,U)_CS_"99VA4"
|
||||
;
|
||||
;--- Store the segment
|
||||
D ADDSEG^RORHL7(.RORSEG)
|
||||
Q ERRCNT
|
||||
;
|
||||
;***** OBX SEGMENT BUILDER (OUTPATIENT)
|
||||
;
|
||||
; RORIEN IEN of file #9000010
|
||||
; RORDFN DFN of Patient Record in File #2
|
||||
;
|
||||
; Return Values:
|
||||
; <0 Error Code
|
||||
; 0 Ok
|
||||
; >0 Non-fatal error(s)
|
||||
;
|
||||
OBX(RORIEN,RORDFN) ;
|
||||
N ERRCNT,RC,RORCS,RORLST,RORMSG,RORSEG,TMP
|
||||
S (ERRCNT,RC)=0
|
||||
D ECH^RORHL7(.RORCS)
|
||||
;
|
||||
;--- Procedures
|
||||
I $D(^TMP("PXKENC",$J,RORIEN,"CPT"))>1 D Q:RC<0 RC
|
||||
. S RC=$$PROCS() S:RC ERRCNT=ERRCNT+1
|
||||
;--- Diagnosis codes
|
||||
I $D(^TMP("PXKENC",$J,RORIEN,"POV"))>1 D Q:RC<0 RC
|
||||
. S RC=$$DIAGS() S:RC ERRCNT=ERRCNT+1
|
||||
;
|
||||
Q ERRCNT
|
||||
;
|
||||
;***** PROCESSES PROCEDURES
|
||||
PROCS() ;
|
||||
N CLASS,ERRCNT,IEN,K5,OID,PROC,PRV,REC,RORMSG,TMP
|
||||
S ERRCNT=0
|
||||
S OID="OCPT"_RORCS_"Procedures"_RORCS_"VA080"
|
||||
S K5=""
|
||||
F S K5=$O(^TMP("PXKENC",$J,RORIEN,"CPT",K5)) Q:K5="" D
|
||||
. S REC=$G(^TMP("PXKENC",$J,RORIEN,"CPT",K5,0))
|
||||
. S IEN=+$P(REC,U) Q:IEN'>0
|
||||
. ;---
|
||||
. S PROC=$$CODEC^ICPTCOD(IEN)
|
||||
. Q:PROC<0
|
||||
. ;---
|
||||
. S PRV=+$P($G(^TMP("PXKENC",$J,RORIEN,"CPT",K5,12)),U,4)
|
||||
. ;12/06/2007 BAY/KAM REM CALL 218601 Modified next 8 lines
|
||||
. ;---
|
||||
. I PRV>0 D
|
||||
.. S $P(PRV,RORCS,13)=$$GET1^DIQ(200,PRV_",",53.5,"E",,"RORMSG")
|
||||
.. I $G(DIERR) D S ERRCNT=ERRCNT+1
|
||||
... D DBS^RORERR("RORMSG",-99,,RORDFN,200,+PRV_",")
|
||||
. E S PRV=""
|
||||
. ;----------> End of changes for 218601
|
||||
. ;---
|
||||
. D SETOBX(OID,PROC,PRV)
|
||||
Q ERRCNT
|
||||
;
|
||||
;***** PV1 SEGMENT BUILDER (OUTPATIENT)
|
||||
;
|
||||
; RORIEN IEN in the file #9000010
|
||||
; RORDFN DFN of Patient Record in File #2
|
||||
;
|
||||
; Return Values:
|
||||
; <0 Error Code
|
||||
; 0 Ok
|
||||
; "S" No visit data
|
||||
; >0 Non-fatal error(s)
|
||||
;
|
||||
PV1(RORIEN,RORDFN) ;
|
||||
N BUF,CLASS,CS,ERRCNT,IENS,KK4,RC,REC,REP,RORCLIN,RORMSG,PRV,TMP,TMP1,VST0
|
||||
S (ERRCNT,RC)=0
|
||||
D ECH^RORHL7(.CS,,.REP)
|
||||
;
|
||||
;--- Get Visit Data
|
||||
D ENCEVENT^PXKENC(RORIEN,1)
|
||||
Q:$D(^TMP("PXKENC",$J,RORIEN))<10 "S"
|
||||
S VST0=$G(^TMP("PXKENC",$J,RORIEN,"VST",RORIEN,0))
|
||||
;
|
||||
;--- Do not send visits with the following service categories: Daily
|
||||
;--- Hospitalization (D), Ancillary (X), Chart (C), Not Found (N),
|
||||
; (E), Event Historical, Hospitalization (H).
|
||||
Q:"HEDXNC"[$P(VST0,U,7) "S"
|
||||
;
|
||||
;--- Initialize the segment
|
||||
S RORSEG(0)="PV1"
|
||||
;
|
||||
;--- PV1-2 - Patient Class
|
||||
S RORSEG(2)="O" ; O - Outpatient
|
||||
;
|
||||
;--- PV1-3 - Assigned Patient Location (Station Number and Stop Code)
|
||||
S RORCLIN=+$P(VST0,U,22),BUF=""
|
||||
I RORCLIN>0 D
|
||||
. S IENS=RORCLIN_","
|
||||
. S TMP=$$GET1^DIQ(44,IENS,3.5,"I") Q:TMP'>0
|
||||
. S BUF=$$GET1^DIQ(40.8,TMP,1) Q:BUF="" ; Station Number
|
||||
. S TMP=$$STOPCODE^RORUTL18(+RORCLIN)
|
||||
. S $P(BUF,CS,6)=$S(TMP>0:TMP,1:"") ; Stop Code
|
||||
Q:$P(BUF,CS,6)="" "S" ; Stop Code is required
|
||||
S RORSEG(3)=BUF
|
||||
;
|
||||
; PV1-4 - Admission Type
|
||||
S TMP=$P($G(^TMP("PXKENC",$J,RORIEN,"VST",RORIEN,150)),U,3)
|
||||
S RORSEG(4)=TMP
|
||||
;
|
||||
;--- PV1-7 - Attending Physician (User IEN and Provider Class Name)
|
||||
S (KK4,BUF)=""
|
||||
F S KK4=$O(^TMP("PXKENC",$J,RORIEN,"PRV",KK4)) Q:KK4="" D
|
||||
. S REC=$G(^TMP("PXKENC",$J,RORIEN,"PRV",KK4,0))
|
||||
. S PRV=+$P(REC,U) Q:(PRV'>0)!($P(REC,U,4)'="P")
|
||||
. S $P(PRV,CS,13)=$$GET1^DIQ(200,PRV_",",53.5,"E",,"RORMSG")
|
||||
. I $G(DIERR) D S ERRCNT=ERRCNT+1
|
||||
. . D DBS^RORERR("RORMSG",-99,,RORDFN,200,PRV_",")
|
||||
. S BUF=BUF_REP_PRV
|
||||
S RORSEG(7)=$P(BUF,REP,2,999)
|
||||
;
|
||||
;--- PV1-19 - Visit Number (IEN in the VISIT file #9000010) *KEY*
|
||||
S RORSEG(19)=RORIEN
|
||||
;
|
||||
;--- PV1-44 - Admit Date/Time (Visit Date/Time) *KEY*
|
||||
S TMP=$$FMTHL7^XLFDT($P(VST0,U))
|
||||
I TMP'>0 D Q RC
|
||||
. S RC=$$ERROR^RORERR(-100,,,,"No admission date","ENCEVENT^PXKENC")
|
||||
S RORSEG(44)=TMP
|
||||
;
|
||||
;--- PV1-51 - Visit Indicator (Deleted Visit Indicator)
|
||||
S TMP=$P(VST0,U,11)
|
||||
S RORSEG(51)=$S(TMP'="":TMP,1:0)
|
||||
;
|
||||
;--- Store the segment
|
||||
D ADDSEG^RORHL7(.RORSEG)
|
||||
Q ERRCNT
|
||||
;
|
||||
;***** LOW-LEVEL SEGMENT BUILDER
|
||||
;
|
||||
; OBX3 Observation Identifier
|
||||
;
|
||||
; OBX5 Observation Value
|
||||
;
|
||||
; [OBX16] Procedure Provider and Provider Class Name
|
||||
;
|
||||
SETOBX(OBX3,OBX5,OBX16) ;
|
||||
N RORSEG
|
||||
S RORSEG(0)="OBX"
|
||||
;--- OBX-2 Value Type
|
||||
S RORSEG(2)="FT"
|
||||
;--- OBX-3 Observation Identifier
|
||||
S RORSEG(3)=OBX3
|
||||
;--- OBX-5 Observation Value
|
||||
S RORSEG(5)=OBX5
|
||||
;--- OBX-11 Observation Result Status
|
||||
S RORSEG(11)="F"
|
||||
;--- OBX-16 Responsible Observer (Procedure Provider)
|
||||
S:$G(OBX16)'="" RORSEG(16)=OBX16
|
||||
;--- Store the segment
|
||||
D ADDSEG^RORHL7(.RORSEG)
|
||||
Q
|
||||
RORHL09 ;HOIFO/BH - HL7 OUTPATIENT DATA: PV1,OBR,OBX ; 3/13/06 9:24am
|
||||
;;1.5;CLINICAL CASE REGISTRIES;**1**;Feb 17, 2006;Build 24
|
||||
;
|
||||
; This routine uses the following IAs:
|
||||
;
|
||||
; #93 Get stop code from the file #44 (controlled)
|
||||
; #1889 Use of the ENCEVENT^PXKENC API
|
||||
; #1995 $$CODEC^ICPTCOD (supported)
|
||||
; #2309 Read access to the 'AA' x-ref in VISIT file (#9000010)
|
||||
; #3990 $$CODEC^ICDCODE (supported)
|
||||
; #10060 Read access to the file #200 (supported)
|
||||
; #2438 Access to the file #40.8 (field #1) (controlled)
|
||||
;
|
||||
Q
|
||||
;
|
||||
;***** PROCESSES DIAGNOSIS CODES
|
||||
DIAGS() ;
|
||||
N DIAG,IEN,K5,OID,REC,TMP
|
||||
S OID="OICD9"_RORCS_"Diagnosis"_RORCS_"VA080"
|
||||
S K5=""
|
||||
F S K5=$O(^TMP("PXKENC",$J,RORIEN,"POV",K5)) Q:K5="" D
|
||||
. S REC=^TMP("PXKENC",$J,RORIEN,"POV",K5,0)
|
||||
. S IEN=+$P(REC,U) Q:IEN'>0
|
||||
. ;---
|
||||
. S DIAG=$$CODEC^ICDCODE(IEN)
|
||||
. D:DIAG'<0 SETOBX(OID,DIAG)
|
||||
Q 0
|
||||
;
|
||||
;***** OUTPATIENT DATA SEGMENT BUILDER
|
||||
;
|
||||
; RORDFN DFN of Patient Record in File #2
|
||||
;
|
||||
; .DXDTS Reference to a local variable where the
|
||||
; data extraction time frames are stored.
|
||||
;
|
||||
; RORTY Set to either "PV1" or "OBR"
|
||||
;
|
||||
; The ^TMP("PXKENC",$J) and ^TMP("RORHL08",$J) global nodes are
|
||||
; used by this function.
|
||||
;
|
||||
; Return Values:
|
||||
; <0 Error Code
|
||||
; 0 Ok
|
||||
; >0 Non-fatal error(s)
|
||||
;
|
||||
EN1(RORDFN,DXDTS,RORTY) ;
|
||||
N ERRCNT,PIEN,PV1CNT,RC
|
||||
S (ERRCNT,RC)=0
|
||||
;
|
||||
;--- PV1 Segments
|
||||
I RORTY="PV1" K ^TMP("PXKENC",$J),^TMP("RORHL09",$J) D
|
||||
. N IDX,INVDT,ROREND
|
||||
. S (IDX,PV1CNT)=0
|
||||
. F S IDX=$O(DXDTS(2,IDX)) Q:IDX'>0 D Q:RC<0
|
||||
. . S INVDT=9999999-$$FMADD^XLFDT($P(DXDTS(2,IDX),U)\1,-1)
|
||||
. . S ROREND=9999999-$P(DXDTS(2,IDX),U,2)
|
||||
. . F S INVDT=$O(^AUPNVSIT("AA",RORDFN,INVDT),-1) Q:'INVDT!(INVDT'>ROREND) D
|
||||
. . . S PIEN=""
|
||||
. . . F S PIEN=$O(^AUPNVSIT("AA",RORDFN,INVDT,PIEN),-1) Q:'PIEN D
|
||||
. . . . S TMP=$$PV1(PIEN,RORDFN)
|
||||
. . . . I TMP Q:TMP<0 S ERRCNT=ERRCNT+TMP
|
||||
. . . . ;--- Reference for the corresponding OBR segment
|
||||
. . . . S:TMP'="S" PV1CNT=PV1CNT+1,^TMP("RORHL09",$J,PV1CNT)=PIEN
|
||||
;
|
||||
;--- OBR and OBX Segments
|
||||
I RORTY="OBR" D K ^TMP("PXKENC",$J),^TMP("RORHL09",$J)
|
||||
. S PV1CNT=0
|
||||
. F S PV1CNT=$O(^TMP("RORHL09",$J,PV1CNT)) Q:PV1CNT'>0 D
|
||||
. . S PIEN=+$G(^TMP("RORHL09",$J,PV1CNT)) Q:PIEN'>0
|
||||
. . ;---
|
||||
. . S TMP=$$OBR(PIEN,RORDFN)
|
||||
. . I TMP Q:TMP<0 S ERRCNT=ERRCNT+TMP
|
||||
. . ;---
|
||||
. . S TMP=$$OBX(PIEN,RORDFN)
|
||||
. . I TMP Q:TMP<0 S ERRCNT=ERRCNT+TMP
|
||||
;
|
||||
;--- Check for errors
|
||||
Q $S(RC<0:RC,1:ERRCNT)
|
||||
;
|
||||
;***** OBR SEGMENT BUILDER (OUTPATIENT)
|
||||
;
|
||||
; RORIEN IEN of file #9000010
|
||||
; RORDFN DFN of Patient Record in File #2
|
||||
;
|
||||
; Return Values:
|
||||
; <0 Error Code
|
||||
; 0 Ok
|
||||
; >0 Non-fatal error(s)
|
||||
;
|
||||
OBR(RORIEN,RORDFN) ;
|
||||
N CS,ERRCNT,RC,RORSEG,STN,TMP,VST0
|
||||
S (ERRCNT,RC)=0
|
||||
D ECH^RORHL7(.CS)
|
||||
;
|
||||
S VST0=$G(^TMP("PXKENC",$J,RORIEN,"VST",RORIEN,0))
|
||||
;
|
||||
;--- Initialize the segment
|
||||
S RORSEG(0)="OBR"
|
||||
;
|
||||
;--- OBR-3 - Order Number (IEN in the VISIT file #9000010)
|
||||
S RORSEG(3)=RORIEN
|
||||
;
|
||||
;--- OBR-4 - Universal Service ID
|
||||
S RORSEG(4)="OP"_CS_"Outpatient"_CS_"C4"
|
||||
;
|
||||
;--- OBR-7 - Observation Date/Time (Visit Date/Time) *KEY*
|
||||
S TMP=$$FMTHL7^XLFDT($P(VST0,U))
|
||||
Q:TMP'>0 $$ERROR^RORERR(-100,,,,"No visit date","ENCEVENT^PXKENC")
|
||||
S RORSEG(7)=TMP
|
||||
;
|
||||
;--- OBR-24 - Diagnostic Service ID
|
||||
S RORSEG(24)="PHY"
|
||||
;
|
||||
;--- OBR-44 - Division
|
||||
S RORSEG(44)=$$SITE^RORUTL03(CS)
|
||||
S TMP=+$P(VST0,U,6) ; LOC. OF ENCOUNTER (.06)
|
||||
I TMP>0 D
|
||||
. S TMP=$$NS^XUAF4(TMP),STN=$P(TMP,U,2)
|
||||
. S:STN'="" RORSEG(44)=STN_CS_$P(TMP,U)_CS_"99VA4"
|
||||
;
|
||||
;--- Store the segment
|
||||
D ADDSEG^RORHL7(.RORSEG)
|
||||
Q ERRCNT
|
||||
;
|
||||
;***** OBX SEGMENT BUILDER (OUTPATIENT)
|
||||
;
|
||||
; RORIEN IEN of file #9000010
|
||||
; RORDFN DFN of Patient Record in File #2
|
||||
;
|
||||
; Return Values:
|
||||
; <0 Error Code
|
||||
; 0 Ok
|
||||
; >0 Non-fatal error(s)
|
||||
;
|
||||
OBX(RORIEN,RORDFN) ;
|
||||
N ERRCNT,RC,RORCS,RORLST,RORMSG,RORSEG,TMP
|
||||
S (ERRCNT,RC)=0
|
||||
D ECH^RORHL7(.RORCS)
|
||||
;
|
||||
;--- Procedures
|
||||
I $D(^TMP("PXKENC",$J,RORIEN,"CPT"))>1 D Q:RC<0 RC
|
||||
. S RC=$$PROCS() S:RC ERRCNT=ERRCNT+1
|
||||
;--- Diagnosis codes
|
||||
I $D(^TMP("PXKENC",$J,RORIEN,"POV"))>1 D Q:RC<0 RC
|
||||
. S RC=$$DIAGS() S:RC ERRCNT=ERRCNT+1
|
||||
;
|
||||
Q ERRCNT
|
||||
;
|
||||
;***** PROCESSES PROCEDURES
|
||||
PROCS() ;
|
||||
N CLASS,ERRCNT,IEN,K5,OID,PROC,PRV,REC,RORMSG,TMP
|
||||
S ERRCNT=0
|
||||
S OID="OCPT"_RORCS_"Procedures"_RORCS_"VA080"
|
||||
S K5=""
|
||||
F S K5=$O(^TMP("PXKENC",$J,RORIEN,"CPT",K5)) Q:K5="" D
|
||||
. S REC=$G(^TMP("PXKENC",$J,RORIEN,"CPT",K5,0))
|
||||
. S IEN=+$P(REC,U) Q:IEN'>0
|
||||
. ;---
|
||||
. S PROC=$$CODEC^ICPTCOD(IEN)
|
||||
. Q:PROC<0
|
||||
. ;---
|
||||
. S PRV=+$P($G(^TMP("PXKENC",$J,RORIEN,"CPT",K5,12)),U,4)
|
||||
. Q:PRV'>0
|
||||
. ;---
|
||||
. S $P(PRV,RORCS,13)=$$GET1^DIQ(200,PRV_",",53.5,"E",,"RORMSG")
|
||||
. I $G(DIERR) D S ERRCNT=ERRCNT+1
|
||||
. . D DBS^RORERR("RORMSG",-99,,RORDFN,200,+PRV_",")
|
||||
. ;---
|
||||
. D SETOBX(OID,PROC,PRV)
|
||||
Q ERRCNT
|
||||
;
|
||||
;***** PV1 SEGMENT BUILDER (OUTPATIENT)
|
||||
;
|
||||
; RORIEN IEN in the file #9000010
|
||||
; RORDFN DFN of Patient Record in File #2
|
||||
;
|
||||
; Return Values:
|
||||
; <0 Error Code
|
||||
; 0 Ok
|
||||
; "S" No visit data
|
||||
; >0 Non-fatal error(s)
|
||||
;
|
||||
PV1(RORIEN,RORDFN) ;
|
||||
N BUF,CLASS,CS,ERRCNT,IENS,KK4,RC,REC,REP,RORCLIN,RORMSG,PRV,TMP,TMP1,VST0
|
||||
S (ERRCNT,RC)=0
|
||||
D ECH^RORHL7(.CS,,.REP)
|
||||
;
|
||||
;--- Get Visit Data
|
||||
D ENCEVENT^PXKENC(RORIEN,1)
|
||||
Q:$D(^TMP("PXKENC",$J,RORIEN))<10 "S"
|
||||
S VST0=$G(^TMP("PXKENC",$J,RORIEN,"VST",RORIEN,0))
|
||||
;
|
||||
;--- Do not send visits with the following service categories: Daily
|
||||
;--- Hospitalization (D), Ancillary (X), Chart (C), Not Found (N),
|
||||
; (E), Event Historical, Hospitalization (H).
|
||||
Q:"HEDXNC"[$P(VST0,U,7) "S"
|
||||
;
|
||||
;--- Initialize the segment
|
||||
S RORSEG(0)="PV1"
|
||||
;
|
||||
;--- PV1-2 - Patient Class
|
||||
S RORSEG(2)="O" ; O - Outpatient
|
||||
;
|
||||
;--- PV1-3 - Assigned Patient Location (Station Number and Stop Code)
|
||||
S RORCLIN=+$P(VST0,U,22),BUF=""
|
||||
I RORCLIN>0 D
|
||||
. S IENS=RORCLIN_","
|
||||
. S TMP=$$GET1^DIQ(44,IENS,3.5,"I") Q:TMP'>0
|
||||
. S BUF=$$GET1^DIQ(40.8,TMP,1) Q:BUF="" ; Station Number
|
||||
. S TMP=$$STOPCODE^RORUTL18(+RORCLIN)
|
||||
. S $P(BUF,CS,6)=$S(TMP>0:TMP,1:"") ; Stop Code
|
||||
Q:$P(BUF,CS,6)="" "S" ; Stop Code is required
|
||||
S RORSEG(3)=BUF
|
||||
;
|
||||
; PV1-4 - Admission Type
|
||||
S TMP=$P($G(^TMP("PXKENC",$J,RORIEN,"VST",RORIEN,150)),U,3)
|
||||
S RORSEG(4)=TMP
|
||||
;
|
||||
;--- PV1-7 - Attending Physician (User IEN and Provider Class Name)
|
||||
S (KK4,BUF)=""
|
||||
F S KK4=$O(^TMP("PXKENC",$J,RORIEN,"PRV",KK4)) Q:KK4="" D
|
||||
. S REC=$G(^TMP("PXKENC",$J,RORIEN,"PRV",KK4,0))
|
||||
. S PRV=+$P(REC,U) Q:(PRV'>0)!($P(REC,U,4)'="P")
|
||||
. S $P(PRV,CS,13)=$$GET1^DIQ(200,PRV_",",53.5,"E",,"RORMSG")
|
||||
. I $G(DIERR) D S ERRCNT=ERRCNT+1
|
||||
. . D DBS^RORERR("RORMSG",-99,,RORDFN,200,PRV_",")
|
||||
. S BUF=BUF_REP_PRV
|
||||
S RORSEG(7)=$P(BUF,REP,2,999)
|
||||
;
|
||||
;--- PV1-19 - Visit Number (IEN in the VISIT file #9000010) *KEY*
|
||||
S RORSEG(19)=RORIEN
|
||||
;
|
||||
;--- PV1-44 - Admit Date/Time (Visit Date/Time) *KEY*
|
||||
S TMP=$$FMTHL7^XLFDT($P(VST0,U))
|
||||
I TMP'>0 D Q RC
|
||||
. S RC=$$ERROR^RORERR(-100,,,,"No admission date","ENCEVENT^PXKENC")
|
||||
S RORSEG(44)=TMP
|
||||
;
|
||||
;--- PV1-51 - Visit Indicator (Deleted Visit Indicator)
|
||||
S TMP=$P(VST0,U,11)
|
||||
S RORSEG(51)=$S(TMP'="":TMP,1:0)
|
||||
;
|
||||
;--- Store the segment
|
||||
D ADDSEG^RORHL7(.RORSEG)
|
||||
Q ERRCNT
|
||||
;
|
||||
;***** LOW-LEVEL SEGMENT BUILDER
|
||||
;
|
||||
; OBX3 Observation Identifier
|
||||
;
|
||||
; OBX5 Observation Value
|
||||
;
|
||||
; [OBX16] Procedure Provider and Provider Class Name
|
||||
;
|
||||
SETOBX(OBX3,OBX5,OBX16) ;
|
||||
N RORSEG
|
||||
S RORSEG(0)="OBX"
|
||||
;--- OBX-2 Value Type
|
||||
S RORSEG(2)="FT"
|
||||
;--- OBX-3 Observation Identifier
|
||||
S RORSEG(3)=OBX3
|
||||
;--- OBX-5 Observation Value
|
||||
S RORSEG(5)=OBX5
|
||||
;--- OBX-11 Observation Result Status
|
||||
S RORSEG(11)="F"
|
||||
;--- OBX-16 Responsible Observer (Procedure Provider)
|
||||
S:$G(OBX16)'="" RORSEG(16)=OBX16
|
||||
;--- Store the segment
|
||||
D ADDSEG^RORHL7(.RORSEG)
|
||||
Q
|
||||
|
|
|
|||
|
|
@ -1,188 +1,228 @@
|
|||
RGEVPRG ;BAY/ALS-OPTIONS TO PURGE MPI/PD EXCEPTIONS ;08/23/99
|
||||
;;1.0;CLINICAL INFO RESOURCE NETWORK;**3,12,19,32,35,43,44,50,52**;30 Apr 99;Build 2
|
||||
;
|
||||
MAIN ;
|
||||
;Q:($D(^TMP("RGEXC")))!($D(^TMP("RGEXC2")))
|
||||
L +^RGHL7(991.1):0 I '$T Q
|
||||
L -^RGHL7(991.1)
|
||||
L +^RGHL7(991.1,"RG PURGE EXCEPTION"):5 E Q
|
||||
I $D(ZTQUEUED) S ZTREQ="@"
|
||||
S $P(^RGSITE(991.8,1,"EXCPRG"),"^",1)=$$NOW^XLFDT
|
||||
S $P(^RGSITE(991.8,1,"EXCPRG"),"^",3)="R"
|
||||
;D PROC ;**52 Module is obsolete
|
||||
D PRGDUP
|
||||
D PRG30
|
||||
D PRGZZ
|
||||
S $P(^RGSITE(991.8,1,"EXCPRG"),"^",2)=$$NOW^XLFDT
|
||||
S $P(^RGSITE(991.8,1,"EXCPRG"),"^",3)="C"
|
||||
L -^RGHL7(991.1,"RG PURGE EXCEPTION")
|
||||
Q
|
||||
PRGPAT ;Purge by Patient
|
||||
W !
|
||||
S DIC="^DPT(",DIC(0)="QEAM",DIC("A")="Select PATIENT: "
|
||||
D ^DIC K DIC G:Y<0 QUIT S RGDFN=+Y
|
||||
S EXCT="",FLAG=0
|
||||
F S EXCT=$O(^RGHL7(991.1,"ADFN",EXCT)) Q:EXCT="" D
|
||||
. I $D(^RGHL7(991.1,"ADFN",EXCT,RGDFN)) S FLAG=1 Q
|
||||
I FLAG=0 W !,"There are no exceptions on file for this patient." G PRGPAT
|
||||
I $$IFLOCAL^MPIF001(RGDFN) W !,"This patient does not have a national ICN assigned, do not purge." Q
|
||||
S DFN=RGDFN D DEM^VADPT
|
||||
S DIR(0)="YA",DIR("B")="YES"
|
||||
S DIR("A")="Are you sure you want to purge all exceptions on file for "_VADM(1)_"? YES// "
|
||||
D ^DIR Q:$D(DIRUT) I Y>0 D
|
||||
. S EXCT="",CNT=0
|
||||
. F S EXCT=$O(^RGHL7(991.1,"ADFN",EXCT)) Q:'EXCT D
|
||||
.. S IEN=0
|
||||
.. F S IEN=$O(^RGHL7(991.1,"ADFN",EXCT,RGDFN,IEN)) Q:'IEN D
|
||||
... S IEN2=0
|
||||
... F S IEN2=$O(^RGHL7(991.1,"ADFN",EXCT,RGDFN,IEN,IEN2)) Q:'IEN2 D
|
||||
.... S NUM="" S NUM=$P(^RGHL7(991.1,IEN,1,0),"^",4)
|
||||
.... I NUM=1 S DIK="^RGHL7(991.1,",DA=IEN D ^DIK K DIK,DA S CNT=CNT+1
|
||||
.... E I NUM>1 D DEL
|
||||
. W !,"All exceptions purged for "_VADM(1)_" DFN: "_RGDFN
|
||||
K EXCT,DFN,FLAG,VADM,CNT,IEN,IEN2,NUM,RGDFN,Y
|
||||
QUIT Q
|
||||
;
|
||||
PRGDT ; Purge by Date
|
||||
W !!,"Enter a date for the purge. All exceptions on file, on or before that date, will be deleted."
|
||||
K DIR,DIRUT,DTOUT,DUOUT
|
||||
S DIR(0)="DA^:DT:EPX",DIR("A")="Enter Date for Purge: "
|
||||
D ^DIR K DIR Q:$D(DIRUT)
|
||||
S PURDT=Y
|
||||
S PDATE=$$FMTE^XLFDT(PURDT)
|
||||
S DIR(0)="YA",DIR("B")="YES"
|
||||
S DIR("A")="Are you sure you want to purge all exceptions on file dated on or before "_PDATE_"? YES// "
|
||||
D ^DIR Q:$D(DIRUT) I Y>0 D
|
||||
. S EXCDT="",CNT=0
|
||||
. F S EXCDT=$O(^RGHL7(991.1,"AD",EXCDT)) Q:'EXCDT D
|
||||
.. I ($P(EXCDT,".",1)=PURDT)!($P(EXCDT,".",1)<PURDT) D
|
||||
... S IEN=0
|
||||
... F S IEN=$O(^RGHL7(991.1,"AD",EXCDT,IEN)) Q:'IEN D
|
||||
.... S NUM="" S NUM=$P($G(^RGHL7(991.1,IEN,1,0)),"^",4) Q:NUM<1
|
||||
.... S CNT=CNT+NUM
|
||||
.... S DIK="^RGHL7(991.1,",DA=IEN
|
||||
.... D ^DIK K DIK,DA
|
||||
I CNT=0 W !,"There are no exceptions dated on or before "_PDATE_", no data to purge."
|
||||
E I CNT>0 W !,CNT_" exceptions, dated on or before "_PDATE_" have been purged!"
|
||||
K PDATE,PURDT,EXCDT,CNT,IEN,NUM,Y
|
||||
Q
|
||||
PRG30 ; Purge Exceptions over 30 days old
|
||||
S TODAY=""
|
||||
S TODAY=$$NOW^XLFDT D
|
||||
. S EXCDT="",CNT=0,DIFF=""
|
||||
. F S EXCDT=$O(^RGHL7(991.1,"AD",EXCDT)) Q:'EXCDT D
|
||||
.. S DIFF=$$FMDIFF^XLFDT(TODAY,EXCDT)
|
||||
.. I DIFF>30 D
|
||||
... S IEN=0
|
||||
... F S IEN=$O(^RGHL7(991.1,"AD",EXCDT,IEN)) Q:'IEN D
|
||||
.... S NUM="" S NUM=$P($G(^RGHL7(991.1,IEN,1,0)),"^",4) Q:'NUM
|
||||
.... S IEN2=0
|
||||
.... F S IEN2=$O(^RGHL7(991.1,IEN,1,IEN2)) Q:'IEN2 D
|
||||
..... S STAT=""
|
||||
..... S STAT=$P(^RGHL7(991.1,IEN,1,IEN2,0),"^",5)
|
||||
..... ; Only delete PROCESSED exceptions
|
||||
..... I (STAT>0)!(STAT="") D
|
||||
...... I NUM>1 D DEL
|
||||
...... E I NUM=1 D
|
||||
....... S CNT=CNT+NUM
|
||||
....... S DIK="^RGHL7(991.1,",DA=IEN
|
||||
....... D ^DIK K DIK,DA
|
||||
K DIFF,TODAY,EXCDT,CNT,IEN,IEN2,NUM,STAT
|
||||
Q
|
||||
PRGEXC ; Purge by Exception Type
|
||||
;**52 This module was obsolete before 52; just adding comment
|
||||
;S DIC="^RGHL7(991.11,",DIC(0)="QEAM"
|
||||
;S DIC("A")="Enter an exception type to purge: "
|
||||
;D ^DIC K DIC G:Y<200 QUIT S EXCTYP=+Y,ETYPE=X
|
||||
;S DIR(0)="YA",DIR("B")="YES"
|
||||
;S DIR("A")="*WARNING* This will permanently delete all "_ETYPE_" exceptions. Are you sure you want to do this? YES// "
|
||||
;D ^DIR Q:$D(DIRUT) I Y>0 D
|
||||
;. S CNT=0,IEN=""
|
||||
;. F S IEN=$O(^RGHL7(991.1,"AC",EXCTYP,IEN)) Q:'IEN D
|
||||
;.. S IEN2=0
|
||||
;.. F S IEN2=$O(^RGHL7(991.1,"AC",EXCTYP,IEN,IEN2)) Q:'IEN2 D
|
||||
;... S NUM="" S NUM=$P(^RGHL7(991.1,IEN,1,0),"^",4)
|
||||
;... I NUM=1 S DIK="^RGHL7(991.1,",DA=IEN D ^DIK K DIK,DA S CNT=CNT+1
|
||||
;... E I NUM>1 D DEL
|
||||
;I CNT=0 W !,"There are no "_ETYPE_" exceptions on file."
|
||||
;E I CNT>0 W !,CNT_" "_ETYPE_" Exceptions purged!"
|
||||
;K ETYPE,CNT,IEN,IEN2,NUM,X,Y
|
||||
Q ;**52;if module accidentally called, should quit instead of falling into next module.
|
||||
PRGDUP ;Purge Duplicate Entries; retain most recent for all except types.
|
||||
;**50 through remainder of module.
|
||||
S EXCTYP="",CNT=0
|
||||
K ^TMP("RGEVDUP",$J)
|
||||
F S EXCTYP=$O(^RGHL7(991.1,"ADFN",EXCTYP)) Q:'EXCTYP D
|
||||
. S RGDFN=""
|
||||
. F S RGDFN=$O(^RGHL7(991.1,"ADFN",EXCTYP,RGDFN)) Q:'RGDFN D
|
||||
.. S IEN=0
|
||||
.. F S IEN=$O(^RGHL7(991.1,"ADFN",EXCTYP,RGDFN,IEN)) Q:'IEN D
|
||||
... S IEN2=0
|
||||
... F S IEN2=$O(^RGHL7(991.1,"ADFN",EXCTYP,RGDFN,IEN,IEN2)) Q:'IEN2 D
|
||||
.... I $P($G(^RGHL7(991.1,IEN,1,IEN2,0)),"^",5)=1 K ^RGHL7(991.1,"ADFN",EXCTYP,RGDFN,IEN,IEN2) Q ;exception processed
|
||||
.... S EXCDT=$P($G(^RGHL7(991.1,IEN,0)),"^",3) ;incoming date
|
||||
.... I '$D(^TMP("RGEVDUP",$J,RGDFN,EXCTYP)) D Q
|
||||
..... S ^TMP("RGEVDUP",$J,RGDFN,EXCTYP)=EXCDT_"^"_IEN_"^"_IEN2
|
||||
.... I $D(^TMP("RGEVDUP",$J,RGDFN,EXCTYP)) D ;duplicate exists; compare incoming to previous.
|
||||
..... S OLDNODE=^TMP("RGEVDUP",$J,RGDFN,EXCTYP)
|
||||
..... S OLDDT=$P(OLDNODE,"^"),OLDIEN=$P(OLDNODE,"^",2),OLDIEN2=$P(OLDNODE,"^",3)
|
||||
..... I EXCDT>OLDDT D Q ;incoming date greater than previous? purge old, keep new.
|
||||
...... S NUM="" S NUM=$P(^RGHL7(991.1,IEN,1,0),"^",4)
|
||||
...... I NUM=1 S DIK="^RGHL7(991.1,",DA=OLDIEN D ^DIK K DIK,DA
|
||||
...... I NUM>1 D
|
||||
....... S DA(1)=OLDIEN,DA=OLDIEN2
|
||||
....... S DIK="^RGHL7(991.1,"_DA(1)_",1," D ^DIK K DIK,DA
|
||||
...... S ^TMP("RGEVDUP",$J,RGDFN,EXCTYP)=EXCDT_"^"_IEN_"^"_IEN2
|
||||
..... ;
|
||||
..... I OLDDT>EXCDT!(OLDDT=EXCDT) D ;previous date greater or equal incoming? purge new, keep old.
|
||||
...... S NUM="" S NUM=$P(^RGHL7(991.1,IEN,1,0),"^",4)
|
||||
...... I NUM=1 S DIK="^RGHL7(991.1,",DA=IEN D ^DIK K DIK,DA
|
||||
...... I NUM>1 D DEL
|
||||
...... ;
|
||||
K CNT,EXCDT,EXCTYP,IEN,IEN2,NUM,OLDDT,OLDIEN,OLDIEN2,OLDNODE,RGDFN,RGDT,^TMP("RGEVDUP")
|
||||
Q
|
||||
;
|
||||
PRGZZ ;Purge if name field is null (incomplete record)
|
||||
;Purge if -9 node exists, this indicates the record has been merged.
|
||||
S EXCTYP="",CNT=""
|
||||
F S EXCTYP=$O(^RGHL7(991.1,"ADFN",EXCTYP)) Q:'EXCTYP D
|
||||
. S RGDFN=""
|
||||
. F S RGDFN=$O(^RGHL7(991.1,"ADFN",EXCTYP,RGDFN)) Q:'RGDFN D
|
||||
.. S IEN=0
|
||||
.. F S IEN=$O(^RGHL7(991.1,"ADFN",EXCTYP,RGDFN,IEN)) Q:'IEN D
|
||||
... S IEN2=0
|
||||
... F S IEN2=$O(^RGHL7(991.1,"ADFN",EXCTYP,RGDFN,IEN,IEN2)) Q:'IEN2 D
|
||||
.... S DFN=RGDFN D DEM^VADPT
|
||||
.... I VADM(1)=""!($D(^DPT(RGDFN,-9))) D
|
||||
..... S NUM="" S NUM=$P(^RGHL7(991.1,IEN,1,0),"^",4)
|
||||
..... I NUM=1 S DIK="^RGHL7(991.1,",DA=IEN D ^DIK K DIK,DA
|
||||
..... E I NUM>1 D DEL
|
||||
K EXCTYP,RGDFN,DFN,IEN,IEN2,NUM,VADM
|
||||
Q
|
||||
DEL ;
|
||||
S CNT=CNT+1
|
||||
S DA(1)=IEN,DA=IEN2
|
||||
S DIK="^RGHL7(991.1,"_DA(1)_",1,"
|
||||
D ^DIK K DIK,DA
|
||||
Q
|
||||
PROC ;Set these exception types to PROCESSED if they have a national ICN
|
||||
;**52 The PROC module is obsolete and is no longer being called.
|
||||
;209 - Required field(s) missing for patient sent to MPI,
|
||||
;227 - Multiple ICNs, 213 - SSN Match Failed, 214 - Name Doesn't Match
|
||||
;S EXCTYP=""
|
||||
;S HOME=$$SITE^VASITE()
|
||||
;F S EXCTYP=$O(^RGHL7(991.1,"AC",EXCTYP)) Q:'EXCTYP D
|
||||
;. I (EXCTYP=209)!(EXCTYP=227)!(EXCTYP=213)!(EXCTYP=214) D ;**43
|
||||
;.. S IEN=0
|
||||
;.. F S IEN=$O(^RGHL7(991.1,"AC",EXCTYP,IEN)) Q:'IEN D
|
||||
;... S IEN2=0,ICN="",RGDFN=""
|
||||
;... F S IEN2=$O(^RGHL7(991.1,"AC",EXCTYP,IEN,IEN2)) Q:'IEN2 D
|
||||
;.... S RGDFN=$P(^RGHL7(991.1,IEN,1,IEN2,0),"^",4) Q:'RGDFN
|
||||
;.... S ICN=+$$GETICN^MPIF001(RGDFN)
|
||||
;.... I $E(ICN,1,3)'=$E($P(HOME,"^",3),1,3)&(ICN>0) D
|
||||
;..... L +^RGHL7(991.1,IEN):10
|
||||
;..... S DA(1)=IEN,DA=IEN2,DR="6///"_1,DIE="^RGHL7(991.1,"_DA(1)_",1,"
|
||||
;..... D ^DIE K DIE,DA,DR
|
||||
;..... L -^RGHL7(991.1,IEN)
|
||||
;K EXCTYP,HOME,ICN,IEN,IEN2,RGDFN
|
||||
Q
|
||||
RGEVPRG ;BAY/ALS-OPTIONS TO PURGE MPI/PD EXCEPTIONS ;08/23/99
|
||||
;;1.0;CLINICAL INFO RESOURCE NETWORK;**3,12,19,32,35,43,44**;30 Apr 99;Build 8
|
||||
;
|
||||
MAIN ;
|
||||
;Q:($D(^TMP("RGEXC")))!($D(^TMP("RGEXC2")))
|
||||
L +^RGHL7(991.1):0 I '$T Q
|
||||
L -^RGHL7(991.1)
|
||||
L +^RGHL7(991.1,"RG PURGE EXCEPTION"):5 E Q
|
||||
I $D(ZTQUEUED) S ZTREQ="@"
|
||||
S $P(^RGSITE(991.8,1,"EXCPRG"),"^",1)=$$NOW^XLFDT
|
||||
S $P(^RGSITE(991.8,1,"EXCPRG"),"^",3)="R"
|
||||
D PROC
|
||||
D PRGDUP
|
||||
D PRG30
|
||||
D PRGZZ
|
||||
S $P(^RGSITE(991.8,1,"EXCPRG"),"^",2)=$$NOW^XLFDT
|
||||
S $P(^RGSITE(991.8,1,"EXCPRG"),"^",3)="C"
|
||||
L -^RGHL7(991.1,"RG PURGE EXCEPTION")
|
||||
Q
|
||||
PRGPAT ;Purge by Patient
|
||||
W !
|
||||
S DIC="^DPT(",DIC(0)="QEAM",DIC("A")="Select PATIENT: "
|
||||
D ^DIC K DIC G:Y<0 QUIT S RGDFN=+Y
|
||||
S EXCT="",FLAG=0
|
||||
F S EXCT=$O(^RGHL7(991.1,"ADFN",EXCT)) Q:EXCT="" D
|
||||
. I $D(^RGHL7(991.1,"ADFN",EXCT,RGDFN)) S FLAG=1 Q
|
||||
I FLAG=0 W !,"There are no exceptions on file for this patient." G PRGPAT
|
||||
I $$IFLOCAL^MPIF001(RGDFN) W !,"This patient does not have a national ICN assigned, do not purge." Q
|
||||
S DFN=RGDFN D DEM^VADPT
|
||||
S DIR(0)="YA",DIR("B")="YES"
|
||||
S DIR("A")="Are you sure you want to purge all exceptions on file for "_VADM(1)_"? YES// "
|
||||
D ^DIR Q:$D(DIRUT) I Y>0 D
|
||||
. S EXCT="",CNT=0
|
||||
. F S EXCT=$O(^RGHL7(991.1,"ADFN",EXCT)) Q:'EXCT D
|
||||
.. S IEN=0
|
||||
.. F S IEN=$O(^RGHL7(991.1,"ADFN",EXCT,RGDFN,IEN)) Q:'IEN D
|
||||
... S IEN2=0
|
||||
... F S IEN2=$O(^RGHL7(991.1,"ADFN",EXCT,RGDFN,IEN,IEN2)) Q:'IEN2 D
|
||||
.... S NUM="" S NUM=$P(^RGHL7(991.1,IEN,1,0),"^",4)
|
||||
.... I NUM=1 S DIK="^RGHL7(991.1,",DA=IEN D ^DIK K DIK,DA S CNT=CNT+1
|
||||
.... E I NUM>1 D DEL
|
||||
. W !,"All exceptions purged for "_VADM(1)_" DFN: "_RGDFN
|
||||
K EXCT,DFN,FLAG,VADM,CNT,IEN,IEN2,NUM,RGDFN,Y
|
||||
QUIT Q
|
||||
;
|
||||
PRGDT ; Purge by Date
|
||||
W !!,"Enter a date for the purge. All exceptions on file, on or before that date, will be deleted."
|
||||
K DIR,DIRUT,DTOUT,DUOUT
|
||||
S DIR(0)="DA^:DT:EPX",DIR("A")="Enter Date for Purge: "
|
||||
D ^DIR K DIR Q:$D(DIRUT)
|
||||
S PURDT=Y
|
||||
S PDATE=$$FMTE^XLFDT(PURDT)
|
||||
S DIR(0)="YA",DIR("B")="YES"
|
||||
S DIR("A")="Are you sure you want to purge all exceptions on file dated on or before "_PDATE_"? YES// "
|
||||
D ^DIR Q:$D(DIRUT) I Y>0 D
|
||||
. S EXCDT="",CNT=0
|
||||
. F S EXCDT=$O(^RGHL7(991.1,"AD",EXCDT)) Q:'EXCDT D
|
||||
.. I ($P(EXCDT,".",1)=PURDT)!($P(EXCDT,".",1)<PURDT) D
|
||||
... S IEN=0
|
||||
... F S IEN=$O(^RGHL7(991.1,"AD",EXCDT,IEN)) Q:'IEN D
|
||||
.... S NUM="" S NUM=$P($G(^RGHL7(991.1,IEN,1,0)),"^",4) Q:NUM<1
|
||||
.... S CNT=CNT+NUM
|
||||
.... S DIK="^RGHL7(991.1,",DA=IEN
|
||||
.... D ^DIK K DIK,DA
|
||||
I CNT=0 W !,"There are no exceptions dated on or before "_PDATE_", no data to purge."
|
||||
E I CNT>0 W !,CNT_" exceptions, dated on or before "_PDATE_" have been purged!"
|
||||
K PDATE,PURDT,EXCDT,CNT,IEN,NUM,Y
|
||||
Q
|
||||
PRG30 ; Purge Exceptions over 30 days old
|
||||
S TODAY=""
|
||||
S TODAY=$$NOW^XLFDT D
|
||||
. S EXCDT="",CNT=0,DIFF=""
|
||||
. F S EXCDT=$O(^RGHL7(991.1,"AD",EXCDT)) Q:'EXCDT D
|
||||
.. S DIFF=$$FMDIFF^XLFDT(TODAY,EXCDT)
|
||||
.. I DIFF>30 D
|
||||
... S IEN=0
|
||||
... F S IEN=$O(^RGHL7(991.1,"AD",EXCDT,IEN)) Q:'IEN D
|
||||
.... S NUM="" S NUM=$P($G(^RGHL7(991.1,IEN,1,0)),"^",4) Q:'NUM
|
||||
.... S IEN2=0
|
||||
.... F S IEN2=$O(^RGHL7(991.1,IEN,1,IEN2)) Q:'IEN2 D
|
||||
..... S STAT=""
|
||||
..... S STAT=$P(^RGHL7(991.1,IEN,1,IEN2,0),"^",5)
|
||||
..... ; Only delete PROCESSED exceptions
|
||||
..... I (STAT>0)!(STAT="") D
|
||||
...... I NUM>1 D DEL
|
||||
...... E I NUM=1 D
|
||||
....... S CNT=CNT+NUM
|
||||
....... S DIK="^RGHL7(991.1,",DA=IEN
|
||||
....... D ^DIK K DIK,DA
|
||||
K DIFF,TODAY,EXCDT,CNT,IEN,IEN2,NUM,STAT
|
||||
Q
|
||||
PRGEXC ; Purge by Exception Type
|
||||
;S DIC="^RGHL7(991.11,",DIC(0)="QEAM"
|
||||
;S DIC("A")="Enter an exception type to purge: "
|
||||
;D ^DIC K DIC G:Y<200 QUIT S EXCTYP=+Y,ETYPE=X
|
||||
;S DIR(0)="YA",DIR("B")="YES"
|
||||
;S DIR("A")="*WARNING* This will permanently delete all "_ETYPE_" exceptions. Are you sure you want to do this? YES// "
|
||||
;D ^DIR Q:$D(DIRUT) I Y>0 D
|
||||
;. S CNT=0,IEN=""
|
||||
;. F S IEN=$O(^RGHL7(991.1,"AC",EXCTYP,IEN)) Q:'IEN D
|
||||
;.. S IEN2=0
|
||||
;.. F S IEN2=$O(^RGHL7(991.1,"AC",EXCTYP,IEN,IEN2)) Q:'IEN2 D
|
||||
;... S NUM="" S NUM=$P(^RGHL7(991.1,IEN,1,0),"^",4)
|
||||
;... I NUM=1 S DIK="^RGHL7(991.1,",DA=IEN D ^DIK K DIK,DA S CNT=CNT+1
|
||||
;... E I NUM>1 D DEL
|
||||
;I CNT=0 W !,"There are no "_ETYPE_" exceptions on file."
|
||||
;E I CNT>0 W !,CNT_" "_ETYPE_" Exceptions purged!"
|
||||
;K ETYPE,CNT,IEN,IEN2,NUM,X,Y
|
||||
;Q
|
||||
PRGDUP ; Purge Duplicate Entries; retain most recent for all types except 234.
|
||||
S EXCTYP="",CNT=0
|
||||
K ^TMP("RGEVDUP",$J)
|
||||
F S EXCTYP=$O(^RGHL7(991.1,"ADFN",EXCTYP)) Q:'EXCTYP D
|
||||
. I EXCTYP=234 Q ;**44 process 234s separately below
|
||||
. S RGDFN=""
|
||||
. F S RGDFN=$O(^RGHL7(991.1,"ADFN",EXCTYP,RGDFN)) Q:'RGDFN D
|
||||
.. S IEN=0
|
||||
.. F S IEN=$O(^RGHL7(991.1,"ADFN",EXCTYP,RGDFN,IEN)) Q:'IEN D
|
||||
... S IEN2=0
|
||||
... F S IEN2=$O(^RGHL7(991.1,"ADFN",EXCTYP,RGDFN,IEN,IEN2)) Q:'IEN2 D
|
||||
.... S EXCDT=$P(^RGHL7(991.1,IEN,0),"^",3)
|
||||
.... I '$D(^TMP("RGEVDUP",$J,RGDFN,EXCTYP)) D Q
|
||||
..... S ^TMP("RGEVDUP",$J,RGDFN,EXCTYP)=EXCDT_"^"_IEN_"^"_IEN2
|
||||
.... I $D(^TMP("RGEVDUP",$J,RGDFN,EXCTYP)) D
|
||||
..... S OLDNODE=^TMP("RGEVDUP",$J,RGDFN,EXCTYP)
|
||||
..... S OLDDT=$P(OLDNODE,"^")
|
||||
..... I EXCDT>OLDDT D Q
|
||||
...... S NUM="" S NUM=$P(^RGHL7(991.1,IEN,1,0),"^",4)
|
||||
...... I NUM=1 S DIK="^RGHL7(991.1,",DA=$P(OLDNODE,"^",2) D ^DIK K DIK,DA
|
||||
...... E I NUM>1 D
|
||||
....... S DA(1)=$P(OLDNODE,"^",2),DA=$P(OLDNODE,"^",3)
|
||||
....... S DIK="^RGHL7(991.1,"_DA(1)_",1," D ^DIK K DIK,DA
|
||||
...... S CNT=CNT+1
|
||||
...... S ^TMP("RGEVDUP",$J,RGDFN,EXCTYP)=EXCDT_"^"_IEN_"^"_IEN2
|
||||
..... I OLDDT>EXCDT!(OLDDT=EXCDT) D
|
||||
...... S NUM="" S NUM=$P(^RGHL7(991.1,IEN,1,0),"^",4)
|
||||
...... I NUM=1 S DIK="^RGHL7(991.1,",DA=IEN D ^DIK K DIK,DA S CNT=CNT+1
|
||||
...... E I NUM>1 D DEL
|
||||
; W !,CNT_" Duplicate entries"
|
||||
;Process PRIMARY VIEW REJECT (234) duplicates; purge if for SAME day.
|
||||
;**44 through remainder of module.
|
||||
K ^TMP("RGDFNDT",$J) S RGDFN=""
|
||||
F S RGDFN=$O(^RGHL7(991.1,"ADFN",234,RGDFN)) Q:'RGDFN D
|
||||
.S IEN=0
|
||||
.F S IEN=$O(^RGHL7(991.1,"ADFN",234,RGDFN,IEN)) Q:'IEN D
|
||||
..S IEN2=0
|
||||
..F S IEN2=$O(^RGHL7(991.1,"ADFN",234,RGDFN,IEN,IEN2)) Q:'IEN2 D
|
||||
...S EXCDT=$P(^RGHL7(991.1,IEN,0),"^",3)
|
||||
...;How many for each DFN? Store in ^TMP("RGDFNDT")
|
||||
...I '$D(^TMP("RGDFNDT",$J,RGDFN)) S ^TMP("RGDFNDT",$J,RGDFN)=0
|
||||
...I $D(^TMP("RGDFNDT",$J,RGDFN)) D
|
||||
....S ^TMP("RGDFNDT",$J,RGDFN)=^TMP("RGDFNDT",$J,RGDFN)+1
|
||||
....S ^TMP("RGDFNDT",$J,RGDFN,IEN,IEN2)=$P(EXCDT,".") ;date only/no time
|
||||
;If RGDFN has more than 1 exception, see if any are for same DAY.
|
||||
;Process the ^TMP("RGDFNDT",$J global to build LOC array.
|
||||
I $D(^TMP("RGDFNDT",$J)) D
|
||||
.S RGDFN=""
|
||||
.F S RGDFN=$O(^TMP("RGDFNDT",$J,RGDFN)) Q:'RGDFN D
|
||||
..;If only one 234 exception for DFN ignore it.
|
||||
..I ^TMP("RGDFNDT",$J,RGDFN)=1 Q
|
||||
..;More than one for this DFN? How many for same day?
|
||||
..S IEN=0 K LOC
|
||||
..F S IEN=$O(^TMP("RGDFNDT",$J,RGDFN,IEN)) Q:'IEN D
|
||||
...S (IEN2,VAL)=0
|
||||
...F S IEN2=$O(^TMP("RGDFNDT",$J,RGDFN,IEN,IEN2)) Q:'IEN2 D
|
||||
....S VAL=$P(^TMP("RGDFNDT",$J,RGDFN,IEN,IEN2),"^")
|
||||
....I '$D(LOC(VAL)) S LOC(VAL)=0
|
||||
....I $D(LOC(VAL)) D
|
||||
.....S LOC(VAL)=LOC(VAL)+1
|
||||
.....S LOC(VAL,IEN,IEN2)=""
|
||||
..;Process the LOC array; contains numbers / day / DFN.
|
||||
..;If only 1 exception / day, keep it.
|
||||
..S RGDT=0 K CTR,TOT
|
||||
..F S RGDT=$O(LOC(RGDT)) Q:'RGDT D
|
||||
...S TOT=LOC(RGDT)
|
||||
...I TOT=1 K TOT Q ;only 1.
|
||||
...;More than 1, delete all except 1.
|
||||
...S TOT=TOT-1 ;leave 1; doesn't matter which - all are same day.
|
||||
...S IEN=0,CTR=0
|
||||
...F S IEN=$O(LOC(RGDT,IEN)) Q:'IEN D
|
||||
....I CTR=TOT Q
|
||||
....S CTR=CTR+1,IEN2=0
|
||||
....F S IEN2=$O(LOC(RGDT,IEN,IEN2)) Q:'IEN2 D DEL ;delete entry
|
||||
K CNT,CTR,EXCDT,IEN,IEN2,LOC,NUM,OLDDT,OLDNODE,RGDFN,RGDT,TOT,VAL,^TMP("RGDFNDT")
|
||||
Q
|
||||
PRGZZ ;Purge if name field is null (incomplete record)
|
||||
;Purge if -9 node exists, this indicates the record has been merged.
|
||||
S EXCTYP="",CNT=""
|
||||
F S EXCTYP=$O(^RGHL7(991.1,"ADFN",EXCTYP)) Q:'EXCTYP D
|
||||
. S RGDFN=""
|
||||
. F S RGDFN=$O(^RGHL7(991.1,"ADFN",EXCTYP,RGDFN)) Q:'RGDFN D
|
||||
.. S IEN=0
|
||||
.. F S IEN=$O(^RGHL7(991.1,"ADFN",EXCTYP,RGDFN,IEN)) Q:'IEN D
|
||||
... S IEN2=0
|
||||
... F S IEN2=$O(^RGHL7(991.1,"ADFN",EXCTYP,RGDFN,IEN,IEN2)) Q:'IEN2 D
|
||||
.... S DFN=RGDFN D DEM^VADPT
|
||||
.... I VADM(1)=""!($D(^DPT(RGDFN,-9))) D
|
||||
..... S NUM="" S NUM=$P(^RGHL7(991.1,IEN,1,0),"^",4)
|
||||
..... I NUM=1 S DIK="^RGHL7(991.1,",DA=IEN D ^DIK K DIK,DA
|
||||
..... E I NUM>1 D DEL
|
||||
K EXCTYP,RGDFN,DFN,IEN,IEN2,NUM,VADM
|
||||
Q
|
||||
DEL ;
|
||||
S CNT=CNT+1
|
||||
S DA(1)=IEN,DA=IEN2
|
||||
S DIK="^RGHL7(991.1,"_DA(1)_",1,"
|
||||
D ^DIK K DIK,DA
|
||||
Q
|
||||
PROC ;Set these exception types to PROCESSED if they have a national ICN
|
||||
;209 - Required field(s) missing for patient sent to MPI,
|
||||
;227 - Multiple ICNs, 213 - SSN Match Failed, 214 - Name Doesn't Match
|
||||
S EXCTYP=""
|
||||
S HOME=$$SITE^VASITE()
|
||||
F S EXCTYP=$O(^RGHL7(991.1,"AC",EXCTYP)) Q:'EXCTYP D
|
||||
. I (EXCTYP=209)!(EXCTYP=227)!(EXCTYP=213)!(EXCTYP=214) D ;**43
|
||||
.. S IEN=0
|
||||
.. F S IEN=$O(^RGHL7(991.1,"AC",EXCTYP,IEN)) Q:'IEN D
|
||||
... S IEN2=0,ICN="",RGDFN=""
|
||||
... F S IEN2=$O(^RGHL7(991.1,"AC",EXCTYP,IEN,IEN2)) Q:'IEN2 D
|
||||
.... S RGDFN=$P(^RGHL7(991.1,IEN,1,IEN2,0),"^",4) Q:'RGDFN
|
||||
.... S ICN=+$$GETICN^MPIF001(RGDFN)
|
||||
.... I $E(ICN,1,3)'=$E($P(HOME,"^",3),1,3)&(ICN>0) D
|
||||
..... L +^RGHL7(991.1,IEN):10
|
||||
..... S DA(1)=IEN,DA=IEN2,DR="6///"_1,DIE="^RGHL7(991.1,"_DA(1)_",1,"
|
||||
..... D ^DIE K DIE,DA,DR
|
||||
..... L -^RGHL7(991.1,IEN)
|
||||
K EXCTYP,HOME,ICN,IEN,IEN2,RGDFN
|
||||
Q
|
||||
|
|
|
|||
|
|
@ -1,157 +1,156 @@
|
|||
RGEX01 ;BAY/ALS-LIST MANAGER FOR MPI/PD EXCEPTIONS ;10/07/99
|
||||
;;1.0;CLINICAL INFO RESOURCE NETWORK;**3,12,19,23,43,45,47,48,52**;30 Apr 99;Build 2
|
||||
;
|
||||
;Reference to MAIN^VAFCPDAT supported by IA #3299
|
||||
EN ; -- main entry point for RG EXCPT SUMMARY
|
||||
N STDT,ENDDT,PRGSTAT,XFLAG,NOW,%,X,%H,%I,INDT,RUN,INDTT
|
||||
S XFLAG=0 D NOW^%DTC S NOW=%
|
||||
S STDT=$P($G(^RGSITE(991.8,1,"EXCPRG")),"^",1),INDT=STDT
|
||||
I $D(STDT) S STDT=$$FMTE^XLFDT(STDT,1)
|
||||
S PRGSTAT=$P($G(^RGSITE(991.8,1,"EXCPRG")),"^",3)
|
||||
;status shows 'running' but lock shows 'not running';**47
|
||||
I PRGSTAT="R" D
|
||||
.L +^RGHL7(991.1,"RG PURGE EXCEPTION"):0 I $T D ;can get lock
|
||||
..L +^RGSITE(991.8):10
|
||||
..S DIE="^RGSITE(991.8,",DA=1,DR="42///@"
|
||||
..D ^DIE K DA,DIE,DR ;delete old status
|
||||
..L -^RGSITE(991.8)
|
||||
..S PRGSTAT=""
|
||||
.L -^RGHL7(991.1,"RG PURGE EXCEPTION")
|
||||
I PRGSTAT="" D
|
||||
. W $C(7)
|
||||
. W !!,"The MPI/PD Exception Purge process has not been run."
|
||||
. ;**48 NO LONGER A CHOICE
|
||||
. W !!,"The MPI/PD Exception Purge process will now run."
|
||||
. W !,"Please come back to this option in five minutes."
|
||||
. W !!,"Please contact IRM to schedule the MPI/PD EXCEPTION PURGE"
|
||||
. W !,"[RG EXCEPTION PURGE] option via TaskMan with a frequency of once an hour."
|
||||
. S XFLAG=1 D QUEPRG
|
||||
L +^RGHL7(991.1,"RG PURGE EXCEPTION"):0 I '$T W $C(7),!!,"The MPI/PD Exception Purge process is currently running.",!,"Please try this option again in five minutes." S XFLAG=1 G EXIT
|
||||
L -^RGHL7(991.1,"RG PURGE EXCEPTION")
|
||||
S RUN=0
|
||||
I $G(PRGSTAT)="C" D
|
||||
. I $P(INDT,".")<$P(NOW,".") S RUN=1 ;RAN A PREVIOUS DAY
|
||||
. I $P(INDT,".")=$P(NOW,".") D
|
||||
.. S INDTT=$E($P(INDT,".",2),1,4),INDTT=INDTT+101
|
||||
.. I INDTT<$E($P(NOW,".",2),1,4) S RUN=1
|
||||
. Q:RUN=0
|
||||
. ;** if job ran more than 1 hour ago, run it now.
|
||||
. W !!,"The MPI/PD Exception Purge process last ran "_STDT_"."
|
||||
. W !!,"The MPI/PD Exception Purge process will now run."
|
||||
. W !,"Please come back to this option in five minutes."
|
||||
. W !!,"Please contact IRM to verify that the MPI/PD EXCEPTION PURGE "
|
||||
. W !,"[RG EXCEPTION PURGE] option is scheduled to run via TaskMan"
|
||||
. W !,"with a frequency of once an hour."
|
||||
. S XFLAG=1 D QUEPRG
|
||||
I XFLAG=1 G EXIT
|
||||
K RGANS
|
||||
D WAIT^DICD
|
||||
D EN^VALM("RG EXCPT SUMMARY")
|
||||
Q
|
||||
;
|
||||
HDR ; -- header code
|
||||
S VALMHDR(1)="MPI/PD Exception Handling"
|
||||
S VALMHDR(2)=""
|
||||
Q
|
||||
;
|
||||
INIT ; -- init variables and list array
|
||||
I '$D(RGSORT) S RGSORT="SD"
|
||||
K @VALMAR
|
||||
I RGSORT="SD" D DTLIST^RGEXHND1
|
||||
E I RGSORT="ST" D EXCLST^RGEXHND1
|
||||
E I RGSORT="SN" D PATLST^RGEXHND1
|
||||
E I RGSORT="VT" D SELTYP^RGEXHND1
|
||||
Q
|
||||
;
|
||||
SORT ;
|
||||
D INIT
|
||||
S VALMBCK="R"
|
||||
Q
|
||||
HELP ; -- help code
|
||||
S X="?" D DISP^XQORM1 W !!
|
||||
Q
|
||||
HLPPRG ;
|
||||
W !,"Enter Y(YES) to run the MPI/PD Exception Purge process now."
|
||||
W !!,"Enter N(NO) to go directly into the MPI/PD Exception Handling option."
|
||||
Q
|
||||
;
|
||||
EXIT ; -- exit code
|
||||
K VADM,RGDFN,RGNM,RGSORT,RGSSN,STAT,STRING,NDX,NM,IEN,IEN2,X,DATA,CNT,EXCTYPE,ETYPE,^TMP("RGEXC",$J),^TMP("RGEX01",$J)
|
||||
Q
|
||||
QUEPRG S ZTRTN="MAIN^RGEVPRG",ZTDESC="PURGE ZZ*, OVER 30 DAY AND DUPLICATE RECORDS FROM THE CIRN HL7 EXCEPTION LOG FILE"
|
||||
D NOW^%DTC
|
||||
S ZTIO="",ZTDTH=%
|
||||
I $D(DUZ) S ZTSAVE("DUZ")=DUZ
|
||||
D ^%ZTLOAD
|
||||
D HOME^%ZIS K IO("Q")
|
||||
K ZTDESC,ZTDTH,ZTIO,ZTQUEUED,ZTREQ,ZTRTN,ZTSAVE,ZTSK,%
|
||||
Q
|
||||
;
|
||||
EXPND ; -- expand code
|
||||
Q
|
||||
;
|
||||
CUREX() ;Are there any patients in the CIRN HL7 EXCEPTION LOG file (#991.1)
|
||||
;that are NOT PROCESSED for specific exception types?
|
||||
; Return RGEX:
|
||||
;If RGEX=3 both unprocessed and Primary View Reject exceptions exist
|
||||
;If RGEX=2 only Primary View Reject exceptions exist
|
||||
;If RGEX=1 only unprocessed exceptions exist
|
||||
;If RGEX=0 no unprocessed exceptions exist
|
||||
;
|
||||
N EXCTYP,RG1,RG2,RGEX
|
||||
S EXCTYP="",(RG1,RG2,RGEX)=0
|
||||
F S EXCTYP=$O(^RGHL7(991.1,"ASTAT","0",EXCTYP)) Q:'EXCTYP D
|
||||
.I (EXCTYP=234)!(EXCTYP=218) S RG1=1 ;MPIC_772; **52 remove 215, 216, and 217
|
||||
.I (EXCTYP=234) S RG2=1 ;Primary View Reject
|
||||
I (RG1=1),(RG2=1) S RGEX=3 ;Send both messages
|
||||
I (RG1=1),(RG2=0) S RGEX=1 ;Only unresolved exceptions exist
|
||||
I (RG1=0),(RG2=1) S RGEX=2 ;Only Primary View Reject exceptions exist
|
||||
Q RGEX
|
||||
;
|
||||
PROC ; For a given patient, set exceptions STATUS to PROCESSED.
|
||||
;**52 The PROC module is obsolete and is no longer being called.
|
||||
; DFN must be defined
|
||||
;Q:'$D(DFN)
|
||||
;S EXCTYP=""
|
||||
;S HOME=$$SITE^VASITE()
|
||||
;F S EXCTYP=$O(^RGHL7(991.1,"ADFN",EXCTYP)) Q:'EXCTYP D
|
||||
;. S RGDFN="",ICN=""
|
||||
;. F S RGDFN=$O(^RGHL7(991.1,"ADFN",EXCTYP,RGDFN)) Q:'RGDFN D
|
||||
;.. I DFN=RGDFN D
|
||||
;... S ICN=+$$GETICN^MPIF001(DFN)
|
||||
;... ;Only set to PROCESSED if patient has national ICN.
|
||||
;... I $E(ICN,1,3)'=$E($P(HOME,"^",3),1,3)&(ICN>0) D
|
||||
;.... ;Exclude Death exceptions (215-217); they must be processed manually.
|
||||
;.... ;Exclude 218 Potential Matches Returned exception **43
|
||||
;.... I (EXCTYP>218)!(EXCTYP<215) D
|
||||
;..... S IEN=0
|
||||
;..... F S IEN=$O(^RGHL7(991.1,"ADFN",EXCTYP,RGDFN,IEN)) Q:'IEN D
|
||||
;...... S IEN2=0
|
||||
;...... F S IEN2=$O(^RGHL7(991.1,"ADFN",EXCTYP,RGDFN,IEN,IEN2)) Q:'IEN2 D
|
||||
;....... L +^RGHL7(991.1,IEN):10
|
||||
;....... S DA(1)=IEN,DA=IEN2,DR="6///"_1,DIE="^RGHL7(991.1,"_DA(1)_",1,"
|
||||
;....... D ^DIE K DIE,DA,DR
|
||||
;....... L -^RGHL7(991.1,IEN)
|
||||
;K IEN,IEN2,RGDFN,EXCTYP,ICN
|
||||
Q
|
||||
PDAT ;
|
||||
K DIRUT
|
||||
W !,"This report prints MPI/PD Data for a selected patient. The"
|
||||
W !,"information displayed includes the Integration Control Number"
|
||||
W !,"(ICN), patient identity information, and Treating Facility list."
|
||||
W !!,"The information is pulled from the Patient (#2) file and the"
|
||||
W !,"Treating Facility List (#391.91) file."
|
||||
;
|
||||
ASK ;Ask for PATIENT
|
||||
I $D(DIRUT) G QUIT
|
||||
W !!,"Patient lookup can be done by Patient Name/SSN or by ICN.",!
|
||||
N DFN,ICN
|
||||
S DIC="^DPT(",DIC(0)="QEAM",DIC("A")="Select PATIENT: ",D="SSN^AICN^B^BS^BS5"
|
||||
D MIX^DIC1 K DIC
|
||||
G:Y<0 QUIT
|
||||
S DFN=+Y
|
||||
D MAIN^VAFCPDAT
|
||||
G ASK
|
||||
Q
|
||||
QUIT ;
|
||||
K DFN,ICN,D,Y,HOME
|
||||
RGEX01 ;BAY/ALS-LIST MANAGER FOR MPI/PD EXCEPTIONS ;10/07/99
|
||||
;;1.0;CLINICAL INFO RESOURCE NETWORK;**3,12,19,23,43,45,47,48**;30 Apr 99;Build 3
|
||||
;
|
||||
;Reference to MAIN^VAFCPDAT supported by IA #3299
|
||||
EN ; -- main entry point for RG EXCPT SUMMARY
|
||||
N STDT,ENDDT,PRGSTAT,XFLAG,NOW,%,X,%H,%I,INDT,RUN,INDTT
|
||||
S XFLAG=0 D NOW^%DTC S NOW=%
|
||||
S STDT=$P($G(^RGSITE(991.8,1,"EXCPRG")),"^",1),INDT=STDT
|
||||
I $D(STDT) S STDT=$$FMTE^XLFDT(STDT,1)
|
||||
S PRGSTAT=$P($G(^RGSITE(991.8,1,"EXCPRG")),"^",3)
|
||||
;status shows 'running' but lock shows 'not running';**47
|
||||
I PRGSTAT="R" D
|
||||
.L +^RGHL7(991.1,"RG PURGE EXCEPTION"):0 I $T D ;can get lock
|
||||
..L +^RGSITE(991.8):10
|
||||
..S DIE="^RGSITE(991.8,",DA=1,DR="42///@"
|
||||
..D ^DIE K DA,DIE,DR ;delete old status
|
||||
..L -^RGSITE(991.8)
|
||||
..S PRGSTAT=""
|
||||
.L -^RGHL7(991.1,"RG PURGE EXCEPTION")
|
||||
I PRGSTAT="" D
|
||||
. W $C(7)
|
||||
. W !!,"The MPI/PD Exception Purge process has not been run."
|
||||
. ;**48 NO LONGER A CHOICE
|
||||
. W !!,"The MPI/PD Exception Purge process will now run."
|
||||
. W !,"Please come back to this option in five minutes."
|
||||
. W !!,"Please contact IRM to schedule the MPI/PD EXCEPTION PURGE"
|
||||
. W !,"[RG EXCEPTION PURGE] option via TaskMan with a frequency of once an hour."
|
||||
. S XFLAG=1 D QUEPRG
|
||||
L +^RGHL7(991.1,"RG PURGE EXCEPTION"):0 I '$T W $C(7),!!,"The MPI/PD Exception Purge process is currently running.",!,"Please try this option again in five minutes." S XFLAG=1 G EXIT
|
||||
L -^RGHL7(991.1,"RG PURGE EXCEPTION")
|
||||
S RUN=0
|
||||
I $G(PRGSTAT)="C" D
|
||||
. I $P(INDT,".")<$P(NOW,".") S RUN=1 ;RAN A PREVIOUS DAY
|
||||
. I $P(INDT,".")=$P(NOW,".") D
|
||||
.. S INDTT=$E($P(INDT,".",2),1,4),INDTT=INDTT+101
|
||||
.. I INDTT<$E($P(NOW,".",2),1,4) S RUN=1
|
||||
. Q:RUN=0
|
||||
. ;** if job ran more than 1 hour ago, run it now.
|
||||
. W !!,"The MPI/PD Exception Purge process last ran "_STDT_"."
|
||||
. W !!,"The MPI/PD Exception Purge process will now run."
|
||||
. W !,"Please come back to this option in five minutes."
|
||||
. W !!,"Please contact IRM to verify that the MPI/PD EXCEPTION PURGE "
|
||||
. W !,"[RG EXCEPTION PURGE] option is scheduled to run via TaskMan"
|
||||
. W !,"with a frequency of once an hour."
|
||||
. S XFLAG=1 D QUEPRG
|
||||
I XFLAG=1 G EXIT
|
||||
K RGANS
|
||||
D WAIT^DICD
|
||||
D EN^VALM("RG EXCPT SUMMARY")
|
||||
Q
|
||||
;
|
||||
HDR ; -- header code
|
||||
S VALMHDR(1)="MPI/PD Exception Handling"
|
||||
S VALMHDR(2)=""
|
||||
Q
|
||||
;
|
||||
INIT ; -- init variables and list array
|
||||
I '$D(RGSORT) S RGSORT="SD"
|
||||
K @VALMAR
|
||||
I RGSORT="SD" D DTLIST^RGEXHND1
|
||||
E I RGSORT="ST" D EXCLST^RGEXHND1
|
||||
E I RGSORT="SN" D PATLST^RGEXHND1
|
||||
E I RGSORT="VT" D SELTYP^RGEXHND1
|
||||
Q
|
||||
;
|
||||
SORT ;
|
||||
D INIT
|
||||
S VALMBCK="R"
|
||||
Q
|
||||
HELP ; -- help code
|
||||
S X="?" D DISP^XQORM1 W !!
|
||||
Q
|
||||
HLPPRG ;
|
||||
W !,"Enter Y(YES) to run the MPI/PD Exception Purge process now."
|
||||
W !!,"Enter N(NO) to go directly into the MPI/PD Exception Handling option."
|
||||
Q
|
||||
;
|
||||
EXIT ; -- exit code
|
||||
K VADM,RGDFN,RGNM,RGSORT,RGSSN,STAT,STRING,NDX,NM,IEN,IEN2,X,DATA,CNT,EXCTYPE,ETYPE,^TMP("RGEXC",$J),^TMP("RGEX01",$J)
|
||||
Q
|
||||
QUEPRG S ZTRTN="MAIN^RGEVPRG",ZTDESC="PURGE ZZ*, OVER 30 DAY AND DUPLICATE RECORDS FROM THE CIRN HL7 EXCEPTION LOG FILE"
|
||||
D NOW^%DTC
|
||||
S ZTIO="",ZTDTH=%
|
||||
I $D(DUZ) S ZTSAVE("DUZ")=DUZ
|
||||
D ^%ZTLOAD
|
||||
D HOME^%ZIS K IO("Q")
|
||||
K ZTDESC,ZTDTH,ZTIO,ZTQUEUED,ZTREQ,ZTRTN,ZTSAVE,ZTSK,%
|
||||
Q
|
||||
;
|
||||
EXPND ; -- expand code
|
||||
Q
|
||||
;
|
||||
CUREX() ;Are there any patients in the CIRN HL7 EXCEPTION LOG file (#991.1)
|
||||
;that are NOT PROCESSED for specific exception types?
|
||||
; Return RGEX:
|
||||
;If RGEX=3 both unprocessed and Primary View Reject exceptions exist
|
||||
;If RGEX=2 only Primary View Reject exceptions exist
|
||||
;If RGEX=1 only unprocessed exceptions exist
|
||||
;If RGEX=0 no unprocessed exceptions exist
|
||||
;
|
||||
N EXCTYP,RG1,RG2,RGEX
|
||||
S EXCTYP="",(RG1,RG2,RGEX)=0
|
||||
F S EXCTYP=$O(^RGHL7(991.1,"ASTAT","0",EXCTYP)) Q:'EXCTYP D
|
||||
.I ((EXCTYP=234)!((EXCTYP>214)&(EXCTYP<219))) S RG1=1
|
||||
.I (EXCTYP=234) S RG2=1 ;Primary View Reject
|
||||
I (RG1=1),(RG2=1) S RGEX=3 ;Send both messages
|
||||
I (RG1=1),(RG2=0) S RGEX=1 ;Only unresolved exceptions exist
|
||||
I (RG1=0),(RG2=1) S RGEX=2 ;Only Primary View Reject exceptions exist
|
||||
Q RGEX
|
||||
;
|
||||
PROC ; For a given patient, set exceptions STATUS to PROCESSED.
|
||||
; DFN must be defined
|
||||
Q:'$D(DFN)
|
||||
S EXCTYP=""
|
||||
S HOME=$$SITE^VASITE()
|
||||
F S EXCTYP=$O(^RGHL7(991.1,"ADFN",EXCTYP)) Q:'EXCTYP D
|
||||
. S RGDFN="",ICN=""
|
||||
. F S RGDFN=$O(^RGHL7(991.1,"ADFN",EXCTYP,RGDFN)) Q:'RGDFN D
|
||||
.. I DFN=RGDFN D
|
||||
... S ICN=+$$GETICN^MPIF001(DFN)
|
||||
... ;Only set to PROCESSED if patient has national ICN.
|
||||
... I $E(ICN,1,3)'=$E($P(HOME,"^",3),1,3)&(ICN>0) D
|
||||
.... ;Exclude Death exceptions (215-217); they must be processed manually.
|
||||
.... ;Exclude 218 Potential Matches Returned exception **43
|
||||
.... I (EXCTYP>218)!(EXCTYP<215) D
|
||||
..... S IEN=0
|
||||
..... F S IEN=$O(^RGHL7(991.1,"ADFN",EXCTYP,RGDFN,IEN)) Q:'IEN D
|
||||
...... S IEN2=0
|
||||
...... F S IEN2=$O(^RGHL7(991.1,"ADFN",EXCTYP,RGDFN,IEN,IEN2)) Q:'IEN2 D
|
||||
....... L +^RGHL7(991.1,IEN):10
|
||||
....... S DA(1)=IEN,DA=IEN2,DR="6///"_1,DIE="^RGHL7(991.1,"_DA(1)_",1,"
|
||||
....... D ^DIE K DIE,DA,DR
|
||||
....... L -^RGHL7(991.1,IEN)
|
||||
K IEN,IEN2,RGDFN,EXCTYP,ICN
|
||||
Q
|
||||
PDAT ;
|
||||
K DIRUT
|
||||
W !,"This report prints MPI/PD Data for a selected patient. The"
|
||||
W !,"information displayed includes the Integration Control Number"
|
||||
W !,"(ICN), patient identity information, and Treating Facility list."
|
||||
W !!,"The information is pulled from the Patient (#2) file and the"
|
||||
W !,"Treating Facility List (#391.91) file."
|
||||
;
|
||||
ASK ;Ask for PATIENT
|
||||
I $D(DIRUT) G QUIT
|
||||
W !!,"Patient lookup can be done by Patient Name/SSN or by ICN.",!
|
||||
N DFN,ICN
|
||||
S DIC="^DPT(",DIC(0)="QEAM",DIC("A")="Select PATIENT: ",D="SSN^AICN^B^BS^BS5"
|
||||
D MIX^DIC1 K DIC
|
||||
G:Y<0 QUIT
|
||||
S DFN=+Y
|
||||
D MAIN^VAFCPDAT
|
||||
G ASK
|
||||
Q
|
||||
QUIT ;
|
||||
K DFN,ICN,D,Y,HOME
|
||||
|
|
|
|||
|
|
@ -1,63 +1,63 @@
|
|||
RGEX06 ;BIR/PTD-LIST MANAGER ROUTINE FOR REMOTE MPI PRIMARY VIEW PDAT ;5/17/07
|
||||
;;1.0;CLINICAL INFO RESOURCE NETWORK;**48,53**;30 Apr 99;Build 2
|
||||
;
|
||||
;Reference to ^XWB2HL7 supported by IA #3144
|
||||
;Reference to ^XWBDRPC supported by IA #3149
|
||||
;
|
||||
EN(ICN) ;Entry point calling List Template for primary view PDAT display
|
||||
D EN^VALM("RG EXCPT PV MPI PDAT")
|
||||
Q
|
||||
;
|
||||
HDR ; -- header code
|
||||
S VALMHDR(1)="MPI PRIMARY VIEW PATIENT DATA DISPLAY"
|
||||
Q
|
||||
;
|
||||
INIT ;Display the MPI Primary View Patient Data (PDAT)
|
||||
K ^TMP("RGEXC6",$J)
|
||||
K @VALMAR
|
||||
I '$D(ICN) G EXIT
|
||||
S LIN=1,X=0,STR="",TXT=""
|
||||
I '$D(^XTMP("RGPVMPI"_ICN,"DATA")) S TXT=" - No MPI Primary View data exists for this patient." D ADDTMP
|
||||
N STATUS,R,RETURN,RESULT,RET
|
||||
I $D(^XTMP("RGPVMPI"_ICN,"DATA")) S RETURN(0)=$P(^XTMP("RGPVMPI"_ICN,"DATA"),"^") D
|
||||
.D RPCCHK^XWB2HL7(.RESULT,RETURN(0)) I +RESULT(0)=1 D
|
||||
..;Retrieve the data
|
||||
..D RTNDATA^XWBDRPC(.RET,RETURN(0)) D
|
||||
...I $G(RET(0))<0 S TXT="No Data Returned Due To: "_$P(RET(0),"^",2,99) S STR=$$SETSTR^VALM1(TXT,STR,1,80) D ADDTMP Q
|
||||
...I $G(RET)'="",$D(@RET) S GLO=RET F S GLO=$Q(@GLO) Q:$QS(GLO,1)'=$J S TXT=@GLO S STR=$$SETSTR^VALM1(TXT,STR,1,80) D ADDTMP
|
||||
...S R="" F S R=$O(RET(R)) Q:R="" S TXT=RET(R) S STR=$$SETSTR^VALM1(TXT,STR,1,80) D ADDTMP
|
||||
K GLO,L,R,SL
|
||||
S VALMCNT=LIN-1
|
||||
Q
|
||||
;
|
||||
ADDTMP ;Set string into the array.
|
||||
S ^TMP("RGEXC6",$J,LIN,0)=STR
|
||||
S ^TMP("RGEXC6",$J,"IDX",LIN,LIN)=""
|
||||
S LIN=LIN+1,STR=""
|
||||
Q
|
||||
;
|
||||
HELP ; -- help code
|
||||
S X="?" D DISP^XQORM1 W !!
|
||||
Q
|
||||
;
|
||||
EXIT ; -- exit code
|
||||
S VALMBCK=""
|
||||
K ^TMP("RGEXC6",$J),GLO,L,LIN,R,RESULT,RET,RETURN,SL,STATUS,STR,TXT,X
|
||||
S VALMBCK="R"
|
||||
Q
|
||||
;
|
||||
EXPND ; -- expand code
|
||||
Q
|
||||
;
|
||||
SAPV(ICN) ;Print stand alone Primary View display
|
||||
I '$D(^XTMP("RGPVMPI"_ICN,"DATA")) W !," - No MPI Primary View data exists for this patient." Q
|
||||
N STATUS,R,RETURN,RESULT,RET
|
||||
I $D(^XTMP("RGPVMPI"_ICN,"DATA")) S RETURN(0)=$P(^XTMP("RGPVMPI"_ICN,"DATA"),"^") D
|
||||
.D RPCCHK^XWB2HL7(.RESULT,RETURN(0)) I +RESULT(0)=1 D
|
||||
..;Retrieve the data
|
||||
..D RTNDATA^XWBDRPC(.RET,RETURN(0)) D
|
||||
...I $D(RET(0)) I RET(0)<0 W !!,"No data returned due to: "_$P(RET(0),"^",2) Q
|
||||
...I $G(RET)'="",$D(@RET) S GLO=RET F S GLO=$Q(@GLO) Q:$QS(GLO,1)'=$J S TXT=@GLO W !,TXT I $Y>22 S DIR(0)="E" D ^DIR K DIR W @IOF S $Y=1
|
||||
...S R="" F S R=$O(RET(R)) Q:R="" W !,RET(R) I $Y>22 S DIR(0)="E" D ^DIR K DIR Q:'Y W @IOF S $Y=1
|
||||
Q
|
||||
;
|
||||
RGEX06 ;BIR/PTD-LIST MANAGER ROUTINE FOR REMOTE MPI PRIMARY VIEW PDAT ;5/17/07
|
||||
;;1.0;CLINICAL INFO RESOURCE NETWORK;**48**;30 Apr 99;Build 3
|
||||
;
|
||||
;Reference to ^XWB2HL7 supported by IA #3144
|
||||
;Reference to ^XWBDRPC supported by IA #3149
|
||||
;
|
||||
EN(ICN) ;Entry point calling List Template for primary view PDAT display
|
||||
D EN^VALM("RG EXCPT PV MPI PDAT")
|
||||
Q
|
||||
;
|
||||
HDR ; -- header code
|
||||
S VALMHDR(1)="MPI PRIMARY VIEW PATIENT DATA DISPLAY"
|
||||
Q
|
||||
;
|
||||
INIT ;Display the MPI Primary View Patient Data (PDAT)
|
||||
K ^TMP("RGEXC6",$J)
|
||||
K @VALMAR
|
||||
I '$D(ICN) G EXIT
|
||||
S LIN=1,X=0,STR="",TXT=""
|
||||
I '$D(^XTMP("RGPVMPI",ICN)) S TXT=" - No MPI Primary View data exists for this patient." D ADDTMP
|
||||
N STATUS,R,RETURN,RESULT,RET
|
||||
I $D(^XTMP("RGPVMPI",ICN)) S RETURN(0)=$P(^XTMP("RGPVMPI",ICN),"^") D
|
||||
.D RPCCHK^XWB2HL7(.RESULT,RETURN(0)) I +RESULT(0)=1 D
|
||||
..;Retrieve the data
|
||||
..D RTNDATA^XWBDRPC(.RET,RETURN(0)) D
|
||||
...I $G(RET(0))<0 S TXT="No Data Returned Due To: "_$P(RET(0),"^",2,99) S STR=$$SETSTR^VALM1(TXT,STR,1,80) D ADDTMP Q
|
||||
...I $G(RET)'="",$D(@RET) S GLO=RET F S GLO=$Q(@GLO) Q:$QS(GLO,1)'=$J S TXT=@GLO S STR=$$SETSTR^VALM1(TXT,STR,1,80) D ADDTMP
|
||||
...S R="" F S R=$O(RET(R)) Q:R="" S TXT=RET(R) S STR=$$SETSTR^VALM1(TXT,STR,1,80) D ADDTMP
|
||||
K GLO,L,R,SL
|
||||
S VALMCNT=LIN-1
|
||||
Q
|
||||
;
|
||||
ADDTMP ;Set string into the array.
|
||||
S ^TMP("RGEXC6",$J,LIN,0)=STR
|
||||
S ^TMP("RGEXC6",$J,"IDX",LIN,LIN)=""
|
||||
S LIN=LIN+1,STR=""
|
||||
Q
|
||||
;
|
||||
HELP ; -- help code
|
||||
S X="?" D DISP^XQORM1 W !!
|
||||
Q
|
||||
;
|
||||
EXIT ; -- exit code
|
||||
S VALMBCK=""
|
||||
K ^TMP("RGEXC6",$J),GLO,L,LIN,R,RESULT,RET,RETURN,SL,STATUS,STR,TXT,X
|
||||
S VALMBCK="R"
|
||||
Q
|
||||
;
|
||||
EXPND ; -- expand code
|
||||
Q
|
||||
;
|
||||
SAPV(ICN) ;Print stand alone Primary View display
|
||||
I '$D(^XTMP("RGPVMPI",ICN)) W !," - No MPI Primary View data exists for this patient." Q
|
||||
N STATUS,R,RETURN,RESULT,RET
|
||||
I $D(^XTMP("RGPVMPI",ICN)) S RETURN(0)=$P(^XTMP("RGPVMPI",ICN),"^") D
|
||||
.D RPCCHK^XWB2HL7(.RESULT,RETURN(0)) I +RESULT(0)=1 D
|
||||
..;Retrieve the data
|
||||
..D RTNDATA^XWBDRPC(.RET,RETURN(0)) D
|
||||
...I $D(RET(0)) I RET(0)<0 W !!,"No data returned due to: "_$P(RET(0),"^",2) Q
|
||||
...I $G(RET)'="",$D(@RET) S GLO=RET F S GLO=$Q(@GLO) Q:$QS(GLO,1)'=$J S TXT=@GLO W !,TXT I $Y>22 S DIR(0)="E" D ^DIR K DIR W @IOF S $Y=1
|
||||
...S R="" F S R=$O(RET(R)) Q:R="" W !,RET(R) I $Y>22 S DIR(0)="E" D ^DIR K DIR Q:'Y W @IOF S $Y=1
|
||||
Q
|
||||
;
|
||||
|
|
|
|||
|
|
@ -1,52 +1,52 @@
|
|||
RGEX07 ;BIR/PTD-LIST MANAGER ROUTINE FOR REMOTE PRIMARY VIEW DISPLAY ;10/17/06
|
||||
;;1.0;CLINICAL INFO RESOURCE NETWORK;**44,53**;30 Apr 99;Build 2
|
||||
;
|
||||
;Reference to ^XWB2HL7 supported by IA #3144
|
||||
;Reference to ^XWBDRPC supported by IA #3149
|
||||
;
|
||||
EN(ICN,EXCDT) ;Entry point calling List Template for primary view reject display
|
||||
D EN^VALM("RG EXCPT PV REJECT RDISPLAY")
|
||||
Q
|
||||
;
|
||||
HDR ; -- header code
|
||||
S VALMHDR(1)="MPI PRIMARY VIEW REJECT DISPLAY"
|
||||
Q
|
||||
;
|
||||
INIT ;Display the MPI Primary View Rejected Data Report
|
||||
K ^TMP("RGEXC7",$J)
|
||||
K @VALMAR
|
||||
I '$D(ICN) G EXIT
|
||||
I '$D(EXCDT) G EXIT
|
||||
S LIN=1,X=0,STR="",TXT=""
|
||||
I '$D(^XTMP("RGPVREJ"_ICN,EXCDT)) S TXT=" - No Primary View Reject data exists for this patient/exception date." D ADDTMP
|
||||
N STATUS,R,RETURN,RESULT,RET
|
||||
I $D(^XTMP("RGPVREJ"_ICN,EXCDT)) S RETURN(0)=$P(^XTMP("RGPVREJ"_ICN,EXCDT),"^") D
|
||||
.D RPCCHK^XWB2HL7(.RESULT,RETURN(0)) I +RESULT(0)=1 D
|
||||
..;Retrieve the data
|
||||
..D RTNDATA^XWBDRPC(.RET,RETURN(0)) D
|
||||
...I $G(RET(0))<0 S TXT="No Data Returned Due To: "_$P(RET(0),"^",2,99) S STR=$$SETSTR^VALM1(TXT,STR,2,78) D ADDTMP Q
|
||||
...I $G(RET)'="",$D(@RET) S GLO=RET F S GLO=$Q(@GLO) Q:$QS(GLO,1)'=$J S TXT=@GLO S STR=$$SETSTR^VALM1(TXT,STR,2,78) D ADDTMP
|
||||
...S R="" F S R=$O(RET(R)) Q:R="" S TXT=RET(R) S STR=$$SETSTR^VALM1(TXT,STR,2,78) D ADDTMP
|
||||
K GLO,L,R,SL
|
||||
S VALMCNT=LIN-1
|
||||
Q
|
||||
;
|
||||
ADDTMP ;Set string into the array.
|
||||
S ^TMP("RGEXC7",$J,LIN,0)=STR
|
||||
S ^TMP("RGEXC7",$J,"IDX",LIN,LIN)=""
|
||||
S LIN=LIN+1,STR=""
|
||||
Q
|
||||
;
|
||||
HELP ; -- help code
|
||||
S X="?" D DISP^XQORM1 W !!
|
||||
Q
|
||||
;
|
||||
EXIT ; -- exit code
|
||||
S VALMBCK=""
|
||||
K ^TMP("RGEXC7",$J),GLO,L,LIN,R,RESULT,RET,RETURN,SL,STATUS,STR,TXT,X
|
||||
S VALMBCK="R"
|
||||
Q
|
||||
;
|
||||
EXPND ; -- expand code
|
||||
Q
|
||||
;
|
||||
RGEX07 ;BIR/PTD-LIST MANAGER ROUTINE FOR REMOTE PRIMARY VIEW DISPLAY ;10/17/06
|
||||
;;1.0;CLINICAL INFO RESOURCE NETWORK;**44**;30 Apr 99;Build 8
|
||||
;
|
||||
;Reference to ^XWB2HL7 supported by IA #3144
|
||||
;Reference to ^XWBDRPC supported by IA #3149
|
||||
;
|
||||
EN(ICN,EXCDT) ;Entry point calling List Template for primary view reject display
|
||||
D EN^VALM("RG EXCPT PV REJECT RDISPLAY")
|
||||
Q
|
||||
;
|
||||
HDR ; -- header code
|
||||
S VALMHDR(1)="MPI PRIMARY VIEW REJECT DISPLAY"
|
||||
Q
|
||||
;
|
||||
INIT ;Display the MPI Primary View Rejected Data Report
|
||||
K ^TMP("RGEXC7",$J)
|
||||
K @VALMAR
|
||||
I '$D(ICN) G EXIT
|
||||
I '$D(EXCDT) G EXIT
|
||||
S LIN=1,X=0,STR="",TXT=""
|
||||
I '$D(^XTMP("RGPVREJ",ICN,EXCDT)) S TXT=" - No Primary View Reject data exists for this patient/exception date." D ADDTMP
|
||||
N STATUS,R,RETURN,RESULT,RET
|
||||
I $D(^XTMP("RGPVREJ",ICN,EXCDT)) S RETURN(0)=$P(^XTMP("RGPVREJ",ICN,EXCDT),"^") D
|
||||
.D RPCCHK^XWB2HL7(.RESULT,RETURN(0)) I +RESULT(0)=1 D
|
||||
..;Retrieve the data
|
||||
..D RTNDATA^XWBDRPC(.RET,RETURN(0)) D
|
||||
...I $G(RET(0))<0 S TXT="No Data Returned Due To: "_$P(RET(0),"^",2,99) S STR=$$SETSTR^VALM1(TXT,STR,2,78) D ADDTMP Q
|
||||
...I $G(RET)'="",$D(@RET) S GLO=RET F S GLO=$Q(@GLO) Q:$QS(GLO,1)'=$J S TXT=@GLO S STR=$$SETSTR^VALM1(TXT,STR,2,78) D ADDTMP
|
||||
...S R="" F S R=$O(RET(R)) Q:R="" S TXT=RET(R) S STR=$$SETSTR^VALM1(TXT,STR,2,78) D ADDTMP
|
||||
K GLO,L,R,SL
|
||||
S VALMCNT=LIN-1
|
||||
Q
|
||||
;
|
||||
ADDTMP ;Set string into the array.
|
||||
S ^TMP("RGEXC7",$J,LIN,0)=STR
|
||||
S ^TMP("RGEXC7",$J,"IDX",LIN,LIN)=""
|
||||
S LIN=LIN+1,STR=""
|
||||
Q
|
||||
;
|
||||
HELP ; -- help code
|
||||
S X="?" D DISP^XQORM1 W !!
|
||||
Q
|
||||
;
|
||||
EXIT ; -- exit code
|
||||
S VALMBCK=""
|
||||
K ^TMP("RGEXC7",$J),GLO,L,LIN,R,RESULT,RET,RETURN,SL,STATUS,STR,TXT,X
|
||||
S VALMBCK="R"
|
||||
Q
|
||||
;
|
||||
EXPND ; -- expand code
|
||||
Q
|
||||
;
|
||||
|
|
|
|||
|
|
@ -1,172 +1,175 @@
|
|||
RGEXHND1 ;BAY/ALS-MPI/PD EXCEPTION HANDLING UTILITY ;10/08/99
|
||||
;;1.0;CLINICAL INFO RESOURCE NETWORK;**3,12,19,23,43,45,52**;30 Apr 99;Build 2
|
||||
DTLIST ;List exceptions by date
|
||||
K ^TMP("RGEXC",$J)
|
||||
I '$D(RGBG) S VALMBG=1
|
||||
;**45 list exception 234 first regardless of date - Primary View Reject
|
||||
S EXCDT="",EXCTYP=234,(CNT,IEN)=0
|
||||
F S IEN=$O(^RGHL7(991.1,"ASTAT","0",EXCTYP,IEN)) Q:'IEN D
|
||||
.S IEN2=0
|
||||
.F S IEN2=$O(^RGHL7(991.1,"ASTAT","0",EXCTYP,IEN,IEN2)) Q:'IEN2 D
|
||||
..S EXCDT=$P(^RGHL7(991.1,IEN,0),"^",3)
|
||||
..D ADDREC
|
||||
S EXCDT="",EXCTYP=""
|
||||
F S EXCDT=$O(^RGHL7(991.1,"AD",EXCDT)) Q:'EXCDT D
|
||||
. S IEN=0
|
||||
. F S IEN=$O(^RGHL7(991.1,"AD",EXCDT,IEN)) Q:'IEN D
|
||||
.. S NUM="" S NUM=$P($G(^RGHL7(991.1,IEN,1,0)),"^",4) Q:NUM<1 D
|
||||
... S IEN2=0
|
||||
... F S IEN2=$O(^RGHL7(991.1,IEN,1,IEN2)) Q:'IEN2 D
|
||||
.... S EXCTYP=$P(^RGHL7(991.1,IEN,1,IEN2,0),"^",3)
|
||||
....;don't include 234 below; those were done first (above).
|
||||
.... I EXCTYP=218 D ADDREC ;**45;MPIC_772; **52 remove 215, 216, and 217
|
||||
K I,NUM,EXCDT,EXCTYP,RGBG
|
||||
IF CNT<1 D NDATA
|
||||
Q
|
||||
;
|
||||
NDATA ; There is no data matching the criteria
|
||||
S CNT=CNT+1,STRING=""
|
||||
S STRING=$$SETSTR^VALM1("There were no exceptions found.",STRING,5,35)
|
||||
S ^TMP("RGEXC",$J,CNT,0)=STRING
|
||||
S ^TMP("RGEXC",$J,"IDX",CNT,CNT)=""
|
||||
S VALMCNT=CNT
|
||||
Q
|
||||
EXCLST ;List exceptions by type
|
||||
K ^TMP("RGEXC",$J)
|
||||
S CNT=0,EXCDT="",EXCTYP=""
|
||||
I '$D(RGBG) S VALMBG=1
|
||||
F S EXCTYP=$O(^RGHL7(991.1,"AC",EXCTYP)) Q:'EXCTYP D
|
||||
. I (EXCTYP=234)!(EXCTYP=218) D ;**45;MPIC_772; **52 remove 215, 216, and 217
|
||||
.. S IEN=0
|
||||
.. F S IEN=$O(^RGHL7(991.1,"AC",EXCTYP,IEN)) Q:'IEN D
|
||||
... S NUM="" S NUM=$P($G(^RGHL7(991.1,IEN,1,0)),"^",4) Q:NUM<1 D
|
||||
.... S IEN2=0
|
||||
.... F S IEN2=$O(^RGHL7(991.1,"AC",EXCTYP,IEN,IEN2)) Q:'IEN2 D
|
||||
..... S EXCDT=$P($G(^RGHL7(991.1,IEN,0)),"^",3) Q:'EXCDT
|
||||
..... D ADDREC
|
||||
IF CNT<1 D NDATA
|
||||
K RGBG
|
||||
Q
|
||||
PATLST ;List exceptions by patient
|
||||
K ^TMP("RGEXC",$J),^TMP("RGEX01",$J)
|
||||
S CNT=0,EXCDT="",EXCTYP="",NDX=0,NAME=""
|
||||
I '$D(RGBG) S VALMBG=1
|
||||
F S EXCTYP=$O(^RGHL7(991.1,"ADFN",EXCTYP)) Q:'EXCTYP D
|
||||
. I (EXCTYP=234)!(EXCTYP=218) D ;**45;MPIC_772; **52 remove 215, 216, and 217
|
||||
.. S DFN=""
|
||||
.. F S DFN=$O(^RGHL7(991.1,"ADFN",EXCTYP,DFN)) Q:'DFN D
|
||||
... S IEN=0
|
||||
... F S IEN=$O(^RGHL7(991.1,"ADFN",EXCTYP,DFN,IEN)) Q:'IEN D
|
||||
.... S IEN2=0
|
||||
.... F S IEN2=$O(^RGHL7(991.1,"ADFN",EXCTYP,DFN,IEN,IEN2)) Q:'IEN2 D
|
||||
..... S EXCDT=$P($G(^RGHL7(991.1,IEN,0)),"^",3) Q:'EXCDT
|
||||
..... D DEM^VADPT S NAME=VADM(1) Q:NAME=""
|
||||
..... S NDX=NDX+1
|
||||
..... S ^TMP("RGEX01",$J,NAME,NDX)=$G(VADM(1))_"^"_IEN_"^"_IEN2_"^"_EXCTYP_"^"_EXCDT
|
||||
D PATTMP
|
||||
IF CNT<1 D NDATA
|
||||
K DFN,RGBG
|
||||
Q
|
||||
PATTMP ;
|
||||
S NM=""
|
||||
F S NM=$O(^TMP("RGEX01",$J,NM)) Q:NM="" D
|
||||
. S NDX=0
|
||||
. F S NDX=$O(^TMP("RGEX01",$J,NM,NDX)) Q:'NDX D
|
||||
.. S IEN=$P(^TMP("RGEX01",$J,NM,NDX),"^",2)
|
||||
.. S IEN2=$P(^TMP("RGEX01",$J,NM,NDX),"^",3)
|
||||
.. S EXCTYP=$P(^TMP("RGEX01",$J,NM,NDX),"^",4)
|
||||
.. S EXCDT=$P(^TMP("RGEX01",$J,NM,NDX),"^",5)
|
||||
.. D ADDREC
|
||||
K NDX,NM,NAME
|
||||
Q
|
||||
SELTYP ; List all exceptions of type selected by user
|
||||
S EXCTYPE="",FLAG=0,ETYPE=""
|
||||
I '$D(RGBG) S VALMBG=1
|
||||
K DIR,Y,DIC
|
||||
S DIR("A")="Enter an exception type to view: "
|
||||
S DIR(0)="SAM^218:Potential Matches Returned;234:Primary View Reject" ;**43;**45;MPIC_772; **52 remove 215, 216, and 217
|
||||
S DIR("?")="^D HLPSEL^RGEXHND1"
|
||||
D ^DIR
|
||||
I Y<1 S RGSORT="SD" D SORT^RGEX01 Q
|
||||
Q:$D(DUOUT)!$D(DTOUT)
|
||||
S EXCTYPE=+Y,ETYPE=$P(^RGHL7(991.11,EXCTYPE,10),"^",1)
|
||||
I (EXCTYPE=234)!(EXCTYPE=218) S FLAG=1 ;**43;**45;MPIC_772; **52 remove 215, 216, and 217
|
||||
I FLAG=1 D ADDSEL
|
||||
E I FLAG=0 D
|
||||
. W !,"Not a valid selection."
|
||||
. D SELTYP
|
||||
K FLAG,Y,DIR,DIC,DTOUT,DUOUT,RGBG
|
||||
Q
|
||||
ADDSEL ;called by SELTYP
|
||||
K ^TMP("RGEXC",$J)
|
||||
S CNT=0,EXCDT="",EXCTYP=""
|
||||
F S EXCTYP=$O(^RGHL7(991.1,"AC",EXCTYP)) Q:'EXCTYP D
|
||||
. I EXCTYP=EXCTYPE D
|
||||
.. S IEN=0
|
||||
.. F S IEN=$O(^RGHL7(991.1,"AC",EXCTYP,IEN)) Q:'IEN D
|
||||
... S IEN2=0
|
||||
... F S IEN2=$O(^RGHL7(991.1,"AC",EXCTYP,IEN,IEN2)) Q:'IEN2 D
|
||||
.... S EXCDT=$P($G(^RGHL7(991.1,IEN,0)),"^",3) Q:'EXCDT ;**43
|
||||
.... D ADDREC
|
||||
I CNT<1 D
|
||||
. W !,"There are no "_ETYPE
|
||||
. W !,"exceptions that need processing."
|
||||
. D SELTYP
|
||||
Q
|
||||
HLPSEL ;
|
||||
D FULL^VALM1
|
||||
;W !,"The following exception types are handled by this option:"
|
||||
;W !,"Potential Matches Returned",?50,"(218)"
|
||||
;W !,"Primary View Reject",?50,"(234)"
|
||||
S VALMBCK="R"
|
||||
Q
|
||||
ADDREC ;
|
||||
S ETEXT="",RGDFN="",ICN="",RGNM="",STAT="",DOD=""
|
||||
S ETEXT=$P($G(^RGHL7(991.11,EXCTYP,10)),"^",1)
|
||||
S RGDFN=$P(^RGHL7(991.1,IEN,1,IEN2,0),"^",4) Q:'RGDFN
|
||||
S STAT=$P($G(^RGHL7(991.1,IEN,1,IEN2,0)),"^",5)
|
||||
S ICN=+$$GETICN^MPIF001(RGDFN)
|
||||
S HOME=$$SITE^VASITE()
|
||||
I (STAT<1)!(STAT="") D
|
||||
.;Only list exceptions that are Not Processed
|
||||
.; only list patients with local ICN, or for exceptions 234 or 218;MPIC_772; **52 remove 215, 216, and 217
|
||||
. I $E(ICN,1,3)=$E($P(HOME,"^",3),1,3)!(ICN<0)!(EXCTYP=234)!(EXCTYP=218) D ;**43,**45,**52
|
||||
.. S DFN=RGDFN D DEM^VADPT
|
||||
.. S RGNM=VADM(1)
|
||||
.. S RGSSN=$P($G(VADM(2)),"^",1)
|
||||
.. S DOB=$G(VADM(3)) I DOB="" S DOB="^"
|
||||
.. S DOD=$P($P($G(VADM(6)),"^",2),"@",1)
|
||||
.. S EXDATE=$P($$FMTE^XLFDT(EXCDT,2),"@",1)
|
||||
.. S CNT=CNT+1
|
||||
.. S STRING=""
|
||||
.. I ICN<0 S ICN=""
|
||||
.. S STRING=$$SETSTR^VALM1(CNT,STRING,1,4)
|
||||
.. S STRING=$$SETSTR^VALM1($E(RGNM,1,22),STRING,6,21)
|
||||
.. S STRING=$$SETSTR^VALM1(RGSSN,STRING,28,10)
|
||||
.. S STRING=$$SETSTR^VALM1(EXDATE,STRING,39,8)
|
||||
.. S STRING=$$SETSTR^VALM1(ETEXT,STRING,49,32)
|
||||
.. S ^TMP("RGEXC",$J,CNT,0)=STRING
|
||||
.. S ^TMP("RGEXC",$J,"IDX",CNT,CNT)=""
|
||||
.. S ^TMP("RGEXC",$J,CNT,"DATA")=RGNM_"^"_RGSSN_"^"_$P($$FMTE^XLFDT(EXCDT),"@",1)_"^"_ETEXT_"^"_DFN_"^"_ICN_"^"_DOB_"^"_STAT_"^"_IEN_"^"_IEN2_"^"_CNT_"^"_DOD
|
||||
S VALMCNT=CNT
|
||||
K RGDFN,RGNM,RGSSN,EXDATE,ETEXT,ICN,DOB,STAT,VADM,HOME,STRING,DOD
|
||||
Q
|
||||
SELECT ;
|
||||
I $G(STRING)["no exceptions found" D SORT^RGEX01 Q
|
||||
N VALMY
|
||||
D EN^VALM2(XQORNOD(0),"OS")
|
||||
I '$D(VALMY) Q
|
||||
S VALMCNT=CNT
|
||||
S DATA="",CNT=""
|
||||
S CNT=$O(VALMY(0))
|
||||
S DATA=$G(^TMP("RGEXC",$J,CNT,"DATA"))
|
||||
I '$D(DATA) S CNT=0 Q
|
||||
D CLEAN^VALM10
|
||||
D EN^RGEX03(DATA)
|
||||
I RGSORT="VT" D
|
||||
. K @VALMAR
|
||||
. D ADDSEL
|
||||
E I RGSORT'="VT" D SORT^RGEX01
|
||||
;
|
||||
Q
|
||||
QUIT ;
|
||||
RGEXHND1 ;BAY/ALS-MPI/PD EXCEPTION HANDLING UTILITY ;10/08/99
|
||||
;;1.0;CLINICAL INFO RESOURCE NETWORK;**3,12,19,23,43,45**;30 Apr 99;Build 9
|
||||
DTLIST ;List exceptions by date
|
||||
K ^TMP("RGEXC",$J)
|
||||
I '$D(RGBG) S VALMBG=1
|
||||
;**45 list exception 234 first regardless of date - Primary View Reject
|
||||
S EXCDT="",EXCTYP=234,(CNT,IEN)=0
|
||||
F S IEN=$O(^RGHL7(991.1,"ASTAT","0",EXCTYP,IEN)) Q:'IEN D
|
||||
.S IEN2=0
|
||||
.F S IEN2=$O(^RGHL7(991.1,"ASTAT","0",EXCTYP,IEN,IEN2)) Q:'IEN2 D
|
||||
..S EXCDT=$P(^RGHL7(991.1,IEN,0),"^",3)
|
||||
..D ADDREC
|
||||
S EXCDT="",EXCTYP=""
|
||||
F S EXCDT=$O(^RGHL7(991.1,"AD",EXCDT)) Q:'EXCDT D
|
||||
. S IEN=0
|
||||
. F S IEN=$O(^RGHL7(991.1,"AD",EXCDT,IEN)) Q:'IEN D
|
||||
.. S NUM="" S NUM=$P($G(^RGHL7(991.1,IEN,1,0)),"^",4) Q:NUM<1 D
|
||||
... S IEN2=0
|
||||
... F S IEN2=$O(^RGHL7(991.1,IEN,1,IEN2)) Q:'IEN2 D
|
||||
.... S EXCTYP=$P(^RGHL7(991.1,IEN,1,IEN2,0),"^",3)
|
||||
....;don't include 234 below; those were done first (above).
|
||||
.... I ((EXCTYP>214)&(EXCTYP<219)) D ADDREC ;**45
|
||||
K I,NUM,EXCDT,EXCTYP,RGBG
|
||||
IF CNT<1 D NDATA
|
||||
Q
|
||||
;
|
||||
NDATA ; There is no data matching the criteria
|
||||
S CNT=CNT+1,STRING=""
|
||||
S STRING=$$SETSTR^VALM1("There were no exceptions found.",STRING,5,35)
|
||||
S ^TMP("RGEXC",$J,CNT,0)=STRING
|
||||
S ^TMP("RGEXC",$J,"IDX",CNT,CNT)=""
|
||||
S VALMCNT=CNT
|
||||
Q
|
||||
EXCLST ;List exceptions by type
|
||||
K ^TMP("RGEXC",$J)
|
||||
S CNT=0,EXCDT="",EXCTYP=""
|
||||
I '$D(RGBG) S VALMBG=1
|
||||
F S EXCTYP=$O(^RGHL7(991.1,"AC",EXCTYP)) Q:'EXCTYP D
|
||||
. I (EXCTYP=234)!((EXCTYP>214)&(EXCTYP<219)) D ;**45
|
||||
.. S IEN=0
|
||||
.. F S IEN=$O(^RGHL7(991.1,"AC",EXCTYP,IEN)) Q:'IEN D
|
||||
... S NUM="" S NUM=$P($G(^RGHL7(991.1,IEN,1,0)),"^",4) Q:NUM<1 D
|
||||
.... S IEN2=0
|
||||
.... F S IEN2=$O(^RGHL7(991.1,"AC",EXCTYP,IEN,IEN2)) Q:'IEN2 D
|
||||
..... S EXCDT=$P($G(^RGHL7(991.1,IEN,0)),"^",3) Q:'EXCDT
|
||||
..... D ADDREC
|
||||
IF CNT<1 D NDATA
|
||||
K RGBG
|
||||
Q
|
||||
PATLST ;List exceptions by patient
|
||||
K ^TMP("RGEXC",$J),^TMP("RGEX01",$J)
|
||||
S CNT=0,EXCDT="",EXCTYP="",NDX=0,NAME=""
|
||||
I '$D(RGBG) S VALMBG=1
|
||||
F S EXCTYP=$O(^RGHL7(991.1,"ADFN",EXCTYP)) Q:'EXCTYP D
|
||||
. I (EXCTYP=234)!((EXCTYP>214)&(EXCTYP<219)) D ;**45
|
||||
.. S DFN=""
|
||||
.. F S DFN=$O(^RGHL7(991.1,"ADFN",EXCTYP,DFN)) Q:'DFN D
|
||||
... S IEN=0
|
||||
... F S IEN=$O(^RGHL7(991.1,"ADFN",EXCTYP,DFN,IEN)) Q:'IEN D
|
||||
.... S IEN2=0
|
||||
.... F S IEN2=$O(^RGHL7(991.1,"ADFN",EXCTYP,DFN,IEN,IEN2)) Q:'IEN2 D
|
||||
..... S EXCDT=$P($G(^RGHL7(991.1,IEN,0)),"^",3) Q:'EXCDT
|
||||
..... D DEM^VADPT S NAME=VADM(1) Q:NAME=""
|
||||
..... S NDX=NDX+1
|
||||
..... S ^TMP("RGEX01",$J,NAME,NDX)=$G(VADM(1))_"^"_IEN_"^"_IEN2_"^"_EXCTYP_"^"_EXCDT
|
||||
D PATTMP
|
||||
IF CNT<1 D NDATA
|
||||
K DFN,RGBG
|
||||
Q
|
||||
PATTMP ;
|
||||
S NM=""
|
||||
F S NM=$O(^TMP("RGEX01",$J,NM)) Q:NM="" D
|
||||
. S NDX=0
|
||||
. F S NDX=$O(^TMP("RGEX01",$J,NM,NDX)) Q:'NDX D
|
||||
.. S IEN=$P(^TMP("RGEX01",$J,NM,NDX),"^",2)
|
||||
.. S IEN2=$P(^TMP("RGEX01",$J,NM,NDX),"^",3)
|
||||
.. S EXCTYP=$P(^TMP("RGEX01",$J,NM,NDX),"^",4)
|
||||
.. S EXCDT=$P(^TMP("RGEX01",$J,NM,NDX),"^",5)
|
||||
.. D ADDREC
|
||||
K NDX,NM,NAME
|
||||
Q
|
||||
SELTYP ; List all exceptions of type selected by user
|
||||
S EXCTYPE="",FLAG=0,ETYPE=""
|
||||
I '$D(RGBG) S VALMBG=1
|
||||
K DIR,Y,DIC
|
||||
S DIR("A")="Enter an exception type to view: "
|
||||
S DIR(0)="SAM^215:Death Entry on MPI not VISTA;216:Death Entry on Vista not MPI;217:Death Entries on MPI and Vista DON'T MATCH;218:Potential Matches Returned;234:Primary View Reject" ;**43,45
|
||||
S DIR("?")="^D HLPSEL^RGEXHND1"
|
||||
D ^DIR
|
||||
I Y<1 S RGSORT="SD" D SORT^RGEX01 Q
|
||||
Q:$D(DUOUT)!$D(DTOUT)
|
||||
S EXCTYPE=+Y,ETYPE=$P(^RGHL7(991.11,EXCTYPE,10),"^",1)
|
||||
I (EXCTYPE=234)!((EXCTYPE>214)&(EXCTYPE<219)) S FLAG=1 ;**43,45
|
||||
I FLAG=1 D ADDSEL
|
||||
E I FLAG=0 D
|
||||
. W !,"Not a valid selection."
|
||||
. D SELTYP
|
||||
K FLAG,Y,DIR,DIC,DTOUT,DUOUT,RGBG
|
||||
Q
|
||||
ADDSEL ;called by SELTYP
|
||||
K ^TMP("RGEXC",$J)
|
||||
S CNT=0,EXCDT="",EXCTYP=""
|
||||
F S EXCTYP=$O(^RGHL7(991.1,"AC",EXCTYP)) Q:'EXCTYP D
|
||||
. I EXCTYP=EXCTYPE D
|
||||
.. S IEN=0
|
||||
.. F S IEN=$O(^RGHL7(991.1,"AC",EXCTYP,IEN)) Q:'IEN D
|
||||
... S IEN2=0
|
||||
... F S IEN2=$O(^RGHL7(991.1,"AC",EXCTYP,IEN,IEN2)) Q:'IEN2 D
|
||||
.... S EXCDT=$P($G(^RGHL7(991.1,IEN,0)),"^",3) Q:'EXCDT ;**43
|
||||
.... D ADDREC
|
||||
I CNT<1 D
|
||||
. W !,"There are no "_ETYPE
|
||||
. W !,"exceptions that need processing."
|
||||
. D SELTYP
|
||||
Q
|
||||
HLPSEL ;
|
||||
D FULL^VALM1
|
||||
;W !,"The following exception types are handled by this option:"
|
||||
;W !!,"Death Entry on MPI not in VISTA",?50,"(215)"
|
||||
;W !,"Death Entry on Vista not in MPI",?50,"(216)"
|
||||
;W !,"Death Entries on MPI and Vista DO NOT MATCH",?50,"(217)"
|
||||
;W !,"Potential Matches Returned",?50,"(218)"
|
||||
;W !,"Primary View Reject",?50,"(234)"
|
||||
S VALMBCK="R"
|
||||
Q
|
||||
ADDREC ;
|
||||
S ETEXT="",RGDFN="",ICN="",RGNM="",STAT="",DOD=""
|
||||
S ETEXT=$P($G(^RGHL7(991.11,EXCTYP,10)),"^",1)
|
||||
S RGDFN=$P(^RGHL7(991.1,IEN,1,IEN2,0),"^",4) Q:'RGDFN
|
||||
S STAT=$P($G(^RGHL7(991.1,IEN,1,IEN2,0)),"^",5)
|
||||
S ICN=+$$GETICN^MPIF001(RGDFN)
|
||||
S HOME=$$SITE^VASITE()
|
||||
I (STAT<1)!(STAT="") D
|
||||
.;Only list exceptions that are Not Processed
|
||||
.; only list patients with local ICN, or for exceptions 234, 215 - 218
|
||||
. I $E(ICN,1,3)=$E($P(HOME,"^",3),1,3)!(ICN<0)!(EXCTYP=234)!((EXCTYP>214)&(EXCTYP<219)) D ;**43,45
|
||||
.. S DFN=RGDFN D DEM^VADPT
|
||||
.. S RGNM=VADM(1)
|
||||
.. S RGSSN=$P($G(VADM(2)),"^",1)
|
||||
.. S DOB=$G(VADM(3)) I DOB="" S DOB="^"
|
||||
.. S DOD=$P($P($G(VADM(6)),"^",2),"@",1)
|
||||
.. S EXDATE=$P($$FMTE^XLFDT(EXCDT,2),"@",1)
|
||||
.. S CNT=CNT+1
|
||||
.. S STRING=""
|
||||
.. I ICN<0 S ICN=""
|
||||
.. S STRING=$$SETSTR^VALM1(CNT,STRING,1,4)
|
||||
.. S STRING=$$SETSTR^VALM1($E(RGNM,1,22),STRING,6,21)
|
||||
.. S STRING=$$SETSTR^VALM1(RGSSN,STRING,28,10)
|
||||
.. S STRING=$$SETSTR^VALM1(EXDATE,STRING,39,8)
|
||||
.. S STRING=$$SETSTR^VALM1(ETEXT,STRING,49,32)
|
||||
.. S ^TMP("RGEXC",$J,CNT,0)=STRING
|
||||
.. S ^TMP("RGEXC",$J,"IDX",CNT,CNT)=""
|
||||
.. S ^TMP("RGEXC",$J,CNT,"DATA")=RGNM_"^"_RGSSN_"^"_$P($$FMTE^XLFDT(EXCDT),"@",1)_"^"_ETEXT_"^"_DFN_"^"_ICN_"^"_DOB_"^"_STAT_"^"_IEN_"^"_IEN2_"^"_CNT_"^"_DOD
|
||||
S VALMCNT=CNT
|
||||
K RGDFN,RGNM,RGSSN,EXDATE,ETEXT,ICN,DOB,STAT,VADM,HOME,STRING,DOD
|
||||
Q
|
||||
SELECT ;
|
||||
I $G(STRING)["no exceptions found" D SORT^RGEX01 Q
|
||||
N VALMY
|
||||
D EN^VALM2(XQORNOD(0),"OS")
|
||||
I '$D(VALMY) Q
|
||||
S VALMCNT=CNT
|
||||
S DATA="",CNT=""
|
||||
S CNT=$O(VALMY(0))
|
||||
S DATA=$G(^TMP("RGEXC",$J,CNT,"DATA"))
|
||||
I '$D(DATA) S CNT=0 Q
|
||||
D CLEAN^VALM10
|
||||
D EN^RGEX03(DATA)
|
||||
I RGSORT="VT" D
|
||||
. K @VALMAR
|
||||
. D ADDSEL
|
||||
E I RGSORT'="VT" D SORT^RGEX01
|
||||
;
|
||||
Q
|
||||
QUIT ;
|
||||
|
|
|
|||
|
|
@ -1,239 +1,200 @@
|
|||
MDAPI ; HOIFO/DP/NCA - CP API Calls ; [05-05-2003 10:28]
|
||||
;;1.0;CLINICAL PROCEDURES;**6**;Apr 01, 2004;Build 102
|
||||
; Description:
|
||||
; These API's are for use by external packages communicating with CP.
|
||||
;
|
||||
; Integration Agreements:
|
||||
; IA# 3378 [Subscription] Documents the APIs that external packages use to communicate with CP.
|
||||
; IA# 3468 [Subscription] Use GMRCCP APIs.
|
||||
;
|
||||
EXTDATA(MDPROC) ; [Procedure]
|
||||
; Returns 0/1 for external data needed
|
||||
; Called by Consults to determine status of consult ordered
|
||||
;
|
||||
; Input parameters
|
||||
; 1. MDPROC [Literal/Required] CP Definition IEN
|
||||
;
|
||||
Q:'$D(^MDS(702.01,+$G(MDPROC),0)) 0
|
||||
I +$P(^MDS(702.01,+$G(MDPROC),0),U,3)!($O(^(.1,0))) Q 1
|
||||
E Q 0
|
||||
;
|
||||
ISTAT(MDARR) ; [Procedure] Called by Imaging to update status
|
||||
; Input parameters
|
||||
; 1. MDARR [Literal/Required] Array from Imaging
|
||||
;
|
||||
; Input: MDARR(0)="0^error message" or "1^success message"
|
||||
; MDARR(1)=TrackID (CP;Transaction IEN)
|
||||
; MDARR(2)=Queue Number
|
||||
; MDARR(3..N)=Warnings
|
||||
N MDCON,MDCR,MDIEN,MDIENS,MDLP,MDSTAT,MDSTR,MDTIU,RESULTS
|
||||
Q:$G(MDARR(0))=""
|
||||
Q:$G(MDARR(1))=""
|
||||
Q:$P(MDARR(1),";")'="CP"
|
||||
Q:'(+$P(MDARR(1),";",2))
|
||||
S MDIEN=+$P(MDARR(1),";",2),MDIENS=MDIEN_","
|
||||
S MDSTAT=+$P(MDARR(0),"^")
|
||||
S DATA("TRANSACTION")=MDIEN
|
||||
; Is it in error?
|
||||
I 'MDSTAT D Q
|
||||
.D STATUS^MDRPCOT(MDIENS,2,$P(MDARR(0),"^",2))
|
||||
.S DATA("PKG")="IMAGING"
|
||||
.S DATA("MESSAGE")=$P(MDARR(0),"^",2) D RPC^MDRPCOT(.RESULTS,"ADDMSG",.DATA)
|
||||
.F MDLP=2:0 S MDLP=$O(MDARR(MDLP)) Q:'MDLP I $G(MDARR(MDLP))'="" D
|
||||
..S DATA("MESSAGE")=$$TRANS(MDARR(MDLP)) D RPC^MDRPCOT(.RESULTS,"ADDMSG",.DATA)
|
||||
.D IMGSTAT^MDRPCOT1(+MDIENS,2) Q
|
||||
; Call Consults that Partial Result ready
|
||||
S MDCON=+$P(^MDD(702,MDIEN,0),"^",5),MDTIU=+$P(^(0),"^",6)
|
||||
S MDCR=$$UPDCONS^MDRPCOT1(MDCON,MDTIU)
|
||||
I +MDCR<0 D Q
|
||||
.D STATUS^MDRPCOT(MDIENS,2,$P(MDCR,"^",2))
|
||||
.S DATA("PKG")="CONSULTS",DATA("MESSAGE")=$P(MDCR,"^",2)
|
||||
.D RPC^MDRPCOT(.RESULTS,"ADDMSG",.DATA)
|
||||
.Q
|
||||
; Closeout the record
|
||||
D STATUS^MDRPCOT(MDIENS,3,"")
|
||||
; Update Images Status
|
||||
D IMGSTAT^MDRPCOT1(+MDIENS,3)
|
||||
Q
|
||||
;
|
||||
ITIU(RESULTS,DFN,CONSULT,VSTRING) ; [Procedure] API for Vista Imaging
|
||||
; This API enables VistA Imaging to retrieve/create a TIU note for
|
||||
; a consult for attaching images to.
|
||||
;
|
||||
; RESULTS(0) will equal one of the following
|
||||
; IEN of the TIU note if successful
|
||||
; or on failure one of the following status messages
|
||||
; -1^No patient DFN
|
||||
; -1^No Consult IEN
|
||||
; -1^No VString
|
||||
; -1^Error in CP transaction
|
||||
; -1^Unable to create CP transaction
|
||||
; -1^Unable to create the TIU document
|
||||
; -1^No such consult for this patient.
|
||||
;
|
||||
; Input parameters
|
||||
; 1. RESULTS [Reference/Required] Return array
|
||||
; 2. DFN [Literal/Required] Patient IEN
|
||||
; 3. CONSULT [Literal/Required] Consult IEN
|
||||
; 4. VSTRING [Literal/Optional] VString data for TIU Note (Required to create new TIU note)
|
||||
;
|
||||
; Variables:
|
||||
; MDIEN: [Private] Returns IEN from UPDATE~DIE call
|
||||
; MDIENS: [Private] Scratch
|
||||
; MDNOTE: [Private] Scratch
|
||||
; MDTRANS: [Private] Contains IEN of CP transaction
|
||||
;
|
||||
; New private variables
|
||||
NEW MDIEN,MDIENS,MDNOTE,MDTRANS
|
||||
K ^TMP($J),^TMP("MDTIUST",$J)
|
||||
N MDD,MDN,MDTIUER,MDTST,MDNEWV,MDTIUD S (MDTIUD,MDTIUER,MDTST)=""
|
||||
I '$G(DFN) S RESULTS(0)="-1^No patient DFN" Q
|
||||
I '$G(CONSULT) S RESULTS(0)="-1^No Consult IEN" Q
|
||||
; Look for existing transaction
|
||||
S MDTIUD=$$PREV^MDRPCOT(+CONSULT,"")
|
||||
I +MDTIUD S RESULTS(0)=+MDTIUD Q
|
||||
; No transaction, must create one for this consult
|
||||
I $G(VSTRING)="" S RESULTS(0)="-1^No VString" Q
|
||||
D CPLIST^GMRCCP(DFN,,$NA(^TMP($J)))
|
||||
S MDX="" F S MDX=$O(^TMP($J,MDX)) Q:'MDX I $P(^(MDX),U,5)=CONSULT D Q
|
||||
.D NOW^%DTC S MDD=%
|
||||
.S:$L(VSTRING,";")=1 VSTRING=";"_VSTRING
|
||||
.S MDNEWV=$$GETVSTR^MDRPCOT1(DFN,VSTRING,$P(^TMP($J,MDX),U,6),MDD)
|
||||
.S MDFDA(702,"+1,",.01)=DFN
|
||||
.S MDFDA(702,"+1,",.02)=MDD
|
||||
.S MDFDA(702,"+1,",.03)=DUZ
|
||||
.S MDFDA(702,"+1,",.04)=$P(^TMP($J,MDX),U,6)
|
||||
.S MDFDA(702,"+1,",.05)=CONSULT
|
||||
.S MDFDA(702,"+1,",.07)=$P(MDNEWV,";",3)_";"_$P(MDNEWV,";",2)_";"_$P(MDNEWV,";")
|
||||
.S MDFDA(702,"+1,",.09)=0
|
||||
.;Create the new transaction
|
||||
.D UPDATE^DIE("","MDFDA","MDIEN") I '$G(MDIEN(1)) D Q
|
||||
..S RESULTS(0)="-1^Unable to create CP transaction"
|
||||
.
|
||||
.;Create the new TIU Note
|
||||
.S MDIENS=MDIEN(1)_","
|
||||
.S MDN=$$NEWTIUN^MDRPCOT(+MDIENS)
|
||||
.S MDNOTE=$S(MDN:$$GET1^DIQ(702,+MDIENS,.06,"I"),1:0)
|
||||
.I 'MDNOTE D Q
|
||||
..N DA,DIK
|
||||
..S RESULTS(0)="-1^Unable to create the TIU document"
|
||||
..S DA=+MDIENS,DIK="^MDD(702," D ^DIK
|
||||
.S RESULTS(0)=MDNOTE
|
||||
Q
|
||||
;
|
||||
TIUCOMP(MDNOTE) ; [Procedure] Post Signature action to complete transaction
|
||||
; Input parameters
|
||||
; 1. MDNOTE [Literal/Required] TIU IEN
|
||||
;
|
||||
N MDFDA,MDRES
|
||||
S MDRES=$O(^MDD(702,"ATIU",MDNOTE,0))
|
||||
I $G(^MDD(702,+MDRES,0))="" Q 0
|
||||
I $P($G(^MDD(702,+MDRES,0)),"^",9)=3 Q 1
|
||||
S MDFDA(702,MDRES_",",.09)=3
|
||||
D FILE^DIE("","MDFDA")
|
||||
Q 1
|
||||
;
|
||||
TIUDEL(MDNOTE) ; [Procedure] TIU Note deletion Update
|
||||
; Input parameters
|
||||
; 1. MDNOTE [Literal/Required] TIU IEN
|
||||
;
|
||||
N MDGBL,MDRES,MDFDA,MDTRAN,RESULTS
|
||||
S MDRES="" F S MDRES=$O(^MDD(702,"ATIU",MDNOTE,MDRES)) Q:'MDRES D
|
||||
.Q:$G(^MDD(702,+MDRES,0))=""
|
||||
.;S MDFDA(702,MDRES_",",.05)=""
|
||||
.S MDFDA(702,MDRES_",",.06)=""
|
||||
.D FILE^DIE("","MDFDA")
|
||||
.S MDTRAN=$O(^MDD(702.001,"ASTUDY",MDRES,MDNOTE,0)) I +MDTRAN N DA,DIK S DA=+MDTRAN,DIK="^MDD(702.001," D ^DIK
|
||||
.D STATUS^MDRPCOT(MDRES_",",2,"TIU note deleted.")
|
||||
.S DATA("TRANSACTION")=MDRES,DATA("PKG")="TIU"
|
||||
.S DATA("MESSAGE")="TIU note deleted." D RPC^MDRPCOT(.RESULTS,"ADDMSG",.DATA)
|
||||
S MDGBL=$NA(^MDD(702.001,"PK",MDNOTE)) F S MDGBL=$Q(@MDGBL) Q:MDGBL="" Q:$QS(MDGBL,2)'="PK"!($QS(MDGBL,3)'=MDNOTE) S MDTRAN=$QS(MDGBL,6) N DA,DIK S DA=+MDTRAN,DIK="^MDD(702.001," D ^DIK
|
||||
Q 1
|
||||
;
|
||||
TIUREAS(MDFN,MDOLDC,MDANOTE,MDNDFN,MDNEWC,MDNEWV,MDNTIU) ; [Function] This is an API to clean up and update TIU note re-assignment.
|
||||
; Input parameters
|
||||
; 1. MDFN [Literal/Required] The Patient DFN whose TIU document is being re-assigned.
|
||||
; 2. MDOLDC [Literal/Required] The Consult that the note is being re-assigned from.
|
||||
; 3. MDANOTE [Literal/Required] The TIU Document IEN that is being re-assigned.
|
||||
; 4. MDNDFN [Literal/Required] The Patient DFN who will be re-assigned the TIU document.
|
||||
; 5. MDNEWC [Literal/Required] The consult number that will be assignment the TIU document.
|
||||
; 6. MDNEWV [Literal/Required] The new visit for the TIU document assignment.
|
||||
; 7. MDNTIU [Literal/Required] The new reassigned TIU document IEN.
|
||||
;
|
||||
N MDD,MDGBL,MDTRAN,MDCHK,MDLP,MDMULN,MDN,MDPPR,MDREAS,MDTRANI,MDX
|
||||
I '$G(MDFN) Q "0^No DFN for the TIU note re-assignment."
|
||||
I '$G(MDOLDC) Q "0^No Old Consult # for the note re-assignment."
|
||||
I '$G(MDANOTE) Q "0^No TIU Note IEN."
|
||||
I '$G(MDNDFN) Q "0^No New DFN for the note assignment."
|
||||
I '$G(MDNEWC) Q "0^No New Consult # for the note assignment."
|
||||
I '$G(MDNTIU) Q "0^No New Reassigned TIU IEN."
|
||||
S (MDD,MDCHK,MDREAS,MDTRAN)="",MDPPR=0 K ^TMP("MDTMP",$J)
|
||||
S MDTRAN=$O(^MDD(702,"ATIU",MDANOTE,0)) I +MDTRAN S MDCHK=$G(^MDD(702,MDTRAN,0)),MDTRANI=MDTRAN_"," D
|
||||
.I $P(MDCHK,U,5)=MDOLDC&($P(MDCHK,U,6)=MDANOTE) D
|
||||
..S MDFDA(702,+MDTRAN_",",.06)=""
|
||||
..D FILE^DIE("","MDFDA") K MDFDA
|
||||
S MDGBL=$NA(^MDD(702.001,"PK",MDANOTE))
|
||||
F S MDGBL=$Q(@MDGBL) Q:MDGBL="" Q:$QS(MDGBL,2)'="PK"!($QS(MDGBL,3)'=MDANOTE) S MDN=$QS(MDGBL,6) N DA,DIK S DA=+MDN,DIK="^MDD(702.001," D ^DIK
|
||||
S MDMULN=+$O(^MDD(702.001,"ASTUDY",+MDTRAN,0))
|
||||
I '+MDMULN I +MDTRAN N DA,DIK S DA=+MDTRAN,DIK="^MDD(702," D ^DIK
|
||||
D NOW^%DTC S MDD=% S MDTRANI=$O(^MDD(702,"ACON",MDNEWC,0))
|
||||
S MDREAS=$P(MDNEWV,";",3)_";"_$P(MDNEWV,";",2)_";"_$P(MDNEWV,";")
|
||||
I +MDTRANI&(MDNDFN=+$G(^MDD(702,+MDTRANI,0))) D
|
||||
.S MDPPR=$P($G(^MDD(702,+MDTRANI,0)),"^",4) Q:'MDPPR
|
||||
.S MDNEWV=$$GETVSTR^MDRPCOT1(MDNDFN,MDREAS,MDPPR,MDD)
|
||||
.S MDFDA(702,+MDTRANI_",",.06)=MDNTIU
|
||||
.S MDFDA(702,"+1,",.07)=$P(MDNEWV,";",3)_";"_$P(MDNEWV,";",2)_";"_$P(MDNEWV,";")
|
||||
.D FILE^DIE("","MDFDA") K MDFDA
|
||||
I 'MDPPR D
|
||||
.D CPLIST^GMRCCP(MDNDFN,,$NA(^TMP("MDTMP",$J)))
|
||||
.S MDX=""
|
||||
.F S MDX=$O(^TMP("MDTMP",$J,MDX)) Q:'MDX S:$P(^(MDX),U,5)=MDNEWC MDPPR=$P(^(MDX),U,6)
|
||||
K ^TMP("MDTMP",$J)
|
||||
I +MDPPR Q 1
|
||||
S MDNEWV=$$GETVSTR^MDRPCOT1(MDNDFN,MDREAS,MDPPR,MDD)
|
||||
S MDFDA(702,"+1,",.01)=MDNDFN
|
||||
S MDFDA(702,"+1,",.02)=MDD
|
||||
S MDFDA(702,"+1,",.03)=DUZ
|
||||
S MDFDA(702,"+1,",.04)=MDPPR
|
||||
S MDFDA(702,"+1,",.05)=MDNEWC
|
||||
S MDFDA(702,"+1,",.06)=MDNTIU
|
||||
S MDFDA(702,"+1,",.07)=$P(MDNEWV,";",3)_";"_$P(MDNEWV,";",2)_";"_$P(MDNEWV,";")
|
||||
S MDFDA(702,"+1,",.09)=0
|
||||
D UPDATE^DIE("","MDFDA")
|
||||
Q 1
|
||||
;
|
||||
TRANS(STR) ; [Function] Translate the upper arrows to blanks
|
||||
; Input parameters
|
||||
; 1. STR [Literal/Required] Input: Text with upper arrows that needs to be removed
|
||||
;
|
||||
I STR["^" Q $TR(STR,"^"," ")
|
||||
Q STR
|
||||
;
|
||||
GETCP(RESULTS,MDCSLT) ; API to return CP Study data
|
||||
; Input Parameters:
|
||||
; 1. RESULTS [Literal/Required] Return Array
|
||||
; 2. MDCSLT [Literal/Required] Consult number
|
||||
;
|
||||
; Output:
|
||||
; RESULTS(0)=-1^Error Message or 1 for success
|
||||
; (N,1)=CP Study Number
|
||||
; (N,2)=Patient DFN
|
||||
; (N,3)=Created Date/Time
|
||||
; (N,4)=Created By
|
||||
; (N,5)=CP Definition (External Name)
|
||||
; (N,6)=Consult Number
|
||||
; (N,7)=TIU Note IEN
|
||||
; (N,8)=VSTR
|
||||
; (N,9)=Transaction Status
|
||||
;
|
||||
; Where N = 1..n entries
|
||||
;
|
||||
N MDCT,MDX,MDY
|
||||
I '$G(MDCSLT) S @RESULTS@(0)="-1^No Consult Number passed" Q
|
||||
S MDX=$O(^MDD(702,"ACON",MDCSLT,0)) I 'MDX S @RESULTS@(0)="-1^No CP Study Entry." Q
|
||||
S @RESULTS@(0)=1
|
||||
S MDCT=0,MDX="" F S MDX=$O(^MDD(702,"ACON",MDCSLT,MDX)) Q:MDX<1 D
|
||||
.S MDCT=MDCT+1,@RESULTS@(MDCT,1)=MDX
|
||||
.S MDY=$G(^MDD(702,+MDX,0)),@RESULTS@(MDCT,2)=$P(MDY,U),@RESULTS@(MDCT,3)=$P(MDY,U,2),@RESULTS@(MDCT,4)=$P(MDY,U,3),@RESULTS@(MDCT,5)=$$GET1^DIQ(702,+MDX,.04,"E")
|
||||
.S @RESULTS@(MDCT,6)=$P(MDY,U,5),@RESULTS@(MDCT,7)=$P(MDY,U,6),@RESULTS@(MDCT,8)=$P(MDY,U,7),@RESULTS@(MDCT,9)=$$GET1^DIQ(702,+MDX,.09,"E")
|
||||
Q
|
||||
MDAPI ; HOIFO/DP/NCA - CP API Calls ; [05-05-2003 10:28]
|
||||
;;1.0;CLINICAL PROCEDURES;;Apr 01, 2004
|
||||
; Description:
|
||||
; These API's are for use by external packages communicating with CP.
|
||||
;
|
||||
; Integration Agreements:
|
||||
; IA# 3378 [Restricted] Documents the APIs that external packages use to communicate with CP.
|
||||
; IA# 3468 [Subscription] Use GMRCCP APIs.
|
||||
;
|
||||
EXTDATA(MDPROC) ; [Procedure]
|
||||
; Returns 0/1 for external data needed
|
||||
; Called by Consults to determine status of consult ordered
|
||||
;
|
||||
; Input parameters
|
||||
; 1. MDPROC [Literal/Required] CP Definition IEN
|
||||
;
|
||||
Q:'$D(^MDS(702.01,+$G(MDPROC),0)) 0
|
||||
I +$P(^MDS(702.01,+$G(MDPROC),0),U,3)!($O(^(.1,0))) Q 1
|
||||
E Q 0
|
||||
;
|
||||
ISTAT(MDARR) ; [Procedure] Called by Imaging to update status
|
||||
; Input parameters
|
||||
; 1. MDARR [Literal/Required] Array from Imaging
|
||||
;
|
||||
; Input: MDARR(0)="0^error message" or "1^success message"
|
||||
; MDARR(1)=TrackID (CP;Transaction IEN)
|
||||
; MDARR(2)=Queue Number
|
||||
; MDARR(3..N)=Warnings
|
||||
N MDCON,MDCR,MDIEN,MDIENS,MDLP,MDSTAT,MDSTR,MDTIU,RESULTS
|
||||
Q:$G(MDARR(0))=""
|
||||
Q:$G(MDARR(1))=""
|
||||
Q:$P(MDARR(1),";")'="CP"
|
||||
Q:'(+$P(MDARR(1),";",2))
|
||||
S MDIEN=+$P(MDARR(1),";",2),MDIENS=MDIEN_","
|
||||
S MDSTAT=+$P(MDARR(0),"^")
|
||||
S DATA("TRANSACTION")=MDIEN
|
||||
; Is it in error?
|
||||
I 'MDSTAT D Q
|
||||
.D STATUS^MDRPCOT(MDIENS,2,$P(MDARR(0),"^",2))
|
||||
.S DATA("PKG")="IMAGING"
|
||||
.S DATA("MESSAGE")=$P(MDARR(0),"^",2) D RPC^MDRPCOT(.RESULTS,"ADDMSG",.DATA)
|
||||
.F MDLP=2:0 S MDLP=$O(MDARR(MDLP)) Q:'MDLP I $G(MDARR(MDLP))'="" D
|
||||
..S DATA("MESSAGE")=$$TRANS(MDARR(MDLP)) D RPC^MDRPCOT(.RESULTS,"ADDMSG",.DATA)
|
||||
.D IMGSTAT^MDRPCOT1(+MDIENS,2) Q
|
||||
; Call Consults that Partial Result ready
|
||||
S MDCON=+$P(^MDD(702,MDIEN,0),"^",5),MDTIU=+$P(^(0),"^",6)
|
||||
S MDCR=$$UPDCONS^MDRPCOT1(MDCON,MDTIU)
|
||||
I +MDCR<0 D Q
|
||||
.D STATUS^MDRPCOT(MDIENS,2,$P(MDCR,"^",2))
|
||||
.S DATA("PKG")="CONSULTS",DATA("MESSAGE")=$P(MDCR,"^",2)
|
||||
.D RPC^MDRPCOT(.RESULTS,"ADDMSG",.DATA)
|
||||
.Q
|
||||
; Closeout the record
|
||||
D STATUS^MDRPCOT(MDIENS,3,"")
|
||||
; Update Images Status
|
||||
D IMGSTAT^MDRPCOT1(+MDIENS,3)
|
||||
Q
|
||||
;
|
||||
ITIU(RESULTS,DFN,CONSULT,VSTRING) ; [Procedure] API for Vista Imaging
|
||||
; This API enables VistA Imaging to retrieve/create a TIU note for
|
||||
; a consult for attaching images to.
|
||||
;
|
||||
; RESULTS(0) will equal one of the following
|
||||
; IEN of the TIU note if successful
|
||||
; or on failure one of the following status messages
|
||||
; -1^No patient DFN
|
||||
; -1^No Consult IEN
|
||||
; -1^No VString
|
||||
; -1^Error in CP transaction
|
||||
; -1^Unable to create CP transaction
|
||||
; -1^Unable to create the TIU document
|
||||
; -1^No such consult for this patient.
|
||||
;
|
||||
; Input parameters
|
||||
; 1. RESULTS [Reference/Required] Return array
|
||||
; 2. DFN [Literal/Required] Patient IEN
|
||||
; 3. CONSULT [Literal/Required] Consult IEN
|
||||
; 4. VSTRING [Literal/Optional] VString data for TIU Note (Required to create new TIU note)
|
||||
;
|
||||
; Variables:
|
||||
; MDIEN: [Private] Returns IEN from UPDATE~DIE call
|
||||
; MDIENS: [Private] Scratch
|
||||
; MDNOTE: [Private] Scratch
|
||||
; MDTRANS: [Private] Contains IEN of CP transaction
|
||||
;
|
||||
; New private variables
|
||||
NEW MDIEN,MDIENS,MDNOTE,MDTRANS
|
||||
K ^TMP($J),^TMP("MDTIUST",$J)
|
||||
N MDD,MDN,MDTIUER,MDTST,MDNEWV,MDTIUD S (MDTIUD,MDTIUER,MDTST)=""
|
||||
I '$G(DFN) S RESULTS(0)="-1^No patient DFN" Q
|
||||
I '$G(CONSULT) S RESULTS(0)="-1^No Consult IEN" Q
|
||||
; Look for existing transaction
|
||||
S MDTIUD=$$PREV^MDRPCOT(+CONSULT,"")
|
||||
I +MDTIUD S RESULTS(0)=+MDTIUD Q
|
||||
; No transaction, must create one for this consult
|
||||
I $G(VSTRING)="" S RESULTS(0)="-1^No VString" Q
|
||||
D CPLIST^GMRCCP(DFN,,$NA(^TMP($J)))
|
||||
S MDX="" F S MDX=$O(^TMP($J,MDX)) Q:'MDX I $P(^(MDX),U,5)=CONSULT D Q
|
||||
.D NOW^%DTC S MDD=%
|
||||
.S:$L(VSTRING,";")=1 VSTRING=";"_VSTRING
|
||||
.S MDNEWV=$$GETVSTR^MDRPCOT1(DFN,VSTRING,$P(^TMP($J,MDX),U,6),MDD)
|
||||
.S MDFDA(702,"+1,",.01)=DFN
|
||||
.S MDFDA(702,"+1,",.02)=MDD
|
||||
.S MDFDA(702,"+1,",.03)=DUZ
|
||||
.S MDFDA(702,"+1,",.04)=$P(^TMP($J,MDX),U,6)
|
||||
.S MDFDA(702,"+1,",.05)=CONSULT
|
||||
.S MDFDA(702,"+1,",.07)=$P(MDNEWV,";",3)_";"_$P(MDNEWV,";",2)_";"_$P(MDNEWV,";")
|
||||
.S MDFDA(702,"+1,",.09)=0
|
||||
.;Create the new transaction
|
||||
.D UPDATE^DIE("","MDFDA","MDIEN") I '$G(MDIEN(1)) D Q
|
||||
..S RESULTS(0)="-1^Unable to create CP transaction"
|
||||
.
|
||||
.;Create the new TIU Note
|
||||
.S MDIENS=MDIEN(1)_","
|
||||
.S MDN=$$NEWTIUN^MDRPCOT(+MDIENS)
|
||||
.S MDNOTE=$S(MDN:$$GET1^DIQ(702,+MDIENS,.06,"I"),1:0)
|
||||
.I 'MDNOTE D Q
|
||||
..N DA,DIK
|
||||
..S RESULTS(0)="-1^Unable to create the TIU document"
|
||||
..S DA=+MDIENS,DIK="^MDD(702," D ^DIK
|
||||
.S RESULTS(0)=MDNOTE
|
||||
Q
|
||||
;
|
||||
TIUCOMP(MDNOTE) ; [Procedure] Post Signature action to complete transaction
|
||||
; Input parameters
|
||||
; 1. MDNOTE [Literal/Required] TIU IEN
|
||||
;
|
||||
N MDFDA,MDRES
|
||||
S MDRES=$O(^MDD(702,"ATIU",MDNOTE,0))
|
||||
I $G(^MDD(702,+MDRES,0))="" Q 0
|
||||
I $P($G(^MDD(702,+MDRES,0)),"^",9)=3 Q 1
|
||||
S MDFDA(702,MDRES_",",.09)=3
|
||||
D FILE^DIE("","MDFDA")
|
||||
Q 1
|
||||
;
|
||||
TIUDEL(MDNOTE) ; [Procedure] TIU Note deletion Update
|
||||
; Input parameters
|
||||
; 1. MDNOTE [Literal/Required] TIU IEN
|
||||
;
|
||||
N MDRES,MDFDA,RESULTS
|
||||
S MDRES="" F S MDRES=$O(^MDD(702,"ATIU",MDNOTE,MDRES)) Q:'MDRES D
|
||||
.Q:$G(^MDD(702,+MDRES,0))=""
|
||||
.S MDFDA(702,MDRES_",",.05)=""
|
||||
.S MDFDA(702,MDRES_",",.06)=""
|
||||
.D FILE^DIE("","MDFDA")
|
||||
.D STATUS^MDRPCOT(MDRES_",",2,"TIU note deleted.")
|
||||
.S DATA("TRANSACTION")=MDRES,DATA("PKG")="TIU"
|
||||
.S DATA("MESSAGE")="TIU note deleted." D RPC^MDRPCOT(.RESULTS,"ADDMSG",.DATA)
|
||||
Q 1
|
||||
;
|
||||
TIUREAS(MDFN,MDOLDC,MDANOTE,MDNDFN,MDNEWC,MDNEWV,MDNTIU) ; [Function] This is an API to clean up and update TIU note re-assignment.
|
||||
; Input parameters
|
||||
; 1. MDFN [Literal/Required] The Patient DFN whose TIU document is being re-assigned.
|
||||
; 2. MDOLDC [Literal/Required] The Consult that the note is being re-assigned from.
|
||||
; 3. MDANOTE [Literal/Required] The TIU Document IEN that is being re-assigned.
|
||||
; 4. MDNDFN [Literal/Required] The Patient DFN who will be re-assigned the TIU document.
|
||||
; 5. MDNEWC [Literal/Required] The consult number that will be assignment the TIU document.
|
||||
; 6. MDNEWV [Literal/Required] The new visit for the TIU document assignment.
|
||||
; 7. MDNTIU [Literal/Required] The new reassigned TIU document IEN.
|
||||
;
|
||||
N MDD,MDTRAN,MDCHK,MDLP,MDPPR,MDREAS,MDTRANI,MDX
|
||||
I '$G(MDFN) Q "0^No DFN for the TIU note re-assignment."
|
||||
I '$G(MDOLDC) Q "0^No Old Consult # for the note re-assignment."
|
||||
I '$G(MDANOTE) Q "0^No TIU Note IEN."
|
||||
I '$G(MDNDFN) Q "0^No New DFN for the note assignment."
|
||||
I '$G(MDNEWC) Q "0^No New Consult # for the note assignment."
|
||||
I '$G(MDNTIU) Q "0^No New Reassigned TIU IEN."
|
||||
S (MDD,MDCHK,MDREAS,MDTRAN)="",MDPPR=0 K ^TMP("MDTMP",$J)
|
||||
F S MDTRAN=$O(^MDD(702,"ACON",MDOLDC,MDTRAN)) Q:'MDTRAN D
|
||||
.S MDCHK=$G(^MDD(702,MDTRAN,0)),MDTRANI=MDTRAN_","
|
||||
.I $P(MDCHK,U,5)=MDOLDC&($P(MDCHK,U,6)=MDANOTE) D
|
||||
..S:'MDPPR MDPPR=$P(MDCHK,U,4)
|
||||
..N DA,DIK S DA=+MDTRAN,DIK="^MDD(702," D ^DIK
|
||||
I 'MDPPR D
|
||||
.D CPLIST^GMRCCP(MDNDFN,,$NA(^TMP("MDTMP",$J)))
|
||||
.S MDX=""
|
||||
.F S MDX=$O(^TMP("MDTMP",$J,MDX)) Q:'MDX S:$P(^(MDX),U,5)=MDNEWC MDPPR=$P(^(MDX),U,6)
|
||||
K ^TMP("MDTMP",$J)
|
||||
I 'MDPPR Q 1
|
||||
D NOW^%DTC S MDD=%
|
||||
S MDREAS=$P(MDNEWV,";",3)_";"_$P(MDNEWV,";",2)_";"_$P(MDNEWV,";")
|
||||
S MDNEWV=$$GETVSTR^MDRPCOT1(MDNDFN,MDREAS,MDPPR,MDD)
|
||||
S MDFDA(702,"+1,",.01)=MDNDFN
|
||||
S MDFDA(702,"+1,",.02)=MDD
|
||||
S MDFDA(702,"+1,",.03)=DUZ
|
||||
S MDFDA(702,"+1,",.04)=MDPPR
|
||||
S MDFDA(702,"+1,",.05)=MDNEWC
|
||||
S MDFDA(702,"+1,",.06)=MDNTIU
|
||||
S MDFDA(702,"+1,",.07)=$P(MDNEWV,";",3)_";"_$P(MDNEWV,";",2)_";"_$P(MDNEWV,";")
|
||||
S MDFDA(702,"+1,",.09)=0
|
||||
D UPDATE^DIE("","MDFDA","MDTRANI") Q:'$G(MDTRANI(1)) 1
|
||||
Q 1
|
||||
;
|
||||
TRANS(STR) ; [Function] Translate the upper arrows to blanks
|
||||
; Input parameters
|
||||
; 1. STR [Literal/Required] Input: Text with upper arrows that needs to be removed
|
||||
;
|
||||
I STR["^" Q $TR(STR,"^"," ")
|
||||
Q STR
|
||||
;
|
||||
|
|
|
|||
|
|
@ -1,182 +1,167 @@
|
|||
MDHL7A ; HOIFO/WAA - Routine to Decode HL7 for CP ;9/17/07 08:17
|
||||
;;1.0;CLINICAL PROCEDURES;**6**;Apr 01, 2004;Build 102
|
||||
; Reference DBIA #10035 [Supported] for DPT calls.
|
||||
; Reference DBIA #10106 [Supported] for HLFNC calls.
|
||||
; Reference DBIA #10062 [Supported] for VADPT6 calls.
|
||||
; Reference DBIA #2701 [Supported] for MPIF001 calls
|
||||
; Reference DBIA #10096 [Supported] for ^%ZOSF calls
|
||||
EN ; [Procedure] Entry Point for Message Array in MSG
|
||||
N %,BID,CODE,CPT,DA,DATE,DFN,DIK,DLCO,DTO,DZ,ERRTX,EXAM,EXE,MDFLAG,FIL
|
||||
N I,ICNT,ID,IMP,J,K,LBL,LINO,LINE,LN,MDAPP,MDRTN,MG,MSG,N,NAM,NEXT,NUM
|
||||
N ORIFN,P,PID,PIEN,S,SEG,SET,SEP,MDSSN,STR,STYP,SUB,TCNT,TXT,UNIQ,SEC
|
||||
N UNITS,VA,VAL,X,XMBODY,XMDUZ,XMSUBJ,XMTO,Z,ZZ,Z1,Z2,MDERROR
|
||||
N ECODE,MDIEN,MDOBX,NUMZ,PNAM,ZCODE,MDDEV,MDD702,DEVNAME,DEVIEN,MDQFLG
|
||||
N MDIORD
|
||||
K ^TMP($J,"MDHL7A"),^TMP($J,"MDHL7"),^TMP($J,"MDHL7A1")
|
||||
S MDFLAG=0,MDERROR=0,MDQFLG=0
|
||||
Q:$G(HLMTIENS)=""
|
||||
S ^TMP($J,"MDHL7A1")=""
|
||||
S HLREST="^TMP($J,""MDHL7A1"")"
|
||||
S X=$$MSGIEN^MDHL7U3(HLMTIENS,HLREST) ; This code is to convert the HL7 Message **6**
|
||||
I $P(X,U)=0 D Q
|
||||
. S DEVIEN=0,ECODE=0
|
||||
. S ERRTX=$P(X,U,2)
|
||||
. D ^MDHL7X
|
||||
. Q
|
||||
I $P(X,U)=1 D XVERT^MDHL7U3("MDHL7A1","MDHL7A")
|
||||
K HLNODE,^TMP($J,"MDHL7A1")
|
||||
;
|
||||
EN2 ; [Procedure] No Description
|
||||
S (DEVIEN,DEVNAME)="",I=0
|
||||
F I=1:1 S X=$G(^TMP($J,"MDHL7A",I)) Q:X="" Q:$E(X,1,3)="OBX" D
|
||||
. S:$E(X,1,3)="MSH" DEVNAME=$P(X,"|",4)
|
||||
. I DEVNAME="",HLREC("SFN")'="" S DEVNAME=HLREC("SFN")
|
||||
. I $E(X,1,3)="MSH",DEVNAME'="Instrument Manager" S DEVIEN=$O(^MDS(702.09,"B",DEVNAME,0))
|
||||
. I $E(X,1,3)="OBR" D
|
||||
.. I DEVNAME="Instrument Manager" D
|
||||
... S DEVNAME=$P(X,"|",25)
|
||||
... Q
|
||||
.. S MDIORD=$P(X,"|",4)
|
||||
.. S MDD702=$S(+MDIORD<1:"",1:$$GETSTDY^MDRPCOT1(MDIORD))
|
||||
.. I MDD702<1 S MDD702="" Q
|
||||
.. I MDD702>0 D ;Validate the entry from 702 is good.
|
||||
... I $G(^MDD(702,MDD702,0))="" S MDD702="" Q
|
||||
... S DEVIEN=$$GET1^DIQ(702,MDD702,.11,"I")
|
||||
... I DEVIEN<1 S DEVIEN="" ; No device defined
|
||||
... Q
|
||||
.. Q
|
||||
. Q
|
||||
I DEVIEN="",DEVNAME'="" S DEVIEN=$O(^MDS(702.09,"B",DEVNAME,0))
|
||||
I DEVNAME="" S ERRTX="Invalid device Code" D ^MDHL7X Q
|
||||
I DEVIEN="" S ERRTX="Invalid device entry" D ^MDHL7X Q
|
||||
S ZCODE=$P($G(^MDS(702.09,DEVIEN,.1)),"^",2)
|
||||
S ECODE=0,INST=DEVIEN,MDAPP=DEVNAME
|
||||
I 'INST S ERRTX="Invalid Application Code" D ^MDHL7X Q
|
||||
D INST^MDHL7U2(DEVIEN,.ECODE) I 'ECODE D Q
|
||||
. S ERRTX="Device Error" D ^MDHL7X
|
||||
. Q
|
||||
I (ZCODE="M")!(ZCODE="B") D Q:MDERROR Q:ZCODE="M" ;
|
||||
. S MDFLAG=1,MDERROR=0 ; Tell Medicine that CP is talking to HL7
|
||||
. D ^MDHL7MCA ; Run the Medicine routines
|
||||
. Q:MDERROR ; Medicine found an error and sent an error back
|
||||
. Q
|
||||
S NUMZ=$O(^TMP($J,"MDHL7A",""),-1)
|
||||
S NUM=0,MDOBX=0
|
||||
F NUM=1:1:NUMZ D Q:$G(ERRTX)'=""
|
||||
. S LINO=^TMP($J,"MDHL7A",NUM)
|
||||
. S SEC=$P(LINO,"|")
|
||||
. I SEC="MSH" D MSH Q
|
||||
. I SEC="PID" D PID Q
|
||||
. I SEC="OBR" D OBR Q
|
||||
. I SEC="PV1" Q
|
||||
. I SEC="ORC" Q
|
||||
. I SEC="OBX" S MDOBX=1 Q
|
||||
. Q
|
||||
Q:$G(ERRTX)'=""
|
||||
I 'MDOBX S ERRTX="OBX not found when expected" D ^MDHL7X Q
|
||||
D OBX
|
||||
D STATUS(MDIEN,"P")
|
||||
K ^TMP($J,"MDHL7A"),^TMP($J,"MDHL7")
|
||||
Q
|
||||
STATUS(DA,STAT) ; Update the status of the report in 703.1
|
||||
Q:$G(ERRTX)'=""
|
||||
S $P(^MDD(703.1,DA,0),U,9)=STAT
|
||||
S DIK="^MDD(703.1," D IX1^DIK
|
||||
Q
|
||||
IM ;Instrument Manager Interface
|
||||
Q:DEVNAME'="Instrument Manager"
|
||||
I $E(X,1,3)'="OBR" Q
|
||||
S DEVNAME=$P(X,"|",25)
|
||||
S DEVIEN=$O(^MDS(702.09,"B",DEVNAME,0))
|
||||
Q
|
||||
;
|
||||
MSH ; [Procedure] Decode MSH
|
||||
N SEG
|
||||
I '$D(^TMP($J,"MDHL7A",NUM)) Q
|
||||
S X=$G(^TMP($J,"MDHL7A",NUM)),SEG("MSH")=X
|
||||
I $E(X,1,3)'="MSH" S ERRTX="MSH not first record" D ^MDHL7X Q
|
||||
Q
|
||||
;
|
||||
OBR ; [Procedure] Check OBR
|
||||
N MDGMRC
|
||||
S X=$G(^TMP($J,"MDHL7A",NUM)) I $E(X,1,3)'="OBR" S ERRTX="OBR not found when expected" D ^MDHL7X Q
|
||||
S SEG("OBR")=X
|
||||
S MDIORD=$P(X,"|",4)
|
||||
S MDD702=$S(+MDIORD<1:"",1:$$GETSTDY^MDRPCOT1(MDIORD))
|
||||
;I MDD702'="" S MDD702=$$CHK^MDNCHK(MDD702) ; PATCH 11
|
||||
S ORIFN=$P(X,"|",3),(EXAM,%)=$P(X,"|",5) I EXAM'="" S EXAM=$P(%,"^",2) I EXAM="" S EXAM=$P(%,"^",1)
|
||||
S CPT=$P(X,"|",5) I $P(CPT,"^",3)["CPT" S CPT=$P(CPT,"^",1)
|
||||
S DTO="",DATE=$P(X,"|",8) I DATE'="" S:$L(DATE)>14 DATE=$E(DATE,1,14) S DTO=$$FMDATE^HLFNC(DATE)
|
||||
; vvv== Added to address the issues of mismatch
|
||||
I $G(MDD702)>0 I DFN'=$$GET1^DIQ(702,MDD702,.01,"I") S ERRTX="Patient name Mismatch. Name in PID doesn't match the name in the CP Order #"_MDD702_"." D ^MDHL7X Q
|
||||
I $G(MDD702)>0 I MDDOB'=$$GET1^DIQ(2,DFN,.03,"I") S ERRTX="Patient DOB Mismatch. DOB in PID doesn't match the DOB in the CP Order #"_MDD702_"." D ^MDHL7X Q
|
||||
I DTO="" S ERRTX="Missing required Date/Time of Procedure in OBR" D ^MDHL7X Q
|
||||
;;S UNIQ=$TR($H,",","-")
|
||||
S UNIQ=$$NEWID(DFN,DATE,INST,$G(MDD702),HLMTIEN)
|
||||
I +UNIQ="-1" S ERRTX="Unable to Create or Lock 703.1" D ^MDHL7X Q
|
||||
S MDIEN=$P(UNIQ,"^",1) ; Got the IEN for 703.1
|
||||
N SET S SET=DTO_"^"_$P(UNIQ,U,2),ICNT=0 N IMP
|
||||
S MDRTN=$P($G(^MDS(702.09,INST,.1)),"^",1) S:MDRTN'["^" MDRTN="^"_MDRTN
|
||||
S X=MDRTN S:X["^" X=$P(X,"^",2) X ^%ZOSF("TEST") I '$T S ERRTX="Processing routine not found" D ^MDHL7X Q ; IA %10096
|
||||
D CPTICD^MDHL7U3(X,MDIEN) ; Update CPT and ICD9
|
||||
D PHY^MDHL7U3(X,MDIEN) ; Get Doc who did the procedure.
|
||||
Q
|
||||
;
|
||||
PID ; [Procedure] Check PID
|
||||
S X=$G(^TMP($J,"MDHL7A",NUM)) I $E(X,1,3)'="PID" S ERRTX="PID not second record" D ^MDHL7X Q
|
||||
S SEG("PID")=X
|
||||
S MDDOB=$P(X,"|",8) I MDDOB'="" S MDDOB=($E(MDDOB,1,4)-1700)_$E(MDDOB,5,8)
|
||||
I $L($P(X,"|",4))'<16 D I +DFN=-1 Q
|
||||
. N ICN
|
||||
. S ICN=$P(X,"|",4)
|
||||
. S DFN=$$GETDFN^MPIF001(ICN)
|
||||
. I +DFN=-1 S ERRTX=$P(DFN,U,2)
|
||||
. D MDSSN I DFN<1 S ERRTX="SSN not found" D ^MDHL7X Q
|
||||
. I DFN>0 K ERRTX
|
||||
. S MDSSN=$$GET1^DIQ(2,DFN,.09,"I") I MDSSN="" S MDSSN=" ",DFN=0
|
||||
. Q
|
||||
E D MDSSN
|
||||
I 'DFN S ERRTX="SSN not found" D ^MDHL7X Q
|
||||
S Z1=$P($G(^DPT(DFN,0)),",",1),Z2=$P(NAM,"^",1)
|
||||
S Z1=$TR(Z1,"abcdefghijklmnopqrstuvwxyz- '","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
|
||||
S Z2=$TR(Z2,"abcdefghijklmnopqrstuvwxyz- '","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
|
||||
I $E(Z1,1,3)'=$E(Z2,1,3) S ERRTX="Last Name MisMatch" D ^MDHL7X Q
|
||||
S PNAM=$TR(NAM,"^",",")
|
||||
D PID^VADPT6 S PID=$G(VA("PID")),BID=$G(VA("BID")) N VA
|
||||
Q
|
||||
MDSSN ; This subroutine is to match up the SSN for a patient.
|
||||
S NAM=$P(X,"|",6),MDSSN=$P(X,"|",20) I $L(MDSSN)<9 S MDSSN=$P(X,"|",4)
|
||||
S MDSSN=$P(MDSSN,"^",1) I MDSSN'?9N S MDSSN=$TR(MDSSN,"- ","")
|
||||
I $E(MDSSN,$L(MDSSN))="P" S MDSSN=$E(MDSSN,1,9)
|
||||
S:MDSSN'?9N MDSSN=" " S DFN=$O(^DPT("SSN",MDSSN,0))
|
||||
I 'DFN S DFN=$O(^DPT("SSN",MDSSN_"P",0))
|
||||
Q
|
||||
;
|
||||
OBX ; [Observation]
|
||||
D @MDRTN
|
||||
Q
|
||||
NEWID(DFN,DATE,INST,MDD702,HLMTIEN) ; Generate a new entry and ID of 703.1
|
||||
N NEWID,MDFDA,MDIEN,MDNO
|
||||
S NEWID=$TR($H,",","-") ; Create inital ID
|
||||
L +(^MDD(703.1,"B")):60 E Q "-1"
|
||||
;^^--- Unable to get a lock in the file
|
||||
F Q:'$D(^MDD(703.1,"B",NEWID)) H 1 S NEWID=$TR($H,",","-")
|
||||
;^^--- Search to create a new ID if current ID is in use
|
||||
S MDFDA(703.1,"+1,",.01)=NEWID
|
||||
S MDFDA(703.1,"+1,",.02)=DFN
|
||||
S MDFDA(703.1,"+1,",.03)=$$HL7TFM^MDHL7U(DATE)
|
||||
S MDFDA(703.1,"+1,",.04)=INST
|
||||
S MDFDA(703.1,"+1,",.05)=MDD702
|
||||
S MDFDA(703.1,"+1,",.06)=HLMTIEN
|
||||
D UPDATE^DIE("","MDFDA","MDIEN")
|
||||
L -(^MDD(703.1,"B"))
|
||||
I $G(MDIEN(1))>0 D Q MDIEN(1)_U_NEWID
|
||||
. S ^MDD(703.1,MDIEN(1),.1,0)="^703.11S^0^0"
|
||||
. S MDNO=$$NTIU^MDRPCW1(+MDD702)
|
||||
. Q
|
||||
; ^^--- Create Subfile and quit
|
||||
Q "-1" ; Unable to create file
|
||||
;
|
||||
PROC ; [Procedure] Create report entry in file (703.1)
|
||||
D PROC^MDHL7U
|
||||
Q
|
||||
MDHL7A ; HOIFO/WAA - Routine to Decode HL7 for CP ; [05-07-2001 10:38]
|
||||
;;1.0;CLINICAL PROCEDURES;;Apr 01, 2004
|
||||
; Reference DBIA #10035 [Supported] for DPT calls.
|
||||
; Reference DBIA #10106 [Supported] for HLFNC calls.
|
||||
; Reference DBIA #10062 [Supported] for VADPT6 calls.
|
||||
; Reference DBIA #2701 [Supported] for MPIF001 Calls
|
||||
EN ; [Procedure] Entry Point for Message Array in MSG
|
||||
N %,BID,CODE,CPT,DA,DATE,DFN,DIK,DLCO,DTO,DZ,ERRTX,EXAM,EXE,MDFLAG,FIL
|
||||
N I,ICNT,ID,IMP,J,K,LBL,LINO,LINE,LN,MDAPP,MDRTN,MG,MSG,N,NAM,NEXT,NUM
|
||||
N ORIFN,P,PID,PIEN,S,SEG,SET,SEP,MDSSN,STR,STYP,SUB,TCNT,TXT,UNIQ,SEC
|
||||
N UNITS,VA,VAL,X,XMBODY,XMDUZ,XMSUBJ,XMTO,Z,ZZ,Z1,Z2,MDERROR
|
||||
N ECODE,MDIEN,MDOBX,NUMZ,PNAM,ZCODE,MDDEV,MDD702,DEVNAME,DEVIEN,MDQFLG
|
||||
N MDIORD
|
||||
K ^TMP($J,"MDHL7A"),^TMP($J,"MDHL7")
|
||||
S MDFLAG=0,MDERROR=0,MDQFLG=0
|
||||
F I=1:1 X HLNEXT Q:MDQFLG S ^TMP($J,"MDHL7A",I)=$TR(HLNODE,$C(10),""),J=0 S:HLQUIT<1 MDQFLG=1 F S J=$O(HLNODE(J)) Q:J<1 S ^TMP($J,"MDHL7A",I,J)=$TR(HLNODE(J),$C(10),"")
|
||||
K HLNODE
|
||||
;
|
||||
EN2 ; [Procedure] No Description
|
||||
S (DEVIEN,DEVNAME)=""
|
||||
F I=1:1 S X=$G(^TMP($J,"MDHL7A",I)) Q:X="" Q:$E(X,1,3)="OBX" D
|
||||
. S:$E(X,1,3)="MSH" DEVNAME=$P(X,"|",4)
|
||||
. I $E(X,1,3)="MSH",DEVNAME'="Instrument Manager" S DEVIEN=$O(^MDS(702.09,"B",DEVNAME,0))
|
||||
. I $E(X,1,3)="OBR" D
|
||||
.. I DEVNAME="Instrument Manager" D
|
||||
... S DEVNAME=$P(X,"|",25)
|
||||
... Q
|
||||
.. S MDIORD=$P(X,"|",4)
|
||||
.. S MDD702=$S(+MDIORD<1:"",1:$$GETSTDY^MDRPCOT1(MDIORD))
|
||||
.. I MDD702<1 S MDD702="" Q
|
||||
.. I MDD702>0 D ;Validate the entry from 702 is good.
|
||||
... I $G(^MDD(702,MDD702,0))="" S MDD702="" Q
|
||||
... S DEVIEN=$$GET1^DIQ(702,MDD702,.11,"I")
|
||||
... I DEVIEN<1 S DEVIEN="" ; No device defined
|
||||
... Q
|
||||
.. Q
|
||||
. Q
|
||||
I DEVIEN="",DEVNAME'="" S DEVIEN=$O(^MDS(702.09,"B",DEVNAME,0))
|
||||
I DEVNAME="" S ERRTX="Invalid device Code" D ^MDHL7X Q
|
||||
I DEVIEN="" S ERRTX="Invalid device entry" D ^MDHL7X Q
|
||||
S ZCODE=$P($G(^MDS(702.09,DEVIEN,.1)),"^",2)
|
||||
S ECODE=0,INST=DEVIEN,MDAPP=DEVNAME
|
||||
I 'INST S ERRTX="Invalid Application Code" D ^MDHL7X Q
|
||||
D INST^MDHL7U2(DEVIEN,.ECODE) I 'ECODE D Q
|
||||
. S ERRTX="Device Error" D ^MDHL7X
|
||||
. Q
|
||||
I (ZCODE="M")!(ZCODE="B") D Q:MDERROR Q:ZCODE="M" ;
|
||||
. S MDFLAG=1,MDERROR=0 ; Tell Medicine that CP is talking to HL7
|
||||
. ;S MSG(1)=^TMP($J,"MDHL7A",1)
|
||||
. ;S MSG(2)=^TMP($J,"MDHL7A",2)
|
||||
. D ^MDHL7MCA ; Run the Medicine routines
|
||||
. Q:MDERROR ; Medicine found an error and sent an error back
|
||||
. ;;I ZCODE="M" D GENACK^MDHL7X
|
||||
. Q
|
||||
S NUMZ=$O(^TMP($J,"MDHL7A",""),-1)
|
||||
S NUM=0,MDOBX=0
|
||||
F NUM=1:1:NUMZ D Q:$G(ERRTX)'=""
|
||||
. S LINO=^TMP($J,"MDHL7A",NUM)
|
||||
. S SEC=$P(LINO,"|")
|
||||
. I SEC="MSH" D MSH Q
|
||||
. I SEC="PID" D PID Q
|
||||
. I SEC="OBR" D OBR Q
|
||||
. I SEC="PV1" Q
|
||||
. I SEC="ORC" Q
|
||||
. I SEC="OBX" S MDOBX=1 Q
|
||||
. Q
|
||||
Q:$G(ERRTX)'=""
|
||||
I 'MDOBX S ERRTX="OBX not found when expected" D ^MDHL7X Q
|
||||
D OBX
|
||||
D STATUS(MDIEN,"P")
|
||||
K ^TMP($J,"MDHL7A"),^TMP($J,"MDHL7")
|
||||
Q
|
||||
STATUS(DA,STAT) ; Update the status of the report in 703.1
|
||||
Q:$G(ERRTX)'=""
|
||||
S $P(^MDD(703.1,DA,0),U,9)=STAT
|
||||
S DIK="^MDD(703.1," D IX1^DIK
|
||||
Q
|
||||
IM ;Instrument Manager Interface
|
||||
Q:DEVNAME'="Instrument Manager"
|
||||
I $E(X,1,3)'="OBR" Q
|
||||
S DEVNAME=$P(X,"|",25)
|
||||
S DEVIEN=$O(^MDS(702.09,"B",DEVNAME,0))
|
||||
Q
|
||||
;
|
||||
MSH ; [Procedure] Decode MSH
|
||||
N SEG
|
||||
I '$D(^TMP($J,"MDHL7A",NUM)) Q
|
||||
S X=$G(^TMP($J,"MDHL7A",NUM)),SEG("MSH")=X
|
||||
I $E(X,1,3)'="MSH" S ERRTX="MSH not first record" D ^MDHL7X Q
|
||||
Q
|
||||
;
|
||||
OBR ; [Procedure] Check OBR
|
||||
N MDGMRC
|
||||
S X=$G(^TMP($J,"MDHL7A",NUM)) I $E(X,1,3)'="OBR" S ERRTX="OBR not found when expected" D ^MDHL7X Q
|
||||
S SEG("OBR")=X
|
||||
S MDIORD=$P(X,"|",4)
|
||||
S MDD702=$S(+MDIORD<1:"",1:$$GETSTDY^MDRPCOT1(MDIORD))
|
||||
S ORIFN=$P(X,"|",3),(EXAM,%)=$P(X,"|",5) I EXAM'="" S EXAM=$P(%,"^",2) I EXAM="" S EXAM=$P(%,"^",1)
|
||||
S CPT=$P(X,"|",5) I $P(CPT,"^",3)["CPT" S CPT=$P(CPT,"^",1)
|
||||
S DTO="",DATE=$P(X,"|",8) I DATE'="" S:$L(DATE)>14 DATE=$E(DATE,1,14) S DTO=$$FMDATE^HLFNC(DATE)
|
||||
; vvv== Added to address the issues of mismatch
|
||||
I $G(MDD702)>0 I DFN'=$$GET1^DIQ(702,MDD702,.01,"I") S ERRTX="Patient name Mismatch. Name in PID doesn't match the name in the CP Order #"_MDD702_"." D ^MDHL7X Q
|
||||
I DTO="" S ERRTX="Missing required Date/Time of Procedure in OBR" D ^MDHL7X Q
|
||||
;;S UNIQ=$TR($H,",","-")
|
||||
S UNIQ=$$NEWID(DFN,DATE,INST,$G(MDD702),HLMTIEN)
|
||||
I +UNIQ="-1" S ERRTX="Unable to Create or Lock 703.1" D ^MDHL7X Q
|
||||
S MDIEN=$P(UNIQ,"^",1) ; Got the IEN for 703.1
|
||||
N SET S SET=DTO_"^"_$P(UNIQ,U,2),ICNT=0 N IMP
|
||||
S MDRTN=$P($G(^MDS(702.09,INST,.1)),"^",1) S:MDRTN'["^" MDRTN="^"_MDRTN
|
||||
S X=MDRTN S:X["^" X=$P(X,"^",2) X ^%ZOSF("TEST") I '$T S ERRTX="Processing routine not found" D ^MDHL7X Q ; IA %10096
|
||||
Q
|
||||
;
|
||||
PID ; [Procedure] Check PID
|
||||
S X=$G(^TMP($J,"MDHL7A",NUM)) I $E(X,1,3)'="PID" S ERRTX="PID not second record" D ^MDHL7X Q
|
||||
S SEG("PID")=X
|
||||
I $L($P(X,"|",4))'<16 D I +DFN=-1 Q
|
||||
. N ICN
|
||||
. S ICN=$P(X,"|",4)
|
||||
. S DFN=$$GETDFN^MPIF001(ICN)
|
||||
. I +DFN=-1 S ERRTX=$P(DFN,U,2)
|
||||
. D MDSSN I DFN<1 S ERRTX="SSN not found" D ^MDHL7X Q
|
||||
. I DFN>0 K ERRTX
|
||||
. S MDSSN=$$GET1^DIQ(2,DFN,.09,"I") I MDSSN="" S MDSSN=" ",DFN=0
|
||||
. Q
|
||||
E D MDSSN
|
||||
I 'DFN S ERRTX="SSN not found" D ^MDHL7X Q
|
||||
S Z1=$P($G(^DPT(DFN,0)),",",1),Z2=$P(NAM,"^",1)
|
||||
S Z1=$TR(Z1,"abcdefghijklmnopqrstuvwxyz- '","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
|
||||
S Z2=$TR(Z2,"abcdefghijklmnopqrstuvwxyz- '","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
|
||||
I $E(Z1,1,3)'=$E(Z2,1,3) S ERRTX="Last Name MisMatch" D ^MDHL7X Q
|
||||
S PNAM=$TR(NAM,"^",",")
|
||||
D PID^VADPT6 S PID=$G(VA("PID")),BID=$G(VA("BID")) N VA
|
||||
Q
|
||||
MDSSN ; This subroutine is to match up the SSN for a patient.
|
||||
S NAM=$P(X,"|",6),MDSSN=$P(X,"|",20) I $L(MDSSN)<9 S MDSSN=$P(X,"|",4)
|
||||
S MDSSN=$P(MDSSN,"^",1) I MDSSN'?9N S MDSSN=$TR(MDSSN,"- ","")
|
||||
I $E(MDSSN,$L(MDSSN))="P" S MDSSN=$E(MDSSN,1,9)
|
||||
S:MDSSN'?9N MDSSN=" " S DFN=$O(^DPT("SSN",MDSSN,0))
|
||||
I 'DFN S DFN=$O(^DPT("SSN",MDSSN_"P",0))
|
||||
Q
|
||||
;
|
||||
OBX ; [Observation]
|
||||
;Q:$P(^TMP($J,"MDHL7A",NUM),"|")'="OBX"
|
||||
D @MDRTN
|
||||
Q
|
||||
NEWID(DFN,DATE,INST,MDD702,HLMTIEN) ; Generate a new entry and ID of 703.1
|
||||
N NEWID,MDFDA,MDIEN
|
||||
S NEWID=$TR($H,",","-") ; Create inital ID
|
||||
L +(^MDD(703.1,"B")):60 E Q "-1"
|
||||
;^^--- Unable to get an lock in the file
|
||||
F Q:'$D(^MDD(703.1,"B",NEWID)) H 1 S NEWID=$TR($H,",","-")
|
||||
;^^--- Search to create an new ID in current ID is in use
|
||||
S MDFDA(703.1,"+1,",.01)=NEWID
|
||||
S MDFDA(703.1,"+1,",.02)=DFN
|
||||
S MDFDA(703.1,"+1,",.03)=$$HL7TFM^MDHL7U(DATE)
|
||||
S MDFDA(703.1,"+1,",.04)=INST
|
||||
S MDFDA(703.1,"+1,",.05)=MDD702
|
||||
S MDFDA(703.1,"+1,",.06)=HLMTIEN
|
||||
D UPDATE^DIE("","MDFDA","MDIEN")
|
||||
L -(^MDD(703.1,"B"))
|
||||
I $G(MDIEN(1))>0 S ^MDD(703.1,MDIEN(1),.1,0)="^703.11S^0^0" Q MDIEN(1)_U_NEWID
|
||||
; ^^--- Create Subfile and quit
|
||||
Q "-1" ; Unable to create file
|
||||
;
|
||||
PROC ; [Procedure] Create report entry in file (703.1)
|
||||
D PROC^MDHL7U
|
||||
Q
|
||||
|
|
|
|||
|
|
@ -1,66 +1,66 @@
|
|||
MDHL7MCA ; HOIFO/REL-Routine to Decode HL7 for MEDICINE ; [05-07-2001 10:38]
|
||||
;;1.0;CLINICAL PROCEDURES;**6**;Apr 01, 2004;Build 102
|
||||
; Reference DBIA #10035 for DPT calls.
|
||||
; Reference DBIA #10062 for VADPT calls.
|
||||
; Reference DBIA #10106 for HL7 calls.
|
||||
; Reference DBIA #10096 for ^%ZOSF calls.
|
||||
EN ; Entry Point for Message Array in MSG
|
||||
N MSG
|
||||
K ERRTX
|
||||
S MDERROR=0
|
||||
;F I=3:1 X HLNEXT Q:HLQUIT'>0 S MSG(I)=HLNODE,J=0 F S J=$O(HLNODE(J)) Q:'J S MSG(I,J)=HLNODE(J)
|
||||
M MSG=^TMP($J,"MDHL7A")
|
||||
S NUM=1
|
||||
MSH ; Decode MSH
|
||||
K SEG
|
||||
I '$D(MSG(NUM)) G KIL
|
||||
S X=$G(MSG(NUM)),SEG("MSH")=X,MCAPP=""
|
||||
I $E(X,1,3)'="MSH" S ERRTX="MSH not first record" D ^MDHL7MCX G KIL
|
||||
S MCAPP=$P(MSG(NUM),"|",4) I MCAPP="" G KIL
|
||||
S NUM=NUM+1
|
||||
PID ; Check PID
|
||||
S X=$G(MSG(NUM)) I $E(X,1,3)'="PID" S ERRTX="PID not second record" D ^MDHL7MCX G KIL
|
||||
S SEG("PID")=X
|
||||
S NAM=$P(X,"|",6),MDSSN=$P(X,"|",20) I $L(MDSSN)<9 S MDSSN=$P(X,"|",4)
|
||||
S MDSSN=$P(MDSSN,"^",1) I MDSSN'?9N S MDSSN=$TR(MDSSN,"- ","")
|
||||
S:MDSSN'?9N MDSSN=" " S DFN=$O(^DPT("SSN",MDSSN,0))
|
||||
I 'DFN S ERRTX="SSN not found" D ^MDHL7MCX G KIL
|
||||
S Z1=$P($G(^DPT(DFN,0)),",",1),Z2=$P(NAM,"^",1)
|
||||
S Z1=$TR(Z1,"abcdefghijklmnopqrstuvwxyz- '","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
|
||||
S Z2=$TR(Z2,"abcdefghijklmnopqrstuvwxyz- '","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
|
||||
I $E(Z1,1,3)'=$E(Z2,1,3) S ERRTX="Last Name MisMatch" D ^MDHL7MCX G KIL
|
||||
D PID^VADPT6 S PID=$G(VA("PID")),BID=$G(VA("BID")) K VA
|
||||
; If DFN not a medical patient, add DFN to medical patient file
|
||||
I '$D(^MCAR(690,DFN)) S ^MCAR(690,DFN,0)=DFN,^MCAR(690,"B",DFN,DFN)="",$P(^MCAR(690,0),U,4)=$P(^MCAR(690,0),U,4)+1 S:$P(^MCAR(690,0),U,3)<DFN $P(^MCAR(690,0),U,3)=DFN
|
||||
S NUM=NUM+1
|
||||
; Skip PV1, ORC if necessary
|
||||
LPOBR I $E(MSG(NUM),1,3)'="OBR" S NUM=NUM+1 G LPOBR
|
||||
;I $E(MSG(NUM),1,3)="ORC" S NUM=NUM+1
|
||||
OBR ; Check OBR
|
||||
S X=$G(MSG(NUM)) I $E(X,1,3)'="OBR" S ERRTX="OBR not found when expected" D ^MDHL7MCX G KIL
|
||||
S SEG("OBR")=X
|
||||
S ORIFN=$P(X,"|",3),INST=$P(X,"|",25) I MCAPP="Instrument Manager",INST'="" S MCAPP=INST
|
||||
S ORIFN=$P(X,"|",3),(EXAM,%)=$P(X,"|",5) I EXAM'="" S EXAM=$P(%,"^",2),EXAM2=$P(%,"^",1) I EXAM="" S EXAM=EXAM2
|
||||
S CPT=$P(X,"|",5) I $P(CPT,"^",3)["CPT" S CPT=$P(CPT,"^",1)
|
||||
S DTO="",DATE=$P(X,"|",8) I DATE'="" S:$L(DATE)>14 DATE=$E(DATE,1,14) S DTO=$$FMDATE^HLFNC(DATE)
|
||||
I DTO="" S ERRTX="Missing required Date/Time of Procedure in OBR" D ^MDHL7MCX G KIL
|
||||
K SET S SET=DTO_"^"_DFN,NUM=NUM+1,ICNT=0 K IMP
|
||||
; Go to Application
|
||||
S INST=$O(^MCAR(690.7,"B",MCAPP,0)) I 'INST S X=MCAPP,ERRTX="Invalid Application Code" D ^MDHL7MCX G KIL
|
||||
S MCRTN=$G(^MCAR(690.7,INST,1)) S:MCRTN'["^" MCRTN="^"_MCRTN
|
||||
; test for existence
|
||||
S X=MCRTN S:X["^" X=$P(X,"^",2) X ^%ZOSF("TEST") I '$T S ERRTX="Processing routine not found" D ^MDHL7MCX G KIL
|
||||
D @MCRTN G KIL
|
||||
PROC ; Create Procedure entry in appropriate file (FIL)
|
||||
I $P(SET,"^",1)=""!($P(SET,"^",2)="") Q
|
||||
S DA=0 F S DA=$O(^MCAR(FIL,"B",$P(SET,"^",1),DA)) Q:'DA I $P($G(^MCAR(FIL,DA,0)),"^",1,2)=SET Q
|
||||
Q:DA
|
||||
P1 L +^MCAR(FIL,0):3 G:'$T P1 S DA=$P(^MCAR(FIL,0),"^",3)+1,$P(^MCAR(FIL,0),"^",3,4)=DA_"^"_DA L -^MCAR(FIL,0)
|
||||
I $D(^MCAR(FIL,DA)) G P1
|
||||
S ^MCAR(FIL,DA,0)=SET S DIK="^MCAR("_FIL_"," D IX1^DIK Q
|
||||
KIL ; Kill Variables
|
||||
K %,BID,CODE,CPT,DA,DATE,DFN,DIK,DLCO,DTO,ERRTX,EXAM,EXAM2,EXE,FIL
|
||||
K I,ICNT,ID,IMP,J,K,LBL,LINE,LN,MCAPP,MCRTN,MG,MSG,N,NAM,NEXT,NUM
|
||||
K ORIFN,P,PID,PIEN,S,SEG,SEP,SET,MDSSN,STR,STYP,SUB,TCNT,TXT
|
||||
K UNITS,VA,VAL,X,XMBODY,XMDUZ,XMSUBJ,XMTO,Z1,Z2
|
||||
Q
|
||||
MDHL7MCA ; HIRMFO/REL-Routine to Decode HL7 for MEDICINE ; [05-07-2001 10:38]
|
||||
;;1.0;CLINICAL PROCEDURES;;Apr 01, 2004
|
||||
; Reference DBIA #10035 for DPT calls.
|
||||
; Reference DBIA #10062 for VADPT calls.
|
||||
; Reference DBIA #10106 for HL7 calls.
|
||||
EN ; Entry Point for Message Array in MSG
|
||||
N MSG
|
||||
K ERRTX
|
||||
S MDERROR=0
|
||||
;F I=3:1 X HLNEXT Q:HLQUIT'>0 S MSG(I)=HLNODE,J=0 F S J=$O(HLNODE(J)) Q:'J S MSG(I,J)=HLNODE(J)
|
||||
M MSG=^TMP($J,"MDHL7A")
|
||||
S NUM=1
|
||||
MSH ; Decode MSH
|
||||
K SEG
|
||||
I '$D(MSG(NUM)) G KIL
|
||||
S X=$G(MSG(NUM)),SEG("MSH")=X,MCAPP=""
|
||||
I $E(X,1,3)'="MSH" S ERRTX="MSH not first record" D ^MDHL7MCX G KIL
|
||||
S MCAPP=$P(MSG(NUM),"|",4) I MCAPP="" G KIL
|
||||
S NUM=NUM+1
|
||||
PID ; Check PID
|
||||
S X=$G(MSG(NUM)) I $E(X,1,3)'="PID" S ERRTX="PID not second record" D ^MDHL7MCX G KIL
|
||||
S SEG("PID")=X
|
||||
S NAM=$P(X,"|",6),MDSSN=$P(X,"|",20) I $L(MDSSN)<9 S MDSSN=$P(X,"|",4)
|
||||
S MDSSN=$P(MDSSN,"^",1) I MDSSN'?9N S MDSSN=$TR(MDSSN,"- ","")
|
||||
S:MDSSN'?9N MDSSN=" " S DFN=$O(^DPT("SSN",MDSSN,0))
|
||||
I 'DFN S ERRTX="SSN not found" D ^MDHL7MCX G KIL
|
||||
S Z1=$P($G(^DPT(DFN,0)),",",1),Z2=$P(NAM,"^",1)
|
||||
S Z1=$TR(Z1,"abcdefghijklmnopqrstuvwxyz- '","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
|
||||
S Z2=$TR(Z2,"abcdefghijklmnopqrstuvwxyz- '","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
|
||||
I $E(Z1,1,3)'=$E(Z2,1,3) S ERRTX="Last Name MisMatch" D ^MDHL7MCX G KIL
|
||||
D PID^VADPT6 S PID=$G(VA("PID")),BID=$G(VA("BID")) K VA
|
||||
; If DFN not a medical patient, add DFN to medical patient file
|
||||
I '$D(^MCAR(690,DFN)) S ^MCAR(690,DFN,0)=DFN,^MCAR(690,"B",DFN,DFN)="",$P(^MCAR(690,0),U,4)=$P(^MCAR(690,0),U,4)+1 S:$P(^MCAR(690,0),U,3)<DFN $P(^MCAR(690,0),U,3)=DFN
|
||||
S NUM=NUM+1
|
||||
; Skip PV1, ORC if necessary
|
||||
LPOBR I $E(MSG(NUM),1,3)'="OBR" S NUM=NUM+1 G LPOBR
|
||||
;I $E(MSG(NUM),1,3)="ORC" S NUM=NUM+1
|
||||
OBR ; Check OBR
|
||||
W MSG(NUM)
|
||||
S X=$G(MSG(NUM)) I $E(X,1,3)'="OBR" S ERRTX="OBR not found when expected" D ^MDHL7MCX G KIL
|
||||
S SEG("OBR")=X
|
||||
S ORIFN=$P(X,"|",3),INST=$P(X,"|",25) I MCAPP="Instrument Manager",INST'="" S MCAPP=INST
|
||||
S ORIFN=$P(X,"|",3),(EXAM,%)=$P(X,"|",5) I EXAM'="" S EXAM=$P(%,"^",2),EXAM2=$P(%,"^",1) I EXAM="" S EXAM=EXAM2
|
||||
S CPT=$P(X,"|",5) I $P(CPT,"^",3)["CPT" S CPT=$P(CPT,"^",1)
|
||||
S DTO="",DATE=$P(X,"|",8) I DATE'="" S:$L(DATE)>14 DATE=$E(DATE,1,14) S DTO=$$FMDATE^HLFNC(DATE)
|
||||
I DTO="" S ERRTX="Missing required Date/Time of Procedure in OBR" D ^MDHL7MCX G KIL
|
||||
K SET S SET=DTO_"^"_DFN,NUM=NUM+1,ICNT=0 K IMP
|
||||
; Go to Application
|
||||
S INST=$O(^MCAR(690.7,"B",MCAPP,0)) I 'INST S X=MCAPP,ERRTX="Invalid Application Code" D ^MDHL7MCX G KIL
|
||||
S MCRTN=$G(^MCAR(690.7,INST,1)) S:MCRTN'["^" MCRTN="^"_MCRTN
|
||||
; test for existence
|
||||
S X=MCRTN S:X["^" X=$P(X,"^",2) X ^%ZOSF("TEST") I '$T S ERRTX="Processing routine not found" D ^MDHL7MCX G KIL
|
||||
D @MCRTN G KIL
|
||||
PROC ; Create Procedure entry in appropriate file (FIL)
|
||||
I $P(SET,"^",1)=""!($P(SET,"^",2)="") Q
|
||||
S DA=0 F S DA=$O(^MCAR(FIL,"B",$P(SET,"^",1),DA)) Q:'DA I $P($G(^MCAR(FIL,DA,0)),"^",1,2)=SET Q
|
||||
Q:DA
|
||||
P1 L +^MCAR(FIL,0):3 G:'$T P1 S DA=$P(^MCAR(FIL,0),"^",3)+1,$P(^MCAR(FIL,0),"^",3,4)=DA_"^"_DA L -^MCAR(FIL,0)
|
||||
I $D(^MCAR(FIL,DA)) G P1
|
||||
S ^MCAR(FIL,DA,0)=SET S DIK="^MCAR("_FIL_"," D IX1^DIK Q
|
||||
KIL ; Kill Variables
|
||||
K %,BID,CODE,CPT,DA,DATE,DFN,DIK,DLCO,DTO,ERRTX,EXAM,EXAM2,EXE,FIL
|
||||
K I,ICNT,ID,IMP,J,K,LBL,LINE,LN,MCAPP,MCRTN,MG,MSG,N,NAM,NEXT,NUM
|
||||
K ORIFN,P,PID,PIEN,S,SEG,SEP,SET,MDSSN,STR,STYP,SUB,TCNT,TXT
|
||||
K UNITS,VA,VAL,X,XMBODY,XMDUZ,XMSUBJ,XMTO,Z1,Z2
|
||||
Q
|
||||
|
|
|
|||
|
|
@ -1,212 +1,12 @@
|
|||
MDHL7U3 ; HOIFO/WAA -Utilities for CP to process HL7 messages ; 7/26/00
|
||||
;;1.0;CLINICAL PROCEDURES;**6**;Apr 01, 2004;Build 102
|
||||
; Reference DBIA #2729 [Supported] for XMXPAI
|
||||
; Reference DBIA #4262 [Supported] for HL7 call.
|
||||
; Reference DBIA #3273 [Subscription] for HL7 call.
|
||||
; Reference DBIA #10138 [Supported] for HL7 call.
|
||||
; Reference DBIA #3990 [Supported] for ICDCODE call
|
||||
; Reference DBIA #1131 [Supported] for XMB("NETNAME") reference
|
||||
; Reference DBIA #1995 [Supported] for ICPTCOD to handle CPT Codes call
|
||||
; Reference DBIA #10082 [Supported] for ^ICD9 reference
|
||||
; Reference DBIA #10111 [Supported] for FILE 3.8 call
|
||||
; Reference DBIA #10103 [Supported] for XLFDT call
|
||||
;
|
||||
HL7CHK(MDD702) ; Check to see of there is an entry in 703.1 for a patient.
|
||||
N X
|
||||
S X="1^"
|
||||
D
|
||||
. N Y
|
||||
. I $G(^MDD(702,MDD702,0))="" S X="-1^No Entry in 702." Q
|
||||
. I $D(^MDD(703.1,"ASTUDYID",MDD702))=0 Q
|
||||
. S Y=0
|
||||
. S Y=$O(^MDD(703.1,"ASTUDYID",MDD702,Y)) I Y>0 S X="-1^This Study has Data on file."
|
||||
. Q
|
||||
Q X
|
||||
XVERT(MDA,MDB) ; Strip out blank Lines
|
||||
Q:MDA=""
|
||||
Q:MDB=""
|
||||
Q:$G(^TMP($J,MDA,1))
|
||||
N I,CNT,CNT2,NODE,FLG
|
||||
S (CNT,I,FLG)=0
|
||||
F S I=$O(^TMP($J,MDA,I)) Q:I<1 D
|
||||
. S NODE=$TR(^TMP($J,MDA,I),$C(10),"")
|
||||
. I NODE="" S FLG=0 Q
|
||||
. I FLG D Q
|
||||
. . S CNT2=CNT2+1
|
||||
. . S ^TMP($J,MDB,CNT,CNT2)=NODE
|
||||
. . Q
|
||||
. I 'FLG D Q
|
||||
. . S CNT=CNT+1
|
||||
. . S ^TMP($J,MDB,CNT)=NODE
|
||||
. . S FLG=1,CNT2=0
|
||||
. . Q
|
||||
. Q
|
||||
Q
|
||||
;
|
||||
PURGE(MDD7031) ;
|
||||
; This sub-routine will delete HL7 772 Message text after a message
|
||||
; been processed by Imaging.
|
||||
Q:'$D(^MDD(703.1,MDD7031,0)) ; No entry found
|
||||
S MDD772=$P(^MDD(703.1,MDD7031,0),U,6) Q:MDD772=""
|
||||
D DELBODY^HLUOPT2(MDD772,"CLINICAL PROCEDURES message purge","^TMP($J,""IN"")")
|
||||
S $P(^MDD(703.1,MDD7031,0),U,6)=""
|
||||
Q
|
||||
;
|
||||
PHY(X,MDIEN) ; Add the doc who did the exam to the report
|
||||
Q
|
||||
; This will be implemented with the Doctor Lookup when it comes out.
|
||||
N LINE1,LINE
|
||||
S LINE1=$P(X,"|",17)
|
||||
S LINE=$P(LINE1,"^",2) ; Last
|
||||
S LINE=LINE_$S($P(LINE1,"^",3)'="":", "_$P(LINE1,"^",3),1:"") ; First
|
||||
S LINE=LINE_$S($P(LINE1,"^",4)'="":" "_$P(LINE1,"^",4),1:"") ; MI
|
||||
D ADD(MDIEN,"9",LINE)
|
||||
Q
|
||||
;
|
||||
CPTICD(X,MDIEN) ; Break out CPT and ICD9 codes
|
||||
N ICD,CPT
|
||||
Q:MDIEN<1
|
||||
S CPT=$P(X,"|",45) I CPT'="" D FILECD(MDIEN,CPT,"7")
|
||||
S ICD=$P(X,"|",14) I ICD'="" D FILECD(MDIEN,ICD,"8")
|
||||
Q
|
||||
FILECD(MDIEN,CODE,TYPE) ; fILE THE DATA
|
||||
N LINE,Y,I,CNT,RESULT
|
||||
S CNT=$L(CODE,"~")
|
||||
S LINE=""
|
||||
F I=1:1:CNT S Y=$P(CODE,"~",I),RESULT=$P(Y,"^",1),LINE(.2,I,0)=RESULT
|
||||
S LINE(.2,0)="^^"_CNT_"^"_CNT_"^"_$P(%,".")
|
||||
Q:CNT<1 ; file the results if there is any
|
||||
D ADD(MDIEN,TYPE,.LINE,CNT)
|
||||
Q
|
||||
;
|
||||
ADD(MDIEN,TYPE,LINE,CNT) ;
|
||||
; Create an entry in the .1 node
|
||||
N NODE,X
|
||||
S NODE=$G(^MDD(703.1,MDIEN,.1,0)) Q:NODE=""
|
||||
S NODE=$P(NODE,"^",3)
|
||||
S NODE=NODE+1
|
||||
S $P(^MDD(703.1,MDIEN,.1,0),"^",3,4)=NODE_"^"_NODE
|
||||
S $P(^MDD(703.1,MDIEN,.1,NODE,0),"^")=TYPE
|
||||
D NOW^%DTC
|
||||
M ^MDD(703.1,MDIEN,.1,NODE)=LINE
|
||||
Q
|
||||
;
|
||||
MSGIEN(MDHLIENS,MDHLREST) ; Return the message as definded in MDHLIENS to the array in MDHLREST
|
||||
; Only TCP type messages
|
||||
; input: MDHLIENS= the intern entry number of the message in ^HLMA
|
||||
; MDHLREST = the return array that will contain the whole HL7 message
|
||||
; output: return "1^Message complete" if message was successful, "0^reason" if failed.
|
||||
;
|
||||
N MDHLIEN,MDHLI,MDHLCNT,MDHLZ,RET
|
||||
S (MDHLCNT,MDHLI,RET)=0
|
||||
I $G(MDHLIENS)="" S RET=RET_"^No IEN defined" Q RET ; Exit because no IEN for ^HLMA was provided
|
||||
I $G(MDHLREST)="" S RET=RET_"^No Return ARRAY provided" Q RET ; Exit because no return array was provided
|
||||
I $G(^HLMA(MDHLIENS,0))="" S RET=RET_"^HLMA entry does not exist" Q RET ; Exit because invalid OR non-EXISTING HLMA ENTRY
|
||||
S MDHLIEN=$P(^HLMA(MDHLIENS,0),U)
|
||||
I MDHLIEN="" S RET=RET_"^No pointer value to file 772" Q RET ; No Pointer to 772
|
||||
I $G(^HL(772,MDHLIEN,0))="" S RET=RET_"^772 Entry does not exist" Q RET ; No 772 entry exist
|
||||
;get header
|
||||
S MDHLZ=$G(^HLMA(MDHLIENS,"MSH",1,0))
|
||||
I MDHLZ="" S RET=RET_"^No MSH segment found" Q RET ; No MSH was found
|
||||
S MDHLCNT=MDHLCNT+1,@MDHLREST@(MDHLCNT)=MDHLZ
|
||||
S MDHLCNT=MDHLCNT+1,@MDHLREST@(MDHLCNT)=""
|
||||
;get body
|
||||
S MDHLI=0
|
||||
F S MDHLI=$O(^HL(772,MDHLIEN,"IN",MDHLI)) Q:'MDHLI D
|
||||
. S MDHLCNT=MDHLCNT+1
|
||||
. S @MDHLREST@(MDHLCNT)=$G(^HL(772,MDHLIEN,"IN",MDHLI,0))
|
||||
. Q
|
||||
I MDHLCNT'>2 S RET=RET_"^No message body found" Q RET ; There was no body
|
||||
S RET="1^Message complete"
|
||||
Q RET
|
||||
;
|
||||
CICNV(MDIEN,RETURN) ; This subroutine will read the data in 703.1 and return the results
|
||||
;in the indicated global
|
||||
N NODE,FLG
|
||||
S FLG=1
|
||||
Q:MDIEN="" ; The ien was null
|
||||
Q:RETURN="" ; the array was null
|
||||
S ARRAY(0)="0^0"
|
||||
I $G(^MDD(703.1,MDIEN,.1,0))="" S FLG=0 Q ; There is not data.
|
||||
; Start the processing of ICD/POV codes Value is 8
|
||||
S NODE=0
|
||||
I FLG I $G(^MDD(703.1,MDIEN,.1,0))'="" D
|
||||
. F S NODE=$O(^MDD(703.1,MDIEN,.1,NODE)) Q:NODE<1 D
|
||||
. . S TYPE=$P($G(^MDD(703.1,MDIEN,.1,NODE,0),0),"^",1)
|
||||
. . I TYPE=8 D PROCESS(MDIEN,NODE,TYPE,.ARRAY)
|
||||
. . I TYPE=7 D PROCESS(MDIEN,NODE,TYPE,.ARRAY)
|
||||
. . Q
|
||||
. Q
|
||||
M @RETURN=ARRAY
|
||||
Q
|
||||
PROCESS(MDIEN,NODE,TYPE,ARRAY) ; This will process the data for each
|
||||
N CNT,X,CONT,CODE,AR,TP,LOC
|
||||
S CNT=0,CONT=0
|
||||
F S CNT=$O(^MDD(703.1,MDIEN,.1,NODE,.2,CNT)) Q:CNT<1 D
|
||||
. S CODE=$G(^MDD(703.1,MDIEN,.1,NODE,.2,CNT,0),"") ; Grabbing the ICD9 AND CPT codes
|
||||
. I CODE="" Q
|
||||
. I TYPE=8 S AR=1,TP="POV",X=$$ICDDX^ICDCODE(CODE) Q:X="" ; Reference DBIA #3990 [Supported] for ICDCODE call
|
||||
. I TYPE=7 S AR=2,TP="CPT",X=$$CPT^ICPTCOD(CODE) Q:X="" ; Reference DBIA #1995 [Supported] for ICPTCOD to handle CPT Codes call
|
||||
. S CONT=CONT+1
|
||||
. S ARRAY(AR)=CONT_"^"_CONT
|
||||
. I AR=1 D
|
||||
. . N DESC,IN,LN
|
||||
. . S IN=$P(X,"^",1) Q:IN<1
|
||||
. . S LN=$G(^ICD9(IN,0),0) Q:LN=""
|
||||
. . S DESC=$P(LN,"^",3) Q:DESC=""
|
||||
. . S I=CONT
|
||||
. . S $P(ARRAY(AR,I),"^",1)=TP
|
||||
. . S $P(ARRAY(AR,I),"^",2)=$P(X,"^",1)
|
||||
. . S $P(ARRAY(AR,I),"^",3)=$P(X,"^",2)
|
||||
. . S $P(ARRAY(AR,I),"^",5)=DESC
|
||||
. . S $P(ARRAY(AR,I),"^",6)=$S(I=1:1,1:0)
|
||||
. . Q
|
||||
. I AR=2 D
|
||||
. . N DESC,IN,LN
|
||||
. . S IN=$P(X,"^",1) Q:IN<1
|
||||
. . ; S LN=$G(^ICPT(IN,0),0) Q:LN=""
|
||||
. . S DESC=$P(X,"^",3) Q:DESC="" ; DBIA1995 $$CPT^ICPTCOD(CODE) returns X and the second piece of X is the DESC
|
||||
. . S I=CNT
|
||||
. . S $P(ARRAY(AR,I),"^",1)=TP
|
||||
. . S $P(ARRAY(AR,I),"^",2)=$P(X,"^",1)
|
||||
. . S $P(ARRAY(AR,I),"^",3)=$P(X,"^",2)
|
||||
. . S $P(ARRAY(AR,I),"^",5)=DESC
|
||||
. . S $P(ARRAY(AR,I),"^",7)=$S(I=1:1,1:0)
|
||||
. . Q
|
||||
. Q
|
||||
I $D(ARRAY(1))!$D(ARRAY(2)) S ARRAY(0)="1^1"
|
||||
Q
|
||||
;
|
||||
NOTICE(SUBJECT,TXT,DEVIEN,DUZ) ; This will fire off a mail message to the Indicated mail group saying that a study was deleted
|
||||
;
|
||||
N INST,MG,XMTO,XMDUZ,XMSUBJ,XMBODY,N,X
|
||||
S MG=0
|
||||
S INST=DEVIEN
|
||||
I INST>1 S MG=$P($G(^MDS(702.09,INST,0)),"^",2)
|
||||
I 'MG!('$$MG^MDHL7U2(MG)) S MG=$$FIND1^DIC(3.8,"","BX","MD DEVICE ERRORS") Q:'MG
|
||||
S MG=$$GET1^DIQ(3.8,+MG_",",.01)
|
||||
S XMTO="G."_MG_"@"_^XMB("NETNAME"),XMINSTR("FROM")=.5
|
||||
S XMBODY="TXT"
|
||||
S XMSUBJ=SUBJECT
|
||||
D SENDMSG^XMXAPI(DUZ,XMSUBJ,XMBODY,XMTO,.XMINSTR)
|
||||
Q
|
||||
;
|
||||
ALERT(MDSIEN) ; This is to send an e-mail to the main device mail group that a study has been deleted
|
||||
D NOW^%DTC
|
||||
S SUBJECT="Study "_MDSIEN_" for Patient "_$$GET1^DIQ(702,MDSIEN,.01,"E")_" has been DELETED!"
|
||||
S BODY(1)="The following study has been deleted."
|
||||
S BODY(2)=" By the USER: "_$$GET1^DIQ(200,DUZ,.01,"E")
|
||||
S BODY(3)=" On Date: "_$$FMTE^XLFDT(%,1)
|
||||
S BODY(4)=" "
|
||||
S BODY(5)=" CP Study Information"
|
||||
S BODY(6)="------------------------------------------------------------------------------ "
|
||||
S BODY(7)="CP Study ID: "_MDSIEN
|
||||
S BODY(8)="CP Study Def: "_$$GET1^DIQ(702,MDSIEN,.04,"E")
|
||||
S BODY(9)="Created on: "_$$FMTE^XLFDT($$GET1^DIQ(702,MDSIEN,.02,"I"),1)
|
||||
S BODY(10)="Created by: "_$$GET1^DIQ(702,MDSIEN,.03,"E")
|
||||
S BODY(11)="On Instrument: "_$$GET1^DIQ(702,MDSIEN,.11,"E")
|
||||
S BODY(12)="For Patient: "_$$GET1^DIQ(702,MDSIEN,.01,"E")
|
||||
S BODY(13)=" SSN: "_$E($$GET1^DIQ(702,MDSIEN,.011,"E"),6,9)
|
||||
S BODY(14)=" DOB: "_$$FMTE^XLFDT($$GET1^DIQ(702,MDSIEN,.012,"I"),1)
|
||||
S DEVIEN=$$GET1^DIQ(702,MDSIEN,.11,"I")
|
||||
Q
|
||||
MDHL7U3 ; HOIFO/WAA -Utilities for CP to process HL7 messages ; 7/26/00
|
||||
;;1.0;CLINICAL PROCEDURES;;Apr 01, 2004
|
||||
; Reference DBIA #4262 [Supported] for HL7 call.
|
||||
;
|
||||
PURGE(MDD7031) ;
|
||||
; This sub-routine will delete HL7 772 Message text after a message
|
||||
; been processed by Imaging.
|
||||
Q:'$D(^MDD(703.1,MDD7031,0)) ; No entry found
|
||||
S MDD772=$P(^MDD(703.1,MDD7031,0),U,6) Q:MDD772=""
|
||||
D DELBODY^HLUOPT2(MDD772,"CLINICAL PROCEDURES message purge","^TMP($J,""IN"")")
|
||||
S $P(^MDD(703.1,MDD7031,0),U,6)=""
|
||||
Q
|
||||
|
|
|
|||
|
|
@ -1,34 +1,34 @@
|
|||
MDHL7X ; HOIFO/WAA -Generate HL7 Error Message ; 06/08/00
|
||||
;;1.0;CLINICAL PROCEDURES;**6**;Apr 01, 2004;Build 102
|
||||
; Reference IA #1131 for ^XMB("NETNAME") access.
|
||||
; Reference IA #2165 for HLMA1 calls.
|
||||
; Reference IA #2729 for XMXAPI calls.
|
||||
D GENERR,GENACK Q
|
||||
GENERR ; Generate error message
|
||||
N TXT,INST,MG,XMTO,XMDUZ,XMSUBJ,XMBODY,N,X S MG=0
|
||||
S INST=DEVIEN
|
||||
I INST>1 S MG=$P($G(^MDS(702.09,INST,0)),"^",2)
|
||||
I 'MG!('$$MG^MDHL7U2(MG)) S MG=$$FIND1^DIC(3.8,"","BX","MD DEVICE ERRORS") Q:'MG
|
||||
S MG=$$GET1^DIQ(3.8,+MG_",",.01)
|
||||
S XMTO="G."_MG_"@"_^XMB("NETNAME"),XMINSTR("FROM")=.5
|
||||
I '$D(X) S X=$G(ECODE(0))
|
||||
S TXT(1)=ERRTX,TXT(2)=X,TXT(3)=" "
|
||||
S N=3
|
||||
I '$G(ECODE,1) D ; This is to process Device errors
|
||||
. N X
|
||||
. S X=0
|
||||
. F S X=$O(ECODE(X)) Q:X<1 S N=N+1,TXT(N)=ECODE(X)
|
||||
. S N=N+1,TXT(N)=" "
|
||||
. Q
|
||||
F X="MSH","PID","OBR","OBX" I $D(SEG(X)) S N=N+1,TXT(N)=SEG(X)
|
||||
S XMSUBJ="A Clinical Instrument HL7 Error has occurred."
|
||||
S XMBODY="TXT"
|
||||
D SENDMSG^XMXAPI(DUZ,XMSUBJ,XMBODY,XMTO,.XMINSTR)
|
||||
Q
|
||||
GENACK ; Generate an HL7 ACK message
|
||||
; Reference IA #2165 for GENACK^HLMA1 call
|
||||
N HLA,HLEID,HLEIDS,HLARYTYP,HLFORMAT,HLRESLTA
|
||||
S HLA("HLA",1)="MSA"_HL("FS")_$S($D(ERRTX):"AR",1:"AA")_HL("FS")_HL("MID")_$S($D(ERRTX):HL("FS")_ERRTX,1:"")
|
||||
S HLEID=HL("EID"),HLEIDS=HL("EIDS"),HLARYTYP="LM",HLFORMAT=1,HLRESLTA=HL("MID")
|
||||
D GENACK^HLMA1(HLEID,HLMTIENS,HLEIDS,HLARYTYP,HLFORMAT,.HLRESTLA)
|
||||
N ERRTX Q
|
||||
MDHL7X ; HOIFO/WAA -Generate HL7 Error Message ; 06/08/00
|
||||
;;1.0;CLINICAL PROCEDURES;;Apr 01, 2004
|
||||
; Reference IA #1131 for ^XMB("NETNAME") access.
|
||||
; Reference IA #2165 for HLMA1 calls.
|
||||
; Reference IA #2729 for XMXAPI calls.
|
||||
D GENERR,GENACK Q
|
||||
GENERR ; Generate error message
|
||||
N TXT,INST,MG,XMTO,XMDUZ,XMSUBJ,XMBODY,N,X S MG=0
|
||||
S INST=DEVIEN
|
||||
I INST>1 S MG=$P($G(^MDS(702.09,INST,0)),"^",2)
|
||||
I 'MG!('$$MG^MDHL7U2(MG)) S MG=$$FIND1^DIC(3.8,"","BX","MD DEVICE ERRORS") Q:'MG
|
||||
S MG=$$GET1^DIQ(3.8,+MG_",",.01)
|
||||
S XMTO="G."_MG_"@"_^XMB("NETNAME"),XMINSTR("FROM")=.5
|
||||
I '$D(X) S X=ECODE(0)
|
||||
S TXT(1)=ERRTX,TXT(2)=X,TXT(3)=" "
|
||||
S N=3
|
||||
I 'ECODE D ; This is to process Device errors
|
||||
. N X
|
||||
. S X=0
|
||||
. F S X=$O(ECODE(X)) Q:X<1 S N=N+1,TXT(N)=ECODE(X)
|
||||
. S N=N+1,TXT(N)=" "
|
||||
. Q
|
||||
F X="MSH","PID","OBR","OBX" I $D(SEG(X)) S N=N+1,TXT(N)=SEG(X)
|
||||
S XMSUBJ="A Clinical Instrument HL7 Error has occurred."
|
||||
S XMBODY="TXT"
|
||||
D SENDMSG^XMXAPI(DUZ,XMSUBJ,XMBODY,XMTO,.XMINSTR)
|
||||
Q
|
||||
GENACK ; Generate an HL7 ACK message
|
||||
; Reference IA #2165 for GENACK^HLMA1 call
|
||||
N HLA,HLEID,HLEIDS,HLARYTYP,HLFORMAT,HLRESLTA
|
||||
S HLA("HLA",1)="MSA"_HL("FS")_$S($D(ERRTX):"AR",1:"AA")_HL("FS")_HL("MID")_$S($D(ERRTX):HL("FS")_ERRTX,1:"")
|
||||
S HLEID=HL("EID"),HLEIDS=HL("EIDS"),HLARYTYP="LM",HLFORMAT=1,HLRESLTA=HL("MID")
|
||||
D GENACK^HLMA1(HLEID,HLMTIENS,HLEIDS,HLARYTYP,HLFORMAT,.HLRESTLA)
|
||||
N ERRTX Q
|
||||
|
|
|
|||
|
|
@ -1,175 +1,169 @@
|
|||
MDRPCOG ; HOIFO/DP - CP Gateway ; [01-09-2003 15:20]
|
||||
;;1.0;CLINICAL PROCEDURES;**6**;Apr 01, 2004;Build 102
|
||||
; Description:
|
||||
; This is the main routine that manages the CLINICAL PROCEDURES Gateway functions.
|
||||
; Access to these functions is controlled via the MD GATEWAY RPC.
|
||||
;
|
||||
; Integration Agreements:
|
||||
; IA# 10097 [Supported] %ZOSV calls
|
||||
; IA# 10103 [Supported] Calls to XLFDT
|
||||
; IA# 2263 [Supported] Calls to XPAR
|
||||
;
|
||||
CLEANUP ; [Procedure] Cleanup a past results report
|
||||
F X=0:0 S X=$O(^MDD(703.1,DATA,.1,X)) Q:'X D
|
||||
.S:$G(^MDD(703.1,DATA,.1,X,.1))]"" MDFDA(703.11,X_","_DATA_",",.1)="@"
|
||||
.S:$O(^MDD(703.1,DATA,.1,X,.2,0)) MDFDA(703.11,X_","_DATA_",",.2)="@"
|
||||
D:$D(MDFDA) FILE^DIE("K","MDFDA","MDERR")
|
||||
I $D(MDERR) D ERROR^MDRPCU(RESULTS,.MDERR) Q
|
||||
; Manual cleanup of the empty UNC nodes and WP root
|
||||
F X=0:0 S X=$O(^MDD(703.1,DATA,.1,X)) Q:'X D
|
||||
.K ^MDD(703.1,DATA,.1,X,.1)
|
||||
.K ^MDD(703.1,DATA,.1,X,.2)
|
||||
S @RESULTS@(0)="1^Item purged"
|
||||
Q
|
||||
;
|
||||
DONE ; [Procedure] Done processing, Mark study status
|
||||
S MDFDA(703.1,+DATA_",",.09)=$G(P1,"U")
|
||||
D FILE^DIE("","MDFDA")
|
||||
Q
|
||||
;
|
||||
GETATT ; [Procedure] Get attachments for study
|
||||
F X=0:0 S X=$O(^MDD(703.1,+DATA,.1,X)) Q:'X D
|
||||
.S Y=+$O(@RESULTS@(""),-1)+1
|
||||
.S @RESULTS@(Y)="703.11;"_X_U_^MDD(703.1,+DATA,.1,X,0)
|
||||
S @RESULTS@(0)=+$O(@RESULTS@(""),-1)
|
||||
Q
|
||||
;
|
||||
GETOLD ; [Procedure] Returns old results by date
|
||||
; Variables:
|
||||
; LOGDATE: [Private] Loop variable
|
||||
; STOPDATE: [Private] Date to stop retrieving entries
|
||||
;
|
||||
; New private variables
|
||||
NEW LOGDATE,STOPDATE,MDX
|
||||
S LOGDATE=+DATA,STOPDATE=+$P(DATA,U,2)+.2359
|
||||
F S LOGDATE=$O(^MDD(703.1,"ADTP",LOGDATE)) W !,"-->",LOGDATE Q:'LOGDATE!(LOGDATE>STOPDATE) D Q:Y>50
|
||||
.F MDX=0:0 S MDX=$O(^MDD(703.1,"ADTP",LOGDATE,MDX)) Q:'MDX D
|
||||
..I '$$CHECK(MDX) Q
|
||||
..S Y=$O(@RESULTS@(""),-1)+1
|
||||
..S @RESULTS@(Y)="703.1;"_MDX_U_$G(^MDD(703.1,MDX,0))
|
||||
S:'LOGDATE!(LOGDATE>STOPDATE) LOGDATE=STOPDATE
|
||||
S @RESULTS@(0)=+$O(@RESULTS@(""),-1)_U_LOGDATE_U_$$FMTE^XLFDT(LOGDATE)
|
||||
Q
|
||||
;
|
||||
GETPAR ; [Procedure] Get a parameter value for an RPC Call
|
||||
S @RESULTS@(0)=$$PARVAL(DATA)
|
||||
Q
|
||||
;
|
||||
GETTXT ; [Procedure] Get attachment text for processing
|
||||
N X,STUDY,ATT
|
||||
S X=0,STUDY=$P(DATA,",",2),ATT=+DATA
|
||||
I '$O(^MDD(703.1,STUDY,.1,ATT,.2,0)) S @RESULTS@(0)="-1^No Data" Q
|
||||
F S X=$O(^MDD(703.1,STUDY,.1,ATT,.2,X)) Q:'X S @RESULTS@(X)=^(X,0)
|
||||
S @RESULTS@(0)=+$O(@RESULTS@(""),-1)
|
||||
Q
|
||||
;
|
||||
NEXT ; [Procedure] Get the next study to process
|
||||
S Y=+$O(^MDD(703.1,"ASTATUS","P",$G(DATA)))
|
||||
S @RESULTS@(0)=$S($D(^MDD(703.1,Y,0)):"703.1;"_Y_U_^MDD(703.1,Y,0),1:0)
|
||||
Q
|
||||
;
|
||||
PARVAL(INSTANCE) ; [Procedure] Extrinsic get of parameter values
|
||||
; Input parameters
|
||||
; 1. INSTANCE [Literal/Required] XPAR instance
|
||||
;
|
||||
Q $$GET^XPAR("SYS","MD GATEWAY",INSTANCE)
|
||||
;
|
||||
POLL ; [Procedure] Returns server time and flag for studies to process
|
||||
I $$PARVAL("Shutdown Flag")]"" D Q
|
||||
.S @RESULTS@(0)="-1^SHUTDOWN"
|
||||
.D SETPAR("Shutdown Flag","")
|
||||
S @RESULTS@(0)=$$FMTE^XLFDT($$NOW^XLFDT)
|
||||
S @RESULTS@(1)=$D(^MDD(703.1,"ASTATUS","P"))
|
||||
Q
|
||||
;
|
||||
POLLER(RESULTS) ; [Procedure] Non-Disk activity poller
|
||||
; With the exception of a shutdown request pending, this stand alone RPC will operate
|
||||
; without creating any disk activity and not crash during backup operations on the main
|
||||
; VistA server.
|
||||
;
|
||||
; Input parameters
|
||||
; 1. RESULTS [Reference/Required]
|
||||
;
|
||||
I $$PARVAL("Shutdown Flag")]"" D Q
|
||||
.S RESULTS(0)="-1^SHUTDOWN"
|
||||
.D SETPAR("Shutdown Flag","")
|
||||
S RESULTS(0)=$$FMTE^XLFDT($$NOW^XLFDT)
|
||||
S RESULTS(1)=$D(^MDD(703.1,"ASTATUS","P"))
|
||||
Q
|
||||
;
|
||||
RPC(RESULTS,OPTION,DATA,P1) ; [Procedure]
|
||||
; Input parameters
|
||||
; 1. RESULTS [Literal/Required] RPC Return Array
|
||||
; 2. OPTION [Literal/Required] Gateway Option to execute
|
||||
; 3. DATA [Literal/Required] Other information
|
||||
; 4. P1 [Literal/Required] Overflow variable
|
||||
;
|
||||
; Variables:
|
||||
; MDENV: [Private] Server environment variable
|
||||
; MDERR: [Private] Fileman return array
|
||||
; MDFDA: [Private] Fileman FDA
|
||||
;
|
||||
; New private variables
|
||||
NEW MDENV,MDERR,MDFDA
|
||||
S RESULTS=$NA(^TMP("MDRPCOB",$J)) K @RESULTS
|
||||
D @OPTION
|
||||
Q
|
||||
;
|
||||
RUNNING ; [Procedure] Returns 0/1 and message on running status
|
||||
; Note: If lock CAN be obtained, then gateway is NOT running
|
||||
L +^MDD("CPGATEWAY"):1 E S @RESULTS@(0)="1^RUNNING" Q
|
||||
L -(^MDD("CPGATEWAY")) S @RESULTS@(0)="0^NOT RUNNING"
|
||||
Q
|
||||
;
|
||||
SETFILE ; [Procedure] Set filename of new attachment
|
||||
S MDFDA(703.11,$P(DATA,U,1),.02)=$P(DATA,U,2)
|
||||
D FILE^DIE("","MDFDA")
|
||||
Q
|
||||
;
|
||||
SETPAR(INSTANCE,VALUE) ; [Procedure] Set value into XPAR parameter
|
||||
; Input parameters
|
||||
; 1. INSTANCE [Literal/Required] Parameter Instance
|
||||
; 2. VALUE [Literal/Required] Parameter Value
|
||||
;
|
||||
D EN^XPAR("SYS","MD GATEWAY",INSTANCE,VALUE)
|
||||
Q
|
||||
;
|
||||
START ; [Procedure] Can we begin?
|
||||
; Ensure only one Gateway per system by locking the phantom global node
|
||||
L +^MDD("CPGATEWAY"):1
|
||||
I '$T D STATUS S @RESULTS@(0)="-1^FAIL" Q
|
||||
; Clear all process settings
|
||||
D NDEL^XPAR("SYS","MD GATEWAY")
|
||||
S DATA=$G(DATA,"30^1000") ; Default poll interval and log entries
|
||||
D SETPAR("Polling Interval",+$P(DATA,U,1))
|
||||
D SETPAR("Maximum Log Entries",+$P(DATA,U,2))
|
||||
D SETPAR("Job ID",$J)
|
||||
D SETPAR("Started At",$$FMTE^XLFDT($$NOW^XLFDT))
|
||||
D SETPAR("Started By",$$GET1^DIQ(200,DUZ_",",.01))
|
||||
D GETENV^%ZOSV S MDENV=Y
|
||||
D SETPAR("UCI",$P(MDENV,U,1))
|
||||
D SETPAR("Volume",$P(MDENV,U,2))
|
||||
D SETPAR("Node",$P(MDENV,U,3))
|
||||
D SETNM^%ZOSV("CP Gateway")
|
||||
S @RESULTS@(0)="1^OK"
|
||||
Q
|
||||
;
|
||||
STATUS ; [Procedure] Return status of BP
|
||||
D GETLST^XPAR(.MDRET,"SYS","MD GATEWAY","Q")
|
||||
F X=0:0 S X=$O(MDRET(X)) Q:'X S @RESULTS@(X)=MDRET(X)
|
||||
Q
|
||||
;
|
||||
STOP ; [Procedure] Flag client to stop via cal to POLL
|
||||
D SETPAR("Shutdown Flag","Yes")
|
||||
Q
|
||||
;
|
||||
XFERDIR ; [Procedure] Return Imaging xfer directory
|
||||
S @RESULTS@(0)=$$GET^XPAR("SYS","MD IMAGING XFER")
|
||||
Q
|
||||
;
|
||||
CHECK(MDRI) ; Check if Upload Value and Upload Text has already been purged.
|
||||
N MDFLG S MDFLG=0
|
||||
F X=0:0 S X=$O(^MDD(703.1,MDRI,.1,X)) Q:'X D Q:MDFLG
|
||||
.S:$G(^MDD(703.1,MDRI,.1,X,.1))]"" MDFLG=1
|
||||
.S:$O(^MDD(703.1,MDRI,.1,X,.2,0)) MDFLG=1
|
||||
Q MDFLG
|
||||
MDRPCOG ; HOIFO/DP - CP Gateway ; [01-09-2003 15:20]
|
||||
;;1.0;CLINICAL PROCEDURES;;Apr 01, 2004
|
||||
; Description:
|
||||
; This is the main routine that manages the CLINICAL PROCEDURES Gateway functions.
|
||||
; Access to these functions is controlled via the MD GATEWAY RPC.
|
||||
;
|
||||
; Integration Agreements:
|
||||
; IA# 10097 [Supported] %ZOSV calls
|
||||
; IA# 10103 [Supported] Calls to XLFDT
|
||||
; IA# 2263 [Supported] Calls to XPAR
|
||||
;
|
||||
CLEANUP ; [Procedure] Cleanup a past results report
|
||||
F X=0:0 S X=$O(^MDD(703.1,DATA,.1,X)) Q:'X D
|
||||
.S:$G(^MDD(703.1,DATA,.1,X,.1))]"" MDFDA(703.11,X_","_DATA_",",.1)="@"
|
||||
.S:$O(^MDD(703.1,DATA,.1,X,.2,0)) MDFDA(703.11,X_","_DATA_",",.2)="@"
|
||||
D:$D(MDFDA) FILE^DIE("K","MDFDA","MDERR")
|
||||
I $D(MDERR) D ERROR^MDRPCU(RESULTS,.MDERR) Q
|
||||
; Manual cleanup of the empty UNC nodes and WP root
|
||||
F X=0:0 S X=$O(^MDD(703.1,DATA,.1,X)) Q:'X D
|
||||
.K ^MDD(703.1,DATA,.1,X,.1)
|
||||
.K ^MDD(703.1,DATA,.1,X,.2)
|
||||
S @RESULTS@(0)="1^Item purged"
|
||||
Q
|
||||
;
|
||||
DONE ; [Procedure] Done processing, Mark study status
|
||||
S MDFDA(703.1,+DATA_",",.09)=$G(P1,"U")
|
||||
D FILE^DIE("","MDFDA")
|
||||
Q
|
||||
;
|
||||
GETATT ; [Procedure] Get attachments for study
|
||||
F X=0:0 S X=$O(^MDD(703.1,+DATA,.1,X)) Q:'X D
|
||||
.S Y=+$O(@RESULTS@(""),-1)+1
|
||||
.S @RESULTS@(Y)="703.11;"_X_U_^MDD(703.1,+DATA,.1,X,0)
|
||||
S @RESULTS@(0)=+$O(@RESULTS@(""),-1)
|
||||
Q
|
||||
;
|
||||
GETOLD ; [Procedure] Returns old results by date
|
||||
; Variables:
|
||||
; LOGDATE: [Private] Loop variable
|
||||
; STOPDATE: [Private] Date to stop retrieving entries
|
||||
;
|
||||
; New private variables
|
||||
NEW LOGDATE,STOPDATE,MDX
|
||||
S LOGDATE=+DATA,STOPDATE=+$P(DATA,U,2)+.2359
|
||||
F S LOGDATE=$O(^MDD(703.1,"ADTP",LOGDATE)) W !,"-->",LOGDATE Q:'LOGDATE!(LOGDATE>STOPDATE) D Q:Y>50
|
||||
.F MDX=0:0 S MDX=$O(^MDD(703.1,"ADTP",LOGDATE,MDX)) Q:'MDX D
|
||||
..I '$$CHECK(MDX) Q
|
||||
..S Y=$O(@RESULTS@(""),-1)+1
|
||||
..S @RESULTS@(Y)="703.1;"_MDX_U_$G(^MDD(703.1,MDX,0))
|
||||
S:'LOGDATE!(LOGDATE>STOPDATE) LOGDATE=STOPDATE
|
||||
S @RESULTS@(0)=+$O(@RESULTS@(""),-1)_U_LOGDATE_U_$$FMTE^XLFDT(LOGDATE)
|
||||
Q
|
||||
;
|
||||
GETPAR ; [Procedure] Get a parameter value for an RPC Call
|
||||
S @RESULTS@(0)=$$PARVAL(DATA)
|
||||
Q
|
||||
;
|
||||
GETTXT ; [Procedure] Get attachment text for processing
|
||||
N X,STUDY,ATT
|
||||
S X=0,STUDY=$P(DATA,",",2),ATT=+DATA
|
||||
I '$O(^MDD(703.1,STUDY,.1,ATT,.2,0)) S @RESULTS@(0)="-1^No Data" Q
|
||||
F S X=$O(^MDD(703.1,STUDY,.1,ATT,.2,X)) Q:'X S @RESULTS@(X)=^(X,0)
|
||||
S @RESULTS@(0)=+$O(@RESULTS@(""),-1)
|
||||
Q
|
||||
;
|
||||
NEXT ; [Procedure] Get the next study to process
|
||||
S Y=+$O(^MDD(703.1,"ASTATUS","P",$G(DATA)))
|
||||
S @RESULTS@(0)=$S($D(^MDD(703.1,Y,0)):"703.1;"_Y_U_^MDD(703.1,Y,0),1:0)
|
||||
Q
|
||||
;
|
||||
PARVAL(INSTANCE) ; [Procedure] Extrinsic get of parameter values
|
||||
; Input parameters
|
||||
; 1. INSTANCE [Literal/Required] XPAR instance
|
||||
;
|
||||
Q $$GET^XPAR("SYS","MD GATEWAY",INSTANCE)
|
||||
;
|
||||
POLL ; [Procedure] Returns server time and flag for studies to process
|
||||
I $$PARVAL("Shutdown Flag")]"" D Q
|
||||
.S @RESULTS@(0)="-1^SHUTDOWN"
|
||||
.D SETPAR("Shutdown Flag","")
|
||||
S @RESULTS@(0)=$$FMTE^XLFDT($$NOW^XLFDT)
|
||||
S @RESULTS@(1)=$D(^MDD(703.1,"ASTATUS","P"))
|
||||
Q
|
||||
;
|
||||
POLLER(RESULTS) ; [Procedure] Non-Disk activity poller
|
||||
; With the exception of a shutdown request pending, this stand alone RPC will operate
|
||||
; without creating any disk activity and not crash during backup operations on the main
|
||||
; VistA server.
|
||||
;
|
||||
; Input parameters
|
||||
; 1. RESULTS [Reference/Required]
|
||||
;
|
||||
I $$PARVAL("Shutdown Flag")]"" D Q
|
||||
.S RESULTS(0)="-1^SHUTDOWN"
|
||||
.D SETPAR("Shutdown Flag","")
|
||||
S RESULTS(0)=$$FMTE^XLFDT($$NOW^XLFDT)
|
||||
S RESULTS(1)=$D(^MDD(703.1,"ASTATUS","P"))
|
||||
Q
|
||||
;
|
||||
RPC(RESULTS,OPTION,DATA,P1) ; [Procedure]
|
||||
; Input parameters
|
||||
; 1. RESULTS [Literal/Required] RPC Return Array
|
||||
; 2. OPTION [Literal/Required] Gateway Option to execute
|
||||
; 3. DATA [Literal/Required] Other information
|
||||
; 4. P1 [Literal/Required] Overflow variable
|
||||
;
|
||||
; Variables:
|
||||
; MDENV: [Private] Server environment variable
|
||||
; MDERR: [Private] Fileman return array
|
||||
; MDFDA: [Private] Fileman FDA
|
||||
;
|
||||
; New private variables
|
||||
NEW MDENV,MDERR,MDFDA
|
||||
S RESULTS=$NA(^TMP("MDRPCOB",$J)) K @RESULTS
|
||||
D @OPTION
|
||||
Q
|
||||
;
|
||||
SETFILE ; [Procedure] Set filename of new attachment
|
||||
S MDFDA(703.11,$P(DATA,U,1),.02)=$P(DATA,U,2)
|
||||
D FILE^DIE("","MDFDA")
|
||||
Q
|
||||
;
|
||||
SETPAR(INSTANCE,VALUE) ; [Procedure] Set value into XPAR parameter
|
||||
; Input parameters
|
||||
; 1. INSTANCE [Literal/Required] Parameter Instance
|
||||
; 2. VALUE [Literal/Required] Parameter Value
|
||||
;
|
||||
D EN^XPAR("SYS","MD GATEWAY",INSTANCE,VALUE)
|
||||
Q
|
||||
;
|
||||
START ; [Procedure] Can we begin?
|
||||
; Ensure only one Gateway per system by locking the phantom global node
|
||||
L +^MDD("CPGATEWAY"):1
|
||||
I '$T D STATUS S @RESULTS@(0)="-1^FAIL" Q
|
||||
; Clear all process settings
|
||||
D NDEL^XPAR("SYS","MD GATEWAY")
|
||||
S DATA=$G(DATA,"30^1000") ; Default poll interval and log entries
|
||||
D SETPAR("Polling Interval",+$P(DATA,U,1))
|
||||
D SETPAR("Maximum Log Entries",+$P(DATA,U,2))
|
||||
D SETPAR("Job ID",$J)
|
||||
D SETPAR("Started At",$$FMTE^XLFDT($$NOW^XLFDT))
|
||||
D SETPAR("Started By",$$GET1^DIQ(200,DUZ_",",.01))
|
||||
D GETENV^%ZOSV S MDENV=Y
|
||||
D SETPAR("UCI",$P(MDENV,U,1))
|
||||
D SETPAR("Volume",$P(MDENV,U,2))
|
||||
D SETPAR("Node",$P(MDENV,U,3))
|
||||
D SETNM^%ZOSV("CP Gateway")
|
||||
S @RESULTS@(0)="1^OK"
|
||||
Q
|
||||
;
|
||||
STATUS ; [Procedure] Return status of BP
|
||||
D GETLST^XPAR(.MDRET,"SYS","MD GATEWAY","Q")
|
||||
F X=0:0 S X=$O(MDRET(X)) Q:'X S @RESULTS@(X)=MDRET(X)
|
||||
Q
|
||||
;
|
||||
STOP ; [Procedure] Flag client to stop via cal to POLL
|
||||
D SETPAR("Shutdown Flag","Yes")
|
||||
Q
|
||||
;
|
||||
XFERDIR ; [Procedure] Return Imaging xfer directory
|
||||
S @RESULTS@(0)=$$GET^XPAR("SYS","MD IMAGING XFER")
|
||||
Q
|
||||
;
|
||||
CHECK(MDRI) ; Check if Upload Value and Upload Text has already been purged.
|
||||
N MDFLG S MDFLG=0
|
||||
F X=0:0 S X=$O(^MDD(703.1,MDRI,.1,X)) Q:'X D Q:MDFLG
|
||||
.S:$G(^MDD(703.1,MDRI,.1,X,.1))]"" MDFLG=1
|
||||
.S:$O(^MDD(703.1,MDRI,.1,X,.2,0)) MDFLG=1
|
||||
Q MDFLG
|
||||
|
|
|
|||
|
|
@ -1,225 +1,240 @@
|
|||
MDRPCOP ; HOIFO/DP - Object RPCs (TMDPatient) ;3/12/08 09:16
|
||||
;;1.0;CLINICAL PROCEDURES;**4,6**;Apr 01, 2004;Build 102
|
||||
; Integration Agreements:
|
||||
; IA# 2263 [Supported] XPAR calls
|
||||
; IA# 3027 [Supported] Calls to DGSEC4
|
||||
; IA# 2981 [Subscription] Calls to GUI~GMRCP5
|
||||
; IA# 2548 [Supported] ACRP Interface Toolkit APIs.
|
||||
; IA# 2552 [Supported] AIT API to provide outpatient encounter data.
|
||||
; IA# 10061 [Supported] VADPT calls.
|
||||
; IA# 3468 [Subscription] Use GMRCCP APIs.
|
||||
; IA# 10103 [Supported] Call to XLFDT
|
||||
; IA# 10039 [Supported] Ward Location File (#42) Access.
|
||||
; IA# 10035 [Supported] DPT references
|
||||
; IA# 3613 [Private] GETVST^MDRPCOP API call
|
||||
; IA# 10099 [Supported] GMRADPT call
|
||||
; IA# 1096 [Controlled Subscription] ^DGPM("ATID1" x-ref loop
|
||||
; IA# 358 [Controlled Subscription] FILE 405 references
|
||||
;
|
||||
ADD(X) ; [Procedure] Add line to @RESULTS@(...
|
||||
S @RESULTS@(+$O(@RESULTS@(""),-1)+1)=X
|
||||
Q
|
||||
;
|
||||
ALLERGY ; [Procedure] Return Allergies
|
||||
D EN1^GMRADPT I '$O(GMRAL(0)) D Q
|
||||
.I $G(GMRAL)="" S @RESULTS@(0)="No Allergy Assessment"
|
||||
.I $G(GMRAL)=0 S @RESULTS@(0)="No Known Allergies"
|
||||
S @RESULTS@(0)="This patient has the following allergy(ies): "
|
||||
F X=0:0 S X=$O(GMRAL(X)) Q:'X D
|
||||
.S @RESULTS@(X)=$P($G(GMRAL(X)),U,2)
|
||||
Q
|
||||
;
|
||||
CHKIN ; [Procedure] Check In Study
|
||||
F X=2:1:5 D
|
||||
.I $P(DATA,U,X)]"" S MDFDA(702,$P(DATA,U,1),$P("^.04^.05^.11^.07",U,X))=$P(DATA,U,X)
|
||||
S MDFDA(702,$P(DATA,U,1),.09)=4 ; Status = Checked-In
|
||||
I $P(DATA,U,1)="+1," D
|
||||
.S MDFDA(702,"+1,",.01)=DFN
|
||||
.S MDFDA(702,"+1,",.02)=$$NOW^XLFDT()
|
||||
.S MDFDA(702,"+1,",.03)=DUZ
|
||||
.D UPDATE^DIE("","MDFDA","MDIEN","MDERR") Q:$D(MDERR)
|
||||
.S MDIENS=MDIEN(1)_",",MDHL7=$$SUB^MDHL7B(MDIEN(1))
|
||||
.I +MDHL7=-1 S MDFDA(702,MDIENS,.09)=2,MDFDA(702,MDIENS,.08)=$P(MDHL7,U,2)
|
||||
.I +MDHL7=1 S MDFDA(702,MDIENS,.09)=5,MDFDA(702,MDIENS,.08)=""
|
||||
.D:$D(MDFDA) FILE^DIE("","MDFDA","MDERR")
|
||||
I $P(DATA,U,1)'="+1," D
|
||||
.D FILE^DIE("","MDFDA","MDERR") Q:$D(MDERR)
|
||||
.S MDIENS=+DATA_","
|
||||
.S MDHL7=$$SUB^MDHL7B(+MDIENS)
|
||||
.I +MDHL7=-1 S MDFDA(702,MDIENS,.09)=2,MDFDA(702,MDIENS,.08)=$P(MDHL7,U,2)
|
||||
.I +MDHL7=1 S MDFDA(702,MDIENS,.09)=5,MDFDA(702,MDIENS,.08)=""
|
||||
.D:$D(MDFDA) FILE^DIE("","MDFDA","MDERR")
|
||||
; Patch 6 - Renal Check-In
|
||||
D:+$G(MDIENS)
|
||||
.S X=+$P(^MDD(702,+MDIENS,0),U,4) Q:'X
|
||||
.I $P(^MDS(702.01,X,0),U,6)=2 D Q ; Renal Check-In
|
||||
..D CP^MDKUTLR(+MDIENS)
|
||||
..S MDFDA(702,+MDIENS_",",.09)=5
|
||||
..D FILE^DIE("","MDFDA","MDERR")
|
||||
; Patch 6 - Renal Check-In
|
||||
I '$D(MDERR) S @RESULTS@(0)="1^OK" Q
|
||||
D ERROR^MDRPCU(RESULTS,.MDERR)
|
||||
Q
|
||||
;
|
||||
DISPCON ; [Procedure] Display a consult
|
||||
K ^TMP("GMRC",$J)
|
||||
D GUI^GMRCP5(.RESULTS,DATA)
|
||||
Q
|
||||
;
|
||||
GETCONS ; [Procedure] Get available consults for patient
|
||||
K ^TMP("MDTMP",$J) N MDCDT,MDDY,X1,X2,X
|
||||
S MDDY=$$GET^XPAR("SYS","MD COMPL PROC DISPLAY DAYS",1)
|
||||
S X1=DT,X2=-$S(MDDY>0:+MDDY,1:365) D C^%DTC S MDCDT=X
|
||||
D CPLIST^GMRCCP(DFN,,$NA(^TMP("MDTMP",$J)))
|
||||
S MDX=0
|
||||
F S MDX=$O(^TMP("MDTMP",$J,MDX)) Q:'MDX D:"saprc"[$P(^(MDX),U,4)
|
||||
.S Y="123;"_$P(^TMP("MDTMP",$J,MDX),U,5)
|
||||
.I $P($G(^TMP("MDTMP",$J,MDX)),U,4)="c" Q:$P($G(^TMP("MDTMP",$J,MDX)),U,1)<MDCDT
|
||||
.F X=2,3,4,1,6,5 S Y=Y_U_$P(^TMP("MDTMP",$J,MDX),U,X)
|
||||
.S Y=Y_U_+$O(^MDD(702,"ACON",+$P(^TMP("MDTMP",$J,MDX),U,5)))
|
||||
.;
|
||||
.; Patch MD*1.0*4 - Return number of times checked in at piece 9
|
||||
.;
|
||||
.S (X,Z)=0,MDY=+$P(^TMP("MDTMP",$J,MDX),U,5)
|
||||
.F S X=$O(^MDD(702,"ACON",MDY,X)) Q:'X S Z=Z+1
|
||||
.S $P(Y,U,9)=Z
|
||||
.;
|
||||
.; End Patch MD*1.0*4
|
||||
.;
|
||||
.D ADD(Y)
|
||||
S @RESULTS@(0)=+$O(@RESULTS@(""),-1)
|
||||
K ^TMP("MDTMP",$J)
|
||||
Q
|
||||
;
|
||||
GETHDR ; [Procedure] Get Pt Header
|
||||
S DFNIENS=DFN_","
|
||||
S @RESULTS@(0)=$$GET1^DIQ(2,DFNIENS,.01)_" "_$$GET1^DIQ(2,DFNIENS,.1)_" "_$$GET1^DIQ(2,DFNIENS,.101)
|
||||
S @RESULTS@(1)=$$GET1^DIQ(2,DFNIENS,.09)_" "_$$GET1^DIQ(2,DFNIENS,.02)_" "_$$GET1^DIQ(2,DFNIENS,.03)_" ("_$$GET1^DIQ(2,DFNIENS,.033)_")"
|
||||
Q
|
||||
;
|
||||
GETOBJ ; [Procedure] Get information for TMDPATIENT object
|
||||
D DEM^VADPT,INP^VADPT
|
||||
S @RESULTS@(0)=DFN
|
||||
S @RESULTS@(1)=VADM(1)
|
||||
S @RESULTS@(2)=$P(VADM(2),U,2)
|
||||
S @RESULTS@(3)=$P(VADM(3),U,2)
|
||||
S @RESULTS@(4)=VADM(4)
|
||||
S @RESULTS@(5)=$P(VADM(5),U,2)
|
||||
I VAIN(4)]"" S @RESULTS@(6)="Ward: "_$P(VAIN(4),U,2)_" Rm: "_VAIN(5)
|
||||
E S @RESULTS@(6)=""
|
||||
Q
|
||||
;
|
||||
GETRES ; [Procedure] Get results report
|
||||
F MDX=0:0 S MDX=$O(^MDD(703.1,"ADFN",DFN,MDX)) Q:'MDX D
|
||||
.S MDINST=+$P($G(^MDD(703.1,MDX,0)),U,4)
|
||||
.I $G(DATA) Q:'$D(^MDS(702.01,DATA,.1,"B",MDINST))
|
||||
.S MDY=$O(@RESULTS@(""),-1)+1
|
||||
.S @RESULTS@(MDY)="703.1;"_MDX_U_^MDD(703.1,MDX,0)
|
||||
.S Y=$P(^MDD(703.1,MDX,0),U,3) D D^DIQ
|
||||
.S $P(@RESULTS@(MDY),U,11)=Y
|
||||
.S Y=$P($G(^MDS(702.09,+$P(^MDD(703.1,MDX,0),U,4),0)),U)
|
||||
.S $P(@RESULTS@(MDY),U,12)=Y
|
||||
S @RESULTS@(0)=+$O(@RESULTS@(""),-1)
|
||||
Q
|
||||
;
|
||||
GETTRAN ; [Procedure] Get a patients transactions
|
||||
K ^TMP("MDTMP",$J),^TMP("MDCONL",$J) N MDCDT,MDCOM,MDMULT,MDNUM,MDREQ,MDREQDT,MDYR,X1,X2,X
|
||||
S MDNUM=$$GET^XPAR("SYS","MD DAYS TO RETAIN COM STUDY",1) S MDCOM=0
|
||||
I +MDNUM>0 S X1=DT,X2=-MDNUM D C^%DTC S MDCOM=X
|
||||
D CPLIST^GMRCCP(DFN,,$NA(^TMP("MDTMP",$J)))
|
||||
S X1=DT,X2=-365 D C^%DTC S MDCDT=X
|
||||
S MDX=0 F S MDX=$O(^TMP("MDTMP",$J,MDX)) Q:'MDX D:"saprc"[$P(^(MDX),U,4)
|
||||
.I $P($G(^TMP("MDTMP",$J,MDX)),U,4)="c" Q:$P($G(^TMP("MDTMP",$J,MDX)),U,1)<MDCDT
|
||||
.S ^TMP("MDCONL",$J,$P($G(^TMP("MDTMP",$J,MDX)),U,5))=$P($G(^TMP("MDTMP",$J,MDX)),U,1)
|
||||
K ^TMP("MDTMP",$J)
|
||||
F MDX=0:0 S MDX=$O(^MDD(702,"B",DFN,+MDX))_"," Q:'MDX D
|
||||
.Q:'$$GET1^DIQ(702,MDX,.05,"I")
|
||||
.Q:$G(^TMP("MDCONL",$J,+$$GET1^DIQ(702,MDX,.05,"I")))=""
|
||||
.S MDMULT=+$$GET1^DIQ(702,MDX,".04:.12","I")
|
||||
.S MDYR=$S(MDMULT<1:MDCOM,1:MDCDT)
|
||||
.I MDNUM Q:$$GET1^DIQ(702,MDX,.09,"I")=3&($$GET1^DIQ(702,MDX,.02,"I")<MDYR)
|
||||
.S MDREQDT="" I +$$GET1^DIQ(702,MDX,.05,"I") S MDREQDT=$G(^TMP("MDCONL",$J,+$$GET1^DIQ(702,MDX,.05,"I")))
|
||||
.I MDREQDT'="" S MDREQDT=$$FMTE^XLFDT(MDREQDT,"1P")
|
||||
.S MDREQ=$$GET1^DIQ(702,MDX,.04)_" "_+MDX_" (Consult #:"_$$GET1^DIQ(702,MDX,.05,"I")_$S(MDREQDT'="":" Requested: "_MDREQDT,1:"")_")"
|
||||
.S Z=$$GET1^DIQ(702,MDX,".04:.02","I")_U_MDREQ_U_$$GET1^DIQ(702,MDX,.02,"I")_U_$$GET1^DIQ(702,MDX,.09)_U_$$GET1^DIQ(702,MDX,.11)_U_$$GET1^DIQ(702,MDX,.991)
|
||||
.S Y=$O(@RESULTS@(""),-1)+1
|
||||
.S @RESULTS@(Y)="702;"_+MDX_U_Z
|
||||
S @RESULTS@(0)=+$O(@RESULTS@(""),-1)
|
||||
K ^TMP("MDCONL",$J)
|
||||
Q
|
||||
;
|
||||
GETVST ; [Procedure] Return list of visits
|
||||
N BEG,END,VAERR,VASD,BDT,DTM,EDT,LOC,NOW,MDQUERY,MDLST,MDTDF,STI,STS,TODAY,I,J,K,XI,XE,X
|
||||
S NOW=$$NOW^XLFDT(),TODAY=$P(NOW,".",1),MDTDF=DFN
|
||||
S BEG=$$X2FM($$GETBEG),END=$$X2FM($$GETEND)+0.2359
|
||||
S MDLST="",MDSTOP=""
|
||||
I END>NOW D ; get future encounters, past cancels/no-shows from VADPT
|
||||
.S VASD("F")=BEG
|
||||
.S VASD("T")=END
|
||||
.S VASD("W")="123456789"
|
||||
.D SDA^VADPT
|
||||
.S I=0 F S I=$O(^UTILITY("VASD",$J,I)) Q:'I D
|
||||
..S XI=^UTILITY("VASD",$J,I,"I"),XE=^("E")
|
||||
..S DTM=$P(XI,U),IEN=$P(XI,U,2),STI=$P(XI,U,3)
|
||||
..S LOC=$P(XE,U,2),STS=$P(XE,U,3)
|
||||
..I DTM<TODAY,(STI=""!(STI["I")!(STI="NT")) Q ; no prior kept appts
|
||||
..S MDLST(DTM,"A",1)="A;"_DTM_";"_IEN_U_DTM_U_LOC_U_STS
|
||||
.K ^UTILITY("VASD",$J)
|
||||
I BEG'>NOW D ;past encounters from ACRP Toolkit - set in CALLBACK
|
||||
.S BDT=BEG
|
||||
.S EDT=$S(END<NOW:END,1:NOW)
|
||||
.D OPEN^SDQ(.MDQUERY)
|
||||
.I '$$ERRCHK^SDQUT() D INDEX^SDQ(.MDQUERY,"PATIENT/DATE","SET")
|
||||
.I '$$ERRCHK^SDQUT() D PAT^SDQ(.MDQUERY,DFN,"SET")
|
||||
.I '$$ERRCHK^SDQUT() D DATE^SDQ(.MDQUERY,BDT,EDT,"SET")
|
||||
.I '$$ERRCHK^SDQUT() D
|
||||
..D SCANCB^SDQ(.MDQUERY,"D CALLBACK^ORWCV(Y,Y0,$NA(MDLST),.MDSTOP)","SET")
|
||||
.I '$$ERRCHK^SDQUT() D ACTIVE^SDQ(.MDQUERY,"TRUE","SET")
|
||||
.I '$$ERRCHK^SDQUT() D SCAN^SDQ(.MDQUERY,"FORWARD")
|
||||
.D CLOSE^SDQ(.MDQUERY)
|
||||
N TIM,MOV,MDX0,Y,MTIM,XTYP,XLOC,XLOCI,HLOC,EARLY,DONE ; admits
|
||||
S EARLY=BEG,DONE=0 S:$G(DFN)="" DFN=MDTDF
|
||||
S TIM="" F S TIM=$O(^DGPM("ATID1",DFN,TIM)) Q:TIM'>0 D Q:DONE
|
||||
.S MOV=0 F S MOV=$O(^DGPM("ATID1",DFN,TIM,MOV)) Q:MOV'>0 D Q:DONE
|
||||
..D GETS^DIQ(405,+MOV_",","*","IE","MDX0") S MTIM=$G(MDX0(405,MOV_",",".01","I"))
|
||||
..S XTYP=$G(MDX0(405,+MOV_",",".04","E"))
|
||||
..S XLOC=$G(MDX0(405,+MOV_",",".06","E"))
|
||||
..S XLOCI=+$G(MDX0(405,+MOV_",",".06","I")),HLOC=+$G(^DIC(42,+XLOCI,44))
|
||||
..S MDLST(MTIM,"I",1)="I;"_MTIM_";"_HLOC_U_MTIM_U_"Inpatient Stay"_U_XLOC_U_XTYP
|
||||
..S DONE=1 ; Not sure if I should include all stays <DRP@Hines>
|
||||
S I=0 F S I=$O(MDLST(I)) Q:'I D
|
||||
.S J="" F S J=$O(MDLST(I,J)) Q:J="" D
|
||||
..S K=0 F S K=$O(MDLST(I,J,K)) Q:'K D
|
||||
...S @RESULTS@($O(@RESULTS@(""),-1)+1)=MDLST(I,J,K)
|
||||
S:$G(DFN)="" DFN=MDTDF S @RESULTS@(0)=+$O(@RESULTS@(""),-1)_U_($$GET1^DIQ(2,DFN_",",.1)]"")
|
||||
Q
|
||||
;
|
||||
GETBEG() ; Get Beginning Date Range
|
||||
I $$GET^XPAR("SYS","MD APPOINT START DATE",1)>1 Q "T-"_$$GET^XPAR("SYS","MD APPOINT START DATE",1)
|
||||
Q "T-200"
|
||||
GETEND() ; Get Ending Date Range
|
||||
I $$GET^XPAR("SYS","MD APPOINT END DATE",1)>1 Q "T+"_$$GET^XPAR("SYS","MD APPOINT END DATE",1)
|
||||
Q "T"
|
||||
LOGSEC ; [Procedure] Log Security
|
||||
N RES
|
||||
D NOTICE^DGSEC4(.RES,DFN,DATA,1)
|
||||
S @RESULTS@(0)=$S(+RES:"1^Logged",1:"-1^Unable to log")
|
||||
Q
|
||||
;
|
||||
RPC(RESULTS,OPTION,DFN,DATA) ; [Procedure] Main RPC call tag
|
||||
NEW DFNIENS,GMRAL,GMVALG,GN,IENS,MDDFN,MDERR,MDFDA,MDFLD,MDHL7,MDID,MDIDS,MDIEN,MDIENS,MDRET,MDX,MDY,VA,VADM,VAERR,VAIN,Z
|
||||
S RESULTS=$NA(^TMP($J)) K @RESULTS
|
||||
D:$T(@OPTION)]"" @OPTION
|
||||
D:'$D(@RESULTS) BADRPC^MDRPCU("MD TMDPATIENT","MDRPCOP",OPTION)
|
||||
D CLEAN^DILF
|
||||
Q
|
||||
;
|
||||
SELECT ; [Procedure] Select patient
|
||||
; Moved to continuation routine at MD*1.0*6 due to routine size
|
||||
D SELECT^MDRPCOP1
|
||||
Q
|
||||
;
|
||||
X2FM(X) ; [Function] return FM date given relative date
|
||||
N %DT S %DT="TS" D ^%DT
|
||||
Q Y
|
||||
;
|
||||
MDRPCOP ; HOIFO/DP - Object RPCs (TMDPatient) ; [01-09-2003 15:21]
|
||||
;;1.0;CLINICAL PROCEDURES;**4**;Apr 01, 2004;Build 3
|
||||
; Integration Agreements:
|
||||
; IA# 3027 [Supported] Calls to DGSEC4
|
||||
; IA# 2981 [Subscription] Calls to GUI~GMRCP5
|
||||
; IA# 2548 [Supported] ACRP Interface Toolkit APIs.
|
||||
; IA# 2552 [Supported] AIT API to provide outpatient encounter data.
|
||||
; IA# 10061 [Supported] VADPT calls.
|
||||
; IA# 3468 [Subscription] Use GMRCCP APIs.
|
||||
; IA# 3266 [Subscription] Call to DPTLK1
|
||||
; IA# 10103 [Supported] Call to XLFDT
|
||||
; IA# 10039 [Supported] Ward Location File (#42) Access.
|
||||
; IA# 10035 [Supported] DPT references
|
||||
; IA# 3267 [Subscription] Call to DPTLK1
|
||||
; IA# 3593 [Supported] Access to routine DPTLK6 utilities for lookup
|
||||
; IA# 3613 [Private] GETVST^MDRPCOP API call
|
||||
; IA# 10099 [Supported] GMRADPT call
|
||||
; IA# 1096 [Controlled Subscription] ^DGPM("ATID1" x-ref loop
|
||||
;
|
||||
ADD(X) ; [Procedure] Add line to @RESULTS@(...
|
||||
S @RESULTS@(+$O(@RESULTS@(""),-1)+1)=X
|
||||
Q
|
||||
;
|
||||
ALLERGY ; [Procedure] Return Allergies
|
||||
D EN1^GMRADPT I '$O(GMRAL(0)) D Q
|
||||
.I $G(GMRAL)="" S @RESULTS@(0)="No Allergy Assessment"
|
||||
.I $G(GMRAL)=0 S @RESULTS@(0)="No Known Allergies"
|
||||
S @RESULTS@(0)="This patient has the following allergy(ies): "
|
||||
F X=0:0 S X=$O(GMRAL(X)) Q:'X D
|
||||
.S @RESULTS@(X)=$P($G(GMRAL(X)),U,2)
|
||||
Q
|
||||
;
|
||||
CHKIN ; [Procedure] Check In Study
|
||||
F X=2:1:5 D
|
||||
.I $P(DATA,U,X)]"" S MDFDA(702,$P(DATA,U,1),$P("^.04^.05^.11^.07",U,X))=$P(DATA,U,X)
|
||||
S MDFDA(702,$P(DATA,U,1),.09)=4 ; Status = Checked-In
|
||||
I $P(DATA,U,1)="+1," D
|
||||
.S MDFDA(702,"+1,",.01)=DFN
|
||||
.S MDFDA(702,"+1,",.02)=$$NOW^XLFDT()
|
||||
.S MDFDA(702,"+1,",.03)=DUZ
|
||||
.D UPDATE^DIE("","MDFDA","MDIEN","MDERR") Q:$D(MDERR)
|
||||
.S MDIENS=MDIEN(1)_",",MDHL7=$$SUB^MDHL7B(MDIEN(1))
|
||||
.I +MDHL7=-1 S MDFDA(702,MDIENS,.09)=2,MDFDA(702,MDIENS,.08)=$P(MDHL7,U,2)
|
||||
.I +MDHL7=1 S MDFDA(702,MDIENS,.09)=5,MDFDA(702,MDIENS,.08)=""
|
||||
.D:$D(MDFDA) FILE^DIE("","MDFDA","MDERR")
|
||||
I $P(DATA,U,1)'="+1," D
|
||||
.D FILE^DIE("","MDFDA","MDERR") Q:$D(MDERR)
|
||||
.S MDIENS=+DATA_","
|
||||
.S MDHL7=$$SUB^MDHL7B(+MDIENS)
|
||||
.I +MDHL7=-1 S MDFDA(702,MDIENS,.09)=2,MDFDA(702,MDIENS,.08)=$P(MDHL7,U,2)
|
||||
.I +MDHL7=1 S MDFDA(702,MDIENS,.09)=5,MDFDA(702,MDIENS,.08)=""
|
||||
.D:$D(MDFDA) FILE^DIE("","MDFDA","MDERR")
|
||||
I '$D(MDERR) S @RESULTS@(0)="1^OK" Q
|
||||
D ERROR^MDRPCU(RESULTS,.MDERR)
|
||||
Q
|
||||
;
|
||||
DISPCON ; [Procedure] Display a consult
|
||||
K ^TMP("GMRC",$J)
|
||||
D GUI^GMRCP5(.RESULTS,DATA)
|
||||
Q
|
||||
;
|
||||
GETCONS ; [Procedure] Get available consults for patient
|
||||
K ^TMP("MDTMP",$J)
|
||||
D CPLIST^GMRCCP(DFN,,$NA(^TMP("MDTMP",$J)))
|
||||
S MDX=0
|
||||
F S MDX=$O(^TMP("MDTMP",$J,MDX)) Q:'MDX D:"saprc"[$P(^(MDX),U,4)
|
||||
.S Y="123;"_$P(^TMP("MDTMP",$J,MDX),U,5)
|
||||
.F X=2,3,4,1,6,5 S Y=Y_U_$P(^TMP("MDTMP",$J,MDX),U,X)
|
||||
.S Y=Y_U_+$O(^MDD(702,"ACON",+$P(^TMP("MDTMP",$J,MDX),U,5)))
|
||||
.;
|
||||
.; Patch MD*1.0*4 - Return number of times checked in at piece 9
|
||||
.;
|
||||
.S (X,Z)=0,MDY=+$P(^TMP("MDTMP",$J,MDX),U,5)
|
||||
.F S X=$O(^MDD(702,"ACON",MDY,X)) Q:'X S Z=Z+1
|
||||
.S $P(Y,U,9)=Z
|
||||
.;
|
||||
.; End Patch MD*1.0*4
|
||||
.;
|
||||
.D ADD(Y)
|
||||
S @RESULTS@(0)=+$O(@RESULTS@(""),-1)
|
||||
K ^TMP("MDTMP",$J)
|
||||
Q
|
||||
;
|
||||
GETHDR ; [Procedure] Get Pt Header
|
||||
S DFNIENS=DFN_","
|
||||
S @RESULTS@(0)=$$GET1^DIQ(2,DFNIENS,.01)_" "_$$GET1^DIQ(2,DFNIENS,.1)_" "_$$GET1^DIQ(2,DFNIENS,.101)
|
||||
S @RESULTS@(1)=$$GET1^DIQ(2,DFNIENS,.09)_" "_$$GET1^DIQ(2,DFNIENS,.02)_" "_$$GET1^DIQ(2,DFNIENS,.03)_" ("_$$GET1^DIQ(2,DFNIENS,.033)_")"
|
||||
Q
|
||||
;
|
||||
GETOBJ ; [Procedure] Get information for TMDPATIENT object
|
||||
D DEM^VADPT,INP^VADPT
|
||||
S @RESULTS@(0)=DFN
|
||||
S @RESULTS@(1)=VADM(1)
|
||||
S @RESULTS@(2)=$P(VADM(2),U,2)
|
||||
S @RESULTS@(3)=$P(VADM(3),U,2)
|
||||
S @RESULTS@(4)=VADM(4)
|
||||
S @RESULTS@(5)=$P(VADM(5),U,2)
|
||||
I VAIN(4)]"" S @RESULTS@(6)="Ward: "_$P(VAIN(4),U,2)_" Rm: "_VAIN(5)
|
||||
E S @RESULTS@(6)=""
|
||||
Q
|
||||
;
|
||||
GETRES ; [Procedure] Get results report
|
||||
F MDX=0:0 S MDX=$O(^MDD(703.1,"ADFN",DFN,MDX)) Q:'MDX D
|
||||
.S MDINST=+$P($G(^MDD(703.1,MDX,0)),U,4)
|
||||
.I $G(DATA) Q:'$D(^MDS(702.01,DATA,.1,"B",MDINST))
|
||||
.S MDY=$O(@RESULTS@(""),-1)+1
|
||||
.S @RESULTS@(MDY)="703.1;"_MDX_U_^MDD(703.1,MDX,0)
|
||||
.S Y=$P(^MDD(703.1,MDX,0),U,3) D D^DIQ
|
||||
.S $P(@RESULTS@(MDY),U,11)=Y
|
||||
.S Y=$P($G(^MDS(702.09,+$P(^MDD(703.1,MDX,0),U,4),0)),U)
|
||||
.S $P(@RESULTS@(MDY),U,12)=Y
|
||||
S @RESULTS@(0)=+$O(@RESULTS@(""),-1)
|
||||
Q
|
||||
;
|
||||
GETTRAN ; [Procedure] Get a patients transactions
|
||||
F MDX=0:0 S MDX=$O(^MDD(702,"B",DFN,+MDX))_"," Q:'MDX D
|
||||
.S Z=$$GET1^DIQ(702,MDX,".04:.02","I")_U_$$GET1^DIQ(702,MDX,.04)_U_$$GET1^DIQ(702,MDX,.02,"I")_U_$$GET1^DIQ(702,MDX,.09)_U_$$GET1^DIQ(702,MDX,.11)_U_$$GET1^DIQ(702,MDX,.991)
|
||||
.S Y=$O(@RESULTS@(""),-1)+1
|
||||
.S @RESULTS@(Y)="702;"_+MDX_U_Z
|
||||
S @RESULTS@(0)=+$O(@RESULTS@(""),-1)
|
||||
Q
|
||||
;
|
||||
GETVST ; [Procedure] Return list of visits
|
||||
N BEG,END,VAERR,VASD,BDT,DTM,EDT,LOC,NOW,MDQUERY,MDLST,STI,STS,TODAY,I,J,K,XI,XE,X
|
||||
S NOW=$$NOW^XLFDT(),TODAY=$P(NOW,".",1)
|
||||
S BEG=$$X2FM("T-200"),END=$$X2FM("T")+0.2359
|
||||
S MDLST="",MDSTOP=""
|
||||
I END>NOW D ; get future encounters, past cancels/no-shows from VADPT
|
||||
.S VASD("F")=BEG
|
||||
.S VASD("T")=END
|
||||
.S VASD("W")="123456789"
|
||||
.D SDA^VADPT
|
||||
.S I=0 F S I=$O(^UTILITY("VASD",$J,I)) Q:'I D
|
||||
..S XI=^UTILITY("VASD",$J,I,"I"),XE=^("E")
|
||||
..S DTM=$P(XI,U),IEN=$P(XI,U,2),STI=$P(XI,U,3)
|
||||
..S LOC=$P(XE,U,2),STS=$P(XE,U,3)
|
||||
..I DTM<TODAY,(STI=""!(STI["I")!(STI="NT")) Q ; no prior kept appts
|
||||
..S MDLST(DTM,"A",1)="A;"_DTM_";"_IEN_U_DTM_U_LOC_U_STS
|
||||
.K ^UTILITY("VASD",$J)
|
||||
I BEG'>NOW D ;past encounters from ACRP Toolkit - set in CALLBACK
|
||||
.S BDT=BEG
|
||||
.S EDT=$S(END<NOW:END,1:NOW)
|
||||
.D OPEN^SDQ(.MDQUERY)
|
||||
.I '$$ERRCHK^SDQUT() D INDEX^SDQ(.MDQUERY,"PATIENT/DATE","SET")
|
||||
.I '$$ERRCHK^SDQUT() D PAT^SDQ(.MDQUERY,DFN,"SET")
|
||||
.I '$$ERRCHK^SDQUT() D DATE^SDQ(.MDQUERY,BDT,EDT,"SET")
|
||||
.I '$$ERRCHK^SDQUT() D
|
||||
..D SCANCB^SDQ(.MDQUERY,"D CALLBACK^ORWCV(Y,Y0,$NA(MDLST),.MDSTOP)","SET")
|
||||
.I '$$ERRCHK^SDQUT() D ACTIVE^SDQ(.MDQUERY,"TRUE","SET")
|
||||
.I '$$ERRCHK^SDQUT() D SCAN^SDQ(.MDQUERY,"FORWARD")
|
||||
.D CLOSE^SDQ(.MDQUERY)
|
||||
N TIM,MOV,MDX0,Y,MTIM,XTYP,XLOC,XLOCI,HLOC,EARLY,DONE ; admits
|
||||
S EARLY=BEG,DONE=0
|
||||
S TIM="" F S TIM=$O(^DGPM("ATID1",DFN,TIM)) Q:TIM'>0 D Q:DONE
|
||||
.S MOV=0 F S MOV=$O(^DGPM("ATID1",DFN,TIM,MOV)) Q:MOV'>0 D Q:DONE
|
||||
..D GETS^DIQ(405,+MOV_",","*","IE","MDX0") S MTIM=$G(MDX0(405,MOV_",",".01","I"))
|
||||
..S XTYP=$G(MDX0(405,+MOV_",",".04","E"))
|
||||
..S XLOC=$G(MDX0(405,+MOV_",",".06","E"))
|
||||
..S XLOCI=+$G(MDX0(405,+MOV_",",".06","I")),HLOC=+$G(^DIC(42,+XLOCI,44))
|
||||
..S MDLST(MTIM,"I",1)="I;"_MTIM_";"_HLOC_U_MTIM_U_"Inpatient Stay"_U_XLOC_U_XTYP
|
||||
..S DONE=1 ; Not sure if I should include all stays <DRP@Hines>
|
||||
S I=0 F S I=$O(MDLST(I)) Q:'I D
|
||||
.S J="" F S J=$O(MDLST(I,J)) Q:J="" D
|
||||
..S K=0 F S K=$O(MDLST(I,J,K)) Q:'K D
|
||||
...S @RESULTS@($O(@RESULTS@(""),-1)+1)=MDLST(I,J,K)
|
||||
S @RESULTS@(0)=+$O(@RESULTS@(""),-1)_U_($$GET1^DIQ(2,DFN_",",.1)]"")
|
||||
Q
|
||||
;
|
||||
LOGSEC ; [Procedure] Log Security
|
||||
D NOTICE^DGSEC4(.RESULTS,DFN,DATA,1)
|
||||
S @RESULTS@(0)=$S(RESULTS:"1^Logged",1:"-1^Unable to log")
|
||||
Q
|
||||
;
|
||||
RPC(RESULTS,OPTION,DFN,DATA) ; [Procedure] Main RPC call tag
|
||||
NEW DFNIENS,GMRAL,GMVALG,GN,IENS,MDDFN,MDERR,MDFDA,MDFLD,MDHL7,MDID,MDIDS,MDIEN,MDIENS,MDRET,MDX,MDY,VA,VADM,VAERR,VAIN,Z
|
||||
S RESULTS=$NA(^TMP($J)) K @RESULTS
|
||||
D:$T(@OPTION)]"" @OPTION
|
||||
D:'$D(@RESULTS) BADRPC^MDRPCU("MD TMDPATIENT","MDRPCOP",OPTION)
|
||||
D CLEAN^DILF
|
||||
Q
|
||||
;
|
||||
SELECT ; [Procedure] Select patient
|
||||
I '$D(^DPT(+$G(DFN),0))#2 S @RESULTS@(0)="-1^No such patient" Q
|
||||
S @RESULTS@(0)="1^Required Identifiers & messages"
|
||||
S IENS=DFN_","
|
||||
D FILE^DID(2,,"REQUIRED IDENTIFIERS","MDIDS")
|
||||
F MDX=0:0 S MDX=$O(MDIDS("REQUIRED IDENTIFIERS",MDX)) Q:'MDX D
|
||||
.S MDFLD=MDIDS("REQUIRED IDENTIFIERS",MDX,"FIELD")
|
||||
.S MDID="$$PTID^"_$$GET1^DID(2,MDFLD,"","LABEL")
|
||||
.S MDID=MDID_U_$$GET1^DIQ(2,IENS,MDFLD)
|
||||
.D:MDFLD=.03
|
||||
..S MDID=MDID_" ("_$$GET1^DIQ(2,IENS,.033)_")"
|
||||
..S MDID=MDID_U_$$DOB^DPTLK1(+IENS)
|
||||
.D:MDFLD=.09
|
||||
..S X=$P(MDID,U,3),X=$E(X,1,3)_"-"_$E(X,4,5)_"-"_$E(X,6,10)
|
||||
..S $P(MDID,U,3)=X,$P(MDID,U,4)=$$SSN^DPTLK1(+IENS)
|
||||
.S @RESULTS@($O(@RESULTS@(""),-1)+1)=MDID
|
||||
S MDID="$$PTID^"_$$GET1^DID(2,.1,"","LABEL")
|
||||
S MDID=MDID_U_$$GET1^DIQ(2,IENS,.1)
|
||||
S @RESULTS@($O(@RESULTS@(""),-1)+1)=MDID
|
||||
S MDID="$$PTID^"_$$GET1^DID(2,.101,"","LABEL")
|
||||
S MDID=MDID_U_$$GET1^DIQ(2,IENS,.101)
|
||||
S @RESULTS@($O(@RESULTS@(""),-1)+1)=MDID
|
||||
K MDRET
|
||||
D GUIBS5A^DPTLK6(.MDRET,DFN) D:MDRET(1)=1
|
||||
.D ADD("$$MSGHDR^2^SAME LAST NAME AND LAST 4")
|
||||
.S MDX=1
|
||||
.F S MDX=$O(MDRET(MDX)) Q:'MDX!(+$G(MDRET(MDX))) D
|
||||
..D ADD($P(MDRET(MDX),U,2))
|
||||
.D ADD(" ")
|
||||
.S MDX=1
|
||||
.F S MDX=$O(MDRET(MDX)) Q:'MDX D:+MDRET(MDX)
|
||||
..S MDDFN=+$P(MDRET(MDX),U,2)
|
||||
..D ADD($$GET1^DIQ(2,MDDFN_",",.01)_" "_$$DOB^DPTLK1(MDDFN)_" "_$$SSN^DPTLK1(MDDFN))
|
||||
.D ADD(" ")
|
||||
.D ADD("Please review carefully before continuing")
|
||||
.D ADD("$$MSGEND")
|
||||
K MDRET
|
||||
D PTSEC^DGSEC4(.MDRET,DFN) D:MDRET(1)'=0
|
||||
.D:MDRET(1)=3
|
||||
..D ADD("$$MSGHDR^0^CAN'T ACCESS YOUR OWN RECORD!!")
|
||||
.D:MDRET(1)=-1
|
||||
..D ADD("$$MSGHDR^0^INCOMPLETE INFORMATION - CAN'T PROCEED")
|
||||
.D:MDRET(1)=1
|
||||
..D ADD("$$MSGHDR^1^SENSITIVE RECORD ACCESS")
|
||||
.D:MDRET(1)'=-1&(MDRET(1)'=3)&(MDRET(1)'=1)
|
||||
..D ADD("$$MSGHDR^3^SENSITIVE RECORD ACCESS")
|
||||
.S MDX=1
|
||||
.F S MDX=$O(MDRET(MDX)) Q:'MDX D ADD($TR(MDRET(MDX),"*"," "))
|
||||
.D ADD("$$MSGEND")
|
||||
D GUIMTD^DPTLK6(.MDRET,DFN) D:MDRET(1)=1
|
||||
.D ADD("$$MSGHDR^1^NOTICE")
|
||||
.F MDX=1:0 S MDX=$O(MDRET(MDX)) Q:'MDX D ADD(MDRET(MDX))
|
||||
.D ADD("$$MSGEND")
|
||||
Q
|
||||
;
|
||||
X2FM(X) ; [Function] return FM date given relative date
|
||||
N %DT S %DT="TS" D ^%DT
|
||||
Q Y
|
||||
;
|
||||
|
|
|
|||
|
|
@ -1,232 +1,219 @@
|
|||
MDRPCOT ; HOIFO/DP/NCA - Object RPCs (TMDTransaction) ;3/12/08 09:18
|
||||
;;1.0;CLINICAL PROCEDURES;**5,6**;Apr 01, 2004;Build 102
|
||||
; Integration Agreements:
|
||||
; IA# 2693 [Subscription] TIU Extractions.
|
||||
; IA# 2944 [Subscription] Calls to TIUSRVR1.
|
||||
; IA# 3535 [Subscription] Calls to TIUSRVP.
|
||||
; IA# 10104 [Supported] Routine XLFSTR calls
|
||||
ADDMSG ; [Procedure] Add message to transaction
|
||||
N MDIEN,MDIENS,MDRET
|
||||
Q:'$G(DATA("TRANSACTION"))
|
||||
Q:$G(DATA("MESSAGE"))=""
|
||||
S MDIEN=+DATA("TRANSACTION"),MDIENS="+1,"_MDIEN_","
|
||||
D NOW^%DTC S DATA("DATE")=% K %
|
||||
S MDFDA(702.091,MDIENS,.01)=+$O(^MDD(702,+MDIEN,.091,"A"),-1)+1
|
||||
S MDFDA(702.091,MDIENS,.02)=DATA("DATE")
|
||||
S MDFDA(702.091,MDIENS,.03)=$G(DATA("PKG"),"UNKNOWN")
|
||||
S MDFDA(702.091,MDIENS,.09)=DATA("MESSAGE")
|
||||
D UPDATE^DIE("","MDFDA","MDRET")
|
||||
Q
|
||||
;
|
||||
DELETE ; [Procedure] Delete Study
|
||||
; Sets @RESULTS@(0)="-1^Reason for not deleting" or "1^Study Deleted"
|
||||
;
|
||||
N MDAST,MDHOLD,MDNOTE,MDRES,MDSIEN,BODY,SUBJECT,DEVIEN
|
||||
S (MDHOLD,MDSIEN)=+DATA,MDRES=0,MDNOTE=""
|
||||
D ALERT^MDHL7U3(MDSIEN) ; Builds the body of the mail message
|
||||
I $G(^MDD(702,+MDSIEN,0))="" S @RESULTS@(0)="1^Study Deleted." D NOTICE^MDHL7U3(SUBJECT,.BODY,DEVIEN,DUZ) Q ;deleting message
|
||||
S:+$P(^MDD(702,MDSIEN,0),U,6) MDNOTE=$P(^MDD(702,MDSIEN,0),U,6)
|
||||
I "13"[$P(^MDD(702,MDSIEN,0),U,9) S @RESULTS@(0)="-1^Can't Delete TIU Note from a "_$$GET1^DIQ(702,MDSIEN,.09,"E")_" Study." Q
|
||||
I "5"[$P(^MDD(702,MDSIEN,0),U,9) S MDCANR=$$CANCEL^MDHL7B(MDHOLD) I MDCANR<1 S @RESULTS@(0)="-1^"_$P(MDCANR,"^",2) Q
|
||||
I +MDNOTE S MDRES="" D DELETE^TIUSRVP(.MDRES,MDNOTE)
|
||||
I MDRES D Q
|
||||
.D STATUS(MDSIEN_",",2,$P(MDRES,"^",2))
|
||||
.S DATA("TRANSACTION")=MDSIEN,DATA("PKG")="TIU"
|
||||
.S DATA("MESSAGE")=$P(MDRES,"^",2) D ADDMSG
|
||||
.S @RESULTS@(0)="-1^"_$P(MDRES,"^",2)
|
||||
.Q
|
||||
E D
|
||||
.I $D(^MDD(702.001,"ASTUDY",MDSIEN)) S @RESULTS@(0)="-1^Note associated with study, can not delete." Q
|
||||
.S MDAST=$$HL7CHK^MDHL7U3(+MDSIEN) I +MDAST<1 S @RESULTS@(0)=MDAST Q
|
||||
.D NOTICE^MDHL7U3(SUBJECT,.BODY,DEVIEN,DUZ) ; delete message
|
||||
.S MDFDA(702,DATA_",",.01)=""
|
||||
.; Check for renal study to delete as well
|
||||
.S:$D(^MDK(704.202,DATA)) MDFDA(704.202,DATA_",",.01)=""
|
||||
.D FILE^DIE("","MDFDA")
|
||||
.N DA,DIK S DA=+MDSIEN,DIK="^MDD(702," D ^DIK
|
||||
.S @RESULTS@(0)="1^Study Deleted."
|
||||
.Q
|
||||
Q
|
||||
;
|
||||
FILEMSG(STUDY,MDPKG,MDSTAT,MDMSG) ; [Procedure] File Study Status and Message.
|
||||
S DATA("TRANSACTION")=STUDY,DATA("PKG")=MDPKG
|
||||
S DATA("MESSAGE")=$P(MDMSG,"^",2)
|
||||
D STATUS(STUDY_",",MDSTAT,$P(MDMSG,"^",2)),ADDMSG
|
||||
Q
|
||||
;
|
||||
FILES ; [Procedure] Add/remove an attachment to this transaction
|
||||
NEW MDFDA,MDIEN,MDIENS,MDRET,P1,P2,P3,P4
|
||||
S P1=$P(DATA,U,1),P2=$P(DATA,U,2),P3=$P(DATA,U,3),P4=$P(DATA,U,4)
|
||||
S MDIEN=0 I $G(^MDD(702,+P1,0))="" Q
|
||||
; Look for file (All comparisons done on lower case values)
|
||||
F S MDIEN=$O(^MDD(702,P1,.1,MDIEN)) Q:'MDIEN D Q:X=P3
|
||||
.S X=$$LOW^XLFSTR($G(^MDD(702,P1,.1,MDIEN,.1)))
|
||||
I MDIEN&P4 S @RESULTS@(0)="1^File already assigned" Q
|
||||
I 'MDIEN&'P4 S @RESULTS@(0)="1^File not assigned" Q
|
||||
I P4 D Q ; Add a file
|
||||
.S MDIENS="+1,"_P1_","
|
||||
.S MDFDA(702.1,MDIENS,.01)=$O(^MDD(702,P1,.1,"B",""),-1)+1
|
||||
.S MDFDA(702.1,MDIENS,.02)=$S(P2:"I",1:"U")
|
||||
.I P2 S MDFDA(702.1,MDIENS,.03)=P2
|
||||
.S MDFDA(702.1,MDIENS,.1)=P3
|
||||
.D UPDATE^DIE("","MDFDA","MDIEN")
|
||||
.S @RESULTS@(0)=+$G(MDIEN(1),-1)
|
||||
I 'P4 D Q ; Remove the file
|
||||
.S MDFDA(702.1,MDIEN_","_P1_",",.01)="@"
|
||||
.D FILE^DIE("","MDFDA","MDRET")
|
||||
.S @RESULTS@(0)=$S($D(MDRET):-1,1:1)
|
||||
Q
|
||||
;
|
||||
GETATT ; [Procedure] Get Attachments
|
||||
F X=0:0 S X=$O(^MDD(702,DATA,.1,X)) Q:'X D
|
||||
.S Y=$O(@RESULTS@(""),-1)+1
|
||||
.S @RESULTS@(Y)=$P(^MDD(702,DATA,.1,X,0),U,1,3)
|
||||
.S $P(@RESULTS@(Y),U,4)=$G(^MDD(702,DATA,.1,X,.1))
|
||||
S @RESULTS@(0)=+$O(@RESULTS@(""),-1)
|
||||
Q
|
||||
;
|
||||
GETERR ; [Procedure] Return list of Imaging Errors
|
||||
; DATA = Transaction IEN
|
||||
F MDX=0:0 S MDX=$O(^MDD(702,DATA,.091,MDX)) Q:'MDX D
|
||||
.S MDY=+^MDD(702,DATA,.091,MDX,0)_U,Y=$P(^(0),U,2)
|
||||
.D D^DIQ S MDY=MDY_Y_U
|
||||
.S MDY=MDY_$P(^MDD(702,DATA,.091,MDX,0),U,3)_U_$P(^(0),U,9)
|
||||
.S ^TMP($J,$O(^TMP($J,""),-1)+1)=MDY
|
||||
S ^TMP($J,0)=+$O(^TMP($J,""),-1)
|
||||
Q
|
||||
;
|
||||
NEWSTAT ; [Procedure] RPC Call to set status
|
||||
S MDFDA(702,DATA,.09)=TYPE
|
||||
D FILE^DIE("","MDFDA")
|
||||
I TYPE=3&($G(^MDK(704.202,+DATA,0))'="") K MDFDA S MDFDA(704.202,DATA,.09)=0 D FILE^DIE("","MDFDA") K MDFDA
|
||||
Q
|
||||
;
|
||||
RPC(RESULTS,OPTION,DATA,TYPE,FILE,RESREP) ; [Procedure] Main RPC call
|
||||
N MDCANR,MDCON,MDDOC,MDFDA,MDFN,MDGST,MDHOLD,MDIEN,MDIENS,MDL,MDLOC,MDMSG,MDNEWV,MDNOTE,MDNVST,MDPDT,MDPKG,MDPROC,MDRES,MDRESU,MDRESUL,MDRET,MDS,MDSIEN,MDSTAT,MDSTUDY,MDTITL,MDTIUER,MDTRAN,MDTST,MDTSTR,MDVST,MDVSTR,MDWP,MDX,MDY
|
||||
S RESULTS=$NA(^TMP($J)) K @RESULTS
|
||||
D:$T(@OPTION)]"" @OPTION
|
||||
D:'$D(@RESULTS) BADRPC^MDRPCU("MD TMDTRANSACTION","MDRPCOT",OPTION)
|
||||
D CLEAN^DILF
|
||||
Q
|
||||
;
|
||||
STATUS(MDIENS,MDSTAT,MDMSG) ; [Procedure] Update transaction status
|
||||
S MDFDA(702,MDIENS,.08)=$G(MDMSG)
|
||||
S MDFDA(702,MDIENS,.09)=MDSTAT
|
||||
D FILE^DIE("","MDFDA")
|
||||
Q
|
||||
;
|
||||
SUBMIT ; [Procedure] Process the Image(s) Submission.
|
||||
; Output: -1^Error Message or
|
||||
; 1^Successful Message
|
||||
N MDRESUL,MDSTUDY
|
||||
S MDSTUDY=+DATA,MDRESUL=""
|
||||
; Create New TIU Document
|
||||
S MDRESUL=$$NEWTIUN(MDSTUDY)
|
||||
; File TIU Error messages
|
||||
I +MDRESUL<0 D Q
|
||||
.D FILEMSG(MDSTUDY,"TIU",2,MDRESUL)
|
||||
.S @RESULTS@(0)=MDRESUL
|
||||
; Submit and export the images
|
||||
S MDRESUL=$$SUBMIT^MDRPCOT1(MDSTUDY)
|
||||
; File message
|
||||
D FILEMSG(MDSTUDY,"IMAGING",$S(+MDRESUL>0:+MDRESUL,1:2),MDRESUL)
|
||||
S @RESULTS@(0)=MDRESUL
|
||||
Q
|
||||
;
|
||||
VIEWTIU ; [Procedure] VIew the associated tiu document
|
||||
I '$P(^MDD(702,+DATA,0),U,6) D Q
|
||||
.S @RESULTS@(0)="NO TIU NOTE FOR THIS STUDY"
|
||||
D TGET^TIUSRVR1(.RESULTS,+$P(^MDD(702,+DATA,0),U,6))
|
||||
Q
|
||||
;
|
||||
GETDATA(STUDY) ; [Function] Return the Necessary data for creating a TIU note.
|
||||
; Return: Patient DFN_"^"_TIU title_"^"_Hospital Location_"^"_TIU Note
|
||||
; IEN_"^"_Consult #_"^"_CP Definition IEN_"^"_Visit String_"^"
|
||||
; New Visit Flag
|
||||
; or
|
||||
; -1^Error Message
|
||||
N DFN,MDCON,MDFN,MDIEN,MDIENS,MDLOC,MDNEWV,MDNOTE,MDNVST,MDPROC,MDVSTR,MDTITL,MDX,MDTST
|
||||
S MDIEN=+STUDY,MDIENS=MDIEN_",",MDNVST=0
|
||||
I $$GET1^DIQ(702,MDIENS,.01)="" Q "-1^No such study entry."
|
||||
; Get DFN
|
||||
S DFN=$$GET1^DIQ(702,MDIEN,.01,"I")
|
||||
I 'DFN Q "-1^No DFN."
|
||||
; Get CP Def
|
||||
S MDPROC=$$GET1^DIQ(702,MDIEN,.04,"I")
|
||||
I 'MDPROC Q "-1^No CP Def."
|
||||
; Get Consult
|
||||
S MDCON=$$GET1^DIQ(702,MDIEN,.05,"I")
|
||||
I 'MDCON Q "-1^No Consult #."
|
||||
; Get TIU Note Title
|
||||
S MDTITL=$$GET1^DIQ(702.01,+MDPROC_",",.04,"I")
|
||||
I 'MDTITL Q "-1^No TIU Note Title."
|
||||
S MDVSTR=$$GET1^DIQ(702,MDIEN,.07)
|
||||
I MDVSTR="" Q "-1^No Visit String."
|
||||
I $L(MDVSTR,";")=1 S MDNVST=1,MDVSTR=";"_MDVSTR ; If new visit is selected
|
||||
; MDLOC is Hospital Location
|
||||
I MDVSTR'="" D
|
||||
.S MDVSTR=$$GETVSTR^MDRPCOT1(DFN,MDVSTR,MDPROC,$$GET1^DIQ(702,MDIEN,.02,"I"))
|
||||
.S MDLOC=$P(MDVSTR,";",1)
|
||||
I $$GET1^DIQ(702.01,+MDPROC_",",.12,"I")=1 Q DFN_"^"_MDTITL_"^"_MDLOC_"^^"_MDCON_"^"_MDPROC_"^"_MDVSTR_"^"_MDNVST
|
||||
; Does TIU doc already exist?
|
||||
I $$GET1^DIQ(702,MDIEN,.06,"I") Q DFN_"^"_MDTITL_"^"_MDLOC_"^"_+$$GET1^DIQ(702,MDIEN,.06,"I")_"^"_MDCON_"^"_MDPROC_"^"_MDVSTR_"^"_MDNVST
|
||||
; Does TIU doc exist for previous transaction of this consult?
|
||||
I MDCON S MDNOTE=$$PREV(MDCON,MDIEN)
|
||||
Q DFN_"^"_MDTITL_"^"_MDLOC_"^"_+MDNOTE_"^"_MDCON_"^"_MDPROC_"^"_MDVSTR_"^"_MDNVST
|
||||
;
|
||||
NEWTIUN(STUDY) ; [Function] Create a new TIU for transaction
|
||||
; Input: STUDY - IENS of CP study entry
|
||||
; Return: TIU Document IEN
|
||||
N CTR,DFN,MDCON,MDFDA,MDGST,MDL,MDLOC,MDNOTE,MDPDT,MDPROC,MDRESU,MDTITL,MDTSTR,MDVST,MDVSTR,MDWP,MDPT S CTR=0,MDGST=+STUDY,MDRESU=""
|
||||
; Get data for TIU Note Creation
|
||||
S (MDTSTR,MDRESU)=$$GETDATA(MDGST)
|
||||
; File Error message
|
||||
I +MDRESU<0 D FILEMSG(MDGST,"CP",2,MDRESU) Q MDRESU
|
||||
I $G(MDTSTR)="" Q "-1^No Data to Create TIU Document"
|
||||
F MDL="DFN","MDTITL","MDLOC","MDNOTE","MDCON","MDPROC","MDVSTR","MDNVST" D
|
||||
.S CTR=CTR+1,@MDL=$P(MDTSTR,"^",CTR)
|
||||
S MDVST=""
|
||||
; If previous TIU document exists, quit
|
||||
I MDNOTE Q MDNOTE
|
||||
I 'MDLOC Q "-1^No Hospital Location."
|
||||
; Create new visit, if no vstring
|
||||
S MDPDT=$$PDT^MDRPCOT1(MDGST)
|
||||
I 'MDPDT S MDPT=$O(^MDD(703.1,"ASTUDYID",+MDGST,0)),MDPDT=$P($G(^MDD(703.1,+MDPT,0)),U,3)
|
||||
S:'MDPDT MDPDT=$P(MDVSTR,";",2) ; If No D/T Performed grab visit D/T
|
||||
I $P(MDVSTR,";",3)="V" S $P(MDVSTR,";",3)="A"
|
||||
; Build variables for TIU Call
|
||||
S MDWP(.05)=1 ; Undicated Status
|
||||
S MDWP(1405)=+MDCON_";GMR(123," ; Package Reference
|
||||
S MDWP(70201)=5 ; Default Procedure Summary Code "Machine Resulted"
|
||||
I MDPDT S MDWP(70202)=MDPDT ; Date/Time Performed
|
||||
; File PCE Error message
|
||||
I MDNVST S MDRESU=$$EN1^MDPCE(MDGST,$P(MDVSTR,";",2),MDPROC,$P(MDVSTR,";",3),"P") I +MDRESU S MDVST=+MDRESU,MDVSTR=$P(MDRESU,"^",2)
|
||||
I MDNVST&(+MDRESU<0) D FILEMSG(MDGST,"PCE",2,$P(MDRESU,"^",2)) Q MDRESU
|
||||
; Create the TIU note stub
|
||||
S MDNOTE="" D MAKE^TIUSRVP(.MDNOTE,DFN,MDTITL,$P(MDVSTR,";",2),MDLOC,$S(MDVST:MDVST,1:""),.MDWP,MDVSTR,1,1)
|
||||
I '(+MDNOTE) S $P(MDNOTE,"^")=-1 Q MDNOTE
|
||||
; Finalize the transaction
|
||||
S MDFDA(702,STUDY_",",.06)=+MDNOTE
|
||||
S MDFDA(702,STUDY_",",.08)=""
|
||||
S:MDVST>0 MDFDA(702,STUDY_",",.13)=MDVST
|
||||
D FILE^DIE("","MDFDA")
|
||||
D UPD^MDKUTLR(STUDY,+MDNOTE)
|
||||
Q 1
|
||||
;
|
||||
PREV(MDC,MDS) ; [Function] Return the Previous TIU document.
|
||||
N MDNEWV,MDDOC,MDTRAN,MDTIUER,MDTST
|
||||
S (MDDOC,MDNEWV,MDTRAN,MDTIUER,MDTST)="" K ^TMP("MDTIUST",$J)
|
||||
F S MDTRAN=$O(^MDD(702,"ACON",MDC,MDTRAN)) Q:'MDTRAN D Q:'MDTRAN
|
||||
.I $P(^MDD(702,MDTRAN,0),U,6) D
|
||||
..D EXTRACT^TIULQ($P(^MDD(702,MDTRAN,0),U,6),"^TMP(""MDTIUST"",$J)",MDTIUER,".01;.05;1406") Q:+MDTIUER
|
||||
..S MDTST=$G(^TMP("MDTIUST",$J,$P(^MDD(702,MDTRAN,0),U,6),.05,"E"))
|
||||
..I MDTST'="UNDICTATED"&(MDTST'="UNSIGNED") K ^TMP("MDTIUST",$J) Q
|
||||
..I MDTST="UNSIGNED"&'($G(^TMP("MDTIUST",$J,$P(^MDD(702,MDTRAN,0),U,6),1406,"I"))) K ^TMP("MDTIUST",$J) Q
|
||||
..S MDDOC=$P(^MDD(702,MDTRAN,0),U,6),MDNEWV=$P(^MDD(702,MDTRAN,0),U,7)
|
||||
..Q:'MDS
|
||||
..S MDFDA(702,MDS_",",.06)=MDDOC
|
||||
..S MDFDA(702,MDS_",",.07)=MDNEWV
|
||||
..D FILE^DIE("","MDFDA")
|
||||
..S MDTRAN=""
|
||||
Q MDDOC
|
||||
;
|
||||
MDRPCOT ; HOIFO/DP/NCA - Object RPCs (TMDTransaction) ;12/5/02 15:33
|
||||
;;1.0;CLINICAL PROCEDURES;**5**;Apr 01, 2004;Build 1
|
||||
; Integration Agreements:
|
||||
; IA# 2693 [Subscription] TIU Extractions.
|
||||
; IA# 2944 [Subscription] Calls to TIUSRVR1.
|
||||
; IA# 3535 [Subscription] Calls to TIUSRVP.
|
||||
; IA# 10104 [Supported] Routine XLFSTR calls
|
||||
ADDMSG ; [Procedure] Add message to transaction
|
||||
N MDIEN,MDIENS,MDRET
|
||||
Q:'$G(DATA("TRANSACTION"))
|
||||
Q:$G(DATA("MESSAGE"))=""
|
||||
S MDIEN=+DATA("TRANSACTION"),MDIENS="+1,"_MDIEN_","
|
||||
D NOW^%DTC S DATA("DATE")=% K %
|
||||
S MDFDA(702.091,MDIENS,.01)=+$O(^MDD(702,+MDIEN,.091,"A"),-1)+1
|
||||
S MDFDA(702.091,MDIENS,.02)=DATA("DATE")
|
||||
S MDFDA(702.091,MDIENS,.03)=$G(DATA("PKG"),"UNKNOWN")
|
||||
S MDFDA(702.091,MDIENS,.09)=DATA("MESSAGE")
|
||||
D UPDATE^DIE("","MDFDA","MDRET")
|
||||
Q
|
||||
;
|
||||
DELETE ; [Procedure] Delete Study
|
||||
; Sets @RESULTS@(0)="-1^Reason for not deleting" or "1^Study Deleted"
|
||||
;
|
||||
N MDHOLD,MDNOTE,MDRES,MDSIEN
|
||||
S (MDHOLD,MDSIEN)=+DATA,MDRES=0,MDNOTE=""
|
||||
S:+$P(^MDD(702,MDSIEN,0),U,6) MDNOTE=$P(^MDD(702,MDSIEN,0),U,6)
|
||||
I "13"[$P(^MDD(702,MDSIEN,0),U,9) S @RESULTS@(0)="-1^Can't Delete TIU Note from a "_$$GET1^DIQ(702,MDSIEN,.09,"E")_" Study." Q
|
||||
I "5"[$P(^MDD(702,MDSIEN,0),U,9) S MDCANR=$$CANCEL^MDHL7B(MDHOLD) I MDCANR<1 S @RESULTS@(0)="-1^"_$P(MDCANR,"^",2) Q
|
||||
I +MDNOTE S MDRES="" D DELETE^TIUSRVP(.MDRES,MDNOTE)
|
||||
I MDRES D Q
|
||||
.D STATUS(MDSIEN_",",2,$P(MDRES,"^",2))
|
||||
.S DATA("TRANSACTION")=MDSIEN,DATA("PKG")="TIU"
|
||||
.S DATA("MESSAGE")=$P(MDRES,"^",2) D ADDMSG
|
||||
.S @RESULTS@(0)="-1^"_$P(MDRES,"^",2)
|
||||
.Q
|
||||
E D
|
||||
.S MDFDA(702,DATA_",",.01)=""
|
||||
.D FILE^DIE("","MDFDA")
|
||||
.N DA,DIK S DA=+MDSIEN,DIK="^MDD(702," D ^DIK
|
||||
.S @RESULTS@(0)="1^Study Deleted."
|
||||
.Q
|
||||
Q
|
||||
;
|
||||
FILEMSG(STUDY,MDPKG,MDSTAT,MDMSG) ; [Procedure] File Study Status and Message.
|
||||
S DATA("TRANSACTION")=STUDY,DATA("PKG")=MDPKG
|
||||
S DATA("MESSAGE")=$P(MDMSG,"^",2)
|
||||
D STATUS(STUDY_",",MDSTAT,$P(MDMSG,"^",2)),ADDMSG
|
||||
Q
|
||||
;
|
||||
FILES ; [Procedure] Add/remove an attachment to this transaction
|
||||
NEW MDFDA,MDIEN,MDIENS,MDRET,P1,P2,P3,P4
|
||||
S P1=$P(DATA,U,1),P2=$P(DATA,U,2),P3=$P(DATA,U,3),P4=$P(DATA,U,4)
|
||||
S MDIEN=0
|
||||
; Look for file (All comparisons done on lower case values)
|
||||
F S MDIEN=$O(^MDD(702,P1,.1,MDIEN)) Q:'MDIEN D Q:X=P3
|
||||
.S X=$$LOW^XLFSTR($G(^MDD(702,P1,.1,MDIEN,.1)))
|
||||
I MDIEN&P4 S @RESULTS@(0)="1^File already assigned" Q
|
||||
I 'MDIEN&'P4 S @RESULTS@(0)="1^File not assigned" Q
|
||||
I P4 D Q ; Add a file
|
||||
.S MDIENS="+1,"_P1_","
|
||||
.S MDFDA(702.1,MDIENS,.01)=$O(^MDD(702,P1,.1,"B",""),-1)+1
|
||||
.S MDFDA(702.1,MDIENS,.02)=$S(P2:"I",1:"U")
|
||||
.I P2 S MDFDA(702.1,MDIENS,.03)=P2
|
||||
.S MDFDA(702.1,MDIENS,.1)=P3
|
||||
.D UPDATE^DIE("","MDFDA","MDIEN")
|
||||
.S @RESULTS@(0)=+$G(MDIEN(1),-1)
|
||||
I 'P4 D Q ; Remove the file
|
||||
.S MDFDA(702.1,MDIEN_","_P1_",",.01)="@"
|
||||
.D FILE^DIE("","MDFDA","MDRET")
|
||||
.S @RESULTS@(0)=$S($D(MDRET):-1,1:1)
|
||||
Q
|
||||
;
|
||||
GETATT ; [Procedure] Get Attachments
|
||||
F X=0:0 S X=$O(^MDD(702,DATA,.1,X)) Q:'X D
|
||||
.S Y=$O(@RESULTS@(""),-1)+1
|
||||
.S @RESULTS@(Y)=$P(^MDD(702,DATA,.1,X,0),U,1,3)
|
||||
.S $P(@RESULTS@(Y),U,4)=$G(^MDD(702,DATA,.1,X,.1))
|
||||
S @RESULTS@(0)=+$O(@RESULTS@(""),-1)
|
||||
Q
|
||||
;
|
||||
GETERR ; [Procedure] Return list of Imaging Errors
|
||||
; DATA = Transaction IEN
|
||||
F MDX=0:0 S MDX=$O(^MDD(702,DATA,.091,MDX)) Q:'MDX D
|
||||
.S MDY=+^MDD(702,DATA,.091,MDX,0)_U,Y=$P(^(0),U,2)
|
||||
.D D^DIQ S MDY=MDY_Y_U
|
||||
.S MDY=MDY_$P(^MDD(702,DATA,.091,MDX,0),U,3)_U_$P(^(0),U,9)
|
||||
.S ^TMP($J,$O(^TMP($J,""),-1)+1)=MDY
|
||||
S ^TMP($J,0)=+$O(^TMP($J,""),-1)
|
||||
Q
|
||||
;
|
||||
NEWSTAT ; [Procedure] RPC Call to set status
|
||||
S MDFDA(702,DATA,.09)=TYPE
|
||||
D FILE^DIE("","MDFDA")
|
||||
Q
|
||||
;
|
||||
RPC(RESULTS,OPTION,DATA,TYPE,FILE,RESREP) ; [Procedure] Main RPC call
|
||||
N MDCANR,MDCON,MDDOC,MDFDA,MDFN,MDGST,MDHOLD,MDIEN,MDIENS,MDL,MDLOC,MDMSG,MDNEWV,MDNOTE,MDNVST,MDPDT,MDPKG,MDPROC,MDRES,MDRESU,MDRESUL,MDRET,MDS,MDSIEN,MDSTAT,MDSTUDY,MDTITL,MDTIUER,MDTRAN,MDTST,MDTSTR,MDVST,MDVSTR,MDWP,MDX,MDY
|
||||
S RESULTS=$NA(^TMP($J)) K @RESULTS
|
||||
D:$T(@OPTION)]"" @OPTION
|
||||
D:'$D(@RESULTS) BADRPC^MDRPCU("MD TMDTRANSACTION","MDRPCOT",OPTION)
|
||||
D CLEAN^DILF
|
||||
Q
|
||||
;
|
||||
STATUS(MDIENS,MDSTAT,MDMSG) ; [Procedure] Update transaction status
|
||||
S MDFDA(702,MDIENS,.08)=$G(MDMSG)
|
||||
S MDFDA(702,MDIENS,.09)=MDSTAT
|
||||
D FILE^DIE("","MDFDA")
|
||||
Q
|
||||
;
|
||||
SUBMIT ; [Procedure] Process the Image(s) Submission.
|
||||
; Output: -1^Error Message or
|
||||
; 1^Successful Message
|
||||
N MDRESUL,MDSTUDY
|
||||
S MDSTUDY=+DATA,MDRESUL=""
|
||||
; Create New TIU Document
|
||||
S MDRESUL=$$NEWTIUN(MDSTUDY)
|
||||
; File TIU Error messages
|
||||
;I +MDRESUL<0 D FILEMSG(MDSTUDY,"TIU",2,MDRESUL) Q MDRESUL
|
||||
I +MDRESUL<0 D Q
|
||||
.D FILEMSG(MDSTUDY,"TIU",2,MDRESUL)
|
||||
.S @RESULTS@(0)=MDRESUL
|
||||
; Submit and export the images
|
||||
S MDRESUL=$$SUBMIT^MDRPCOT1(MDSTUDY)
|
||||
; File message
|
||||
D FILEMSG(MDSTUDY,"IMAGING",$S(+MDRESUL>0:+MDRESUL,1:2),MDRESUL)
|
||||
S @RESULTS@(0)=MDRESUL
|
||||
Q
|
||||
;
|
||||
VIEWTIU ; [Procedure] VIew the associated tiu document
|
||||
I '$P(^MDD(702,+DATA,0),U,6) D Q
|
||||
.S @RESULTS@(0)="NO TIU NOTE FOR THIS STUDY"
|
||||
D TGET^TIUSRVR1(.RESULTS,+$P(^MDD(702,+DATA,0),U,6))
|
||||
Q
|
||||
;
|
||||
GETDATA(STUDY) ; [Function] Return the Necessary data for creating a TIU note.
|
||||
; Return: Patient DFN_"^"_TIU title_"^"_Hospital Location_"^"_TIU Note
|
||||
; IEN_"^"_Consult #_"^"_CP Definition IEN_"^"_Visit String_"^"
|
||||
; New Visit Flag
|
||||
; or
|
||||
; -1^Error Message
|
||||
N DFN,MDCON,MDFN,MDIEN,MDIENS,MDLOC,MDNEWV,MDNOTE,MDNVST,MDPROC,MDVSTR,MDTITL,MDX,MDTST
|
||||
S MDIEN=+STUDY,MDIENS=MDIEN_",",MDNVST=0
|
||||
I $$GET1^DIQ(702,MDIENS,.01)="" Q "-1^No such study entry."
|
||||
; Get DFN
|
||||
S DFN=$$GET1^DIQ(702,MDIEN,.01,"I")
|
||||
I 'DFN Q "-1^No DFN."
|
||||
; Get CP Def
|
||||
S MDPROC=$$GET1^DIQ(702,MDIEN,.04,"I")
|
||||
I 'MDPROC Q "-1^No CP Def."
|
||||
; Get Consult
|
||||
S MDCON=$$GET1^DIQ(702,MDIEN,.05,"I")
|
||||
I 'MDCON Q "-1^No Consult #."
|
||||
; Get TIU Note Title
|
||||
S MDTITL=$$GET1^DIQ(702.01,+MDPROC_",",.04,"I")
|
||||
I 'MDTITL Q "-1^No TIU Note Title."
|
||||
S MDVSTR=$$GET1^DIQ(702,MDIEN,.07)
|
||||
I MDVSTR="" Q "-1^No Visit String."
|
||||
I $L(MDVSTR,";")=1 S MDNVST=1,MDVSTR=";"_MDVSTR ; If new visit is selected
|
||||
; MDLOC is Hospital Location
|
||||
I MDVSTR'="" D
|
||||
.S MDVSTR=$$GETVSTR^MDRPCOT1(DFN,MDVSTR,MDPROC,$$GET1^DIQ(702,MDIEN,.02,"I"))
|
||||
.S MDLOC=$P(MDVSTR,";",1)
|
||||
; Does TIU doc already exist?
|
||||
I $$GET1^DIQ(702,MDIEN,.06,"I") Q DFN_"^"_MDTITL_"^"_MDLOC_"^"_+$$GET1^DIQ(702,MDIEN,.06,"I")_"^"_MDCON_"^"_MDPROC_"^"_MDVSTR_"^"_MDNVST
|
||||
; Does TIU doc exist for previous transaction of this consult?
|
||||
I MDCON S MDNOTE=$$PREV(MDCON,MDIEN)
|
||||
Q DFN_"^"_MDTITL_"^"_MDLOC_"^"_+MDNOTE_"^"_MDCON_"^"_MDPROC_"^"_MDVSTR_"^"_MDNVST
|
||||
;
|
||||
NEWTIUN(STUDY) ; [Function] Create a new TIU for transaction
|
||||
; Input: STUDY - IENS of CP study entry
|
||||
; Return: TIU Document IEN
|
||||
N CTR,DFN,MDCON,MDFDA,MDGST,MDL,MDLOC,MDNOTE,MDPDT,MDPROC,MDRESU,MDTITL,MDTSTR,MDVST,MDVSTR,MDWP S CTR=0,MDGST=+STUDY,MDRESU=""
|
||||
; Get data for TIU Note Creation
|
||||
S (MDTSTR,MDRESU)=$$GETDATA(MDGST)
|
||||
; File Error message
|
||||
I +MDRESU<0 D FILEMSG(MDGST,"CP",2,MDRESU) Q MDRESU
|
||||
I $G(MDTSTR)="" Q "-1^No Data to Create TIU Document"
|
||||
F MDL="DFN","MDTITL","MDLOC","MDNOTE","MDCON","MDPROC","MDVSTR","MDNVST" D
|
||||
.S CTR=CTR+1,@MDL=$P(MDTSTR,"^",CTR)
|
||||
S MDVST=""
|
||||
; If previous TIU document exists, quit
|
||||
I MDNOTE Q MDNOTE
|
||||
I 'MDLOC Q "-1^No Hospital Location."
|
||||
; Create new visit, if no vstring
|
||||
S MDPDT=$$PDT^MDRPCOT1(MDGST)
|
||||
S:'MDPDT MDPDT=$P(MDVSTR,";",2) ; If No D/T Performed grab visit D/T
|
||||
; Build variables for TIU Call
|
||||
S MDWP(.05)=1 ; Undicated Status
|
||||
S MDWP(1405)=+MDCON_";GMR(123," ; Package Reference
|
||||
I MDPDT S MDWP(70202)=MDPDT ; Date/Time Performed
|
||||
; File PCE Error message
|
||||
I MDNVST S MDRESU=$$EN1^MDPCE(MDGST,MDPDT,MDPROC,$P(MDVSTR,";",3),"P") I +MDRESU S MDVST=+MDRESU,MDVSTR=$P(MDRESU,"^",2)
|
||||
I MDNVST&(+MDRESU<0) D FILEMSG(MDGST,"PCE",2,$P(MDRESU,"^",2)) Q MDRESU
|
||||
; Create the TIU note stub
|
||||
S MDNOTE="" D MAKE^TIUSRVP(.MDNOTE,DFN,MDTITL,$P(MDVSTR,";",2),MDLOC,$S(MDVST:MDVST,1:""),.MDWP,MDVSTR,1,1)
|
||||
I '(+MDNOTE) S $P(MDNOTE,"^")=-1 Q MDNOTE
|
||||
; Finalize the transaction
|
||||
S MDFDA(702,STUDY_",",.06)=+MDNOTE
|
||||
S MDFDA(702,STUDY_",",.08)=""
|
||||
D FILE^DIE("","MDFDA")
|
||||
Q 1
|
||||
;
|
||||
PREV(MDC,MDS) ; [Function] Return the Previous TIU document.
|
||||
N MDNEWV,MDDOC,MDTRAN,MDTIUER,MDTST
|
||||
S (MDDOC,MDNEWV,MDTRAN,MDTIUER,MDTST)="" K ^TMP("MDTIUST",$J)
|
||||
F S MDTRAN=$O(^MDD(702,"ACON",MDC,MDTRAN)) Q:'MDTRAN D Q:'MDTRAN
|
||||
.I $P(^MDD(702,MDTRAN,0),U,6) D
|
||||
..D EXTRACT^TIULQ($P(^MDD(702,MDTRAN,0),U,6),"^TMP(""MDTIUST"",$J)",MDTIUER,".01;.05;1406") Q:+MDTIUER
|
||||
..S MDTST=$G(^TMP("MDTIUST",$J,$P(^MDD(702,MDTRAN,0),U,6),.05,"E"))
|
||||
..I MDTST'="UNDICTATED"&(MDTST'="UNSIGNED") K ^TMP("MDTIUST",$J) Q
|
||||
..I MDTST="UNSIGNED"&'($G(^TMP("MDTIUST",$J,$P(^MDD(702,MDTRAN,0),U,6),1406,"I"))) K ^TMP("MDTIUST",$J) Q
|
||||
..S MDDOC=$P(^MDD(702,MDTRAN,0),U,6),MDNEWV=$P(^MDD(702,MDTRAN,0),U,7)
|
||||
..Q:'MDS
|
||||
..S MDFDA(702,MDS_",",.06)=MDDOC
|
||||
..S MDFDA(702,MDS_",",.07)=MDNEWV
|
||||
..D FILE^DIE("","MDFDA")
|
||||
..S MDTRAN=""
|
||||
Q MDDOC
|
||||
;
|
||||
|
|
|
|||
|
|
@ -1,17 +1,16 @@
|
|||
PXRM7M1 ;SLC/JVS HL7 PUT MESSAGE IN 772 FILE; 06/01/2007 15:26
|
||||
;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
|
||||
;This routine will use the HL7 Package commands to gather the message
|
||||
;into the file 772
|
||||
Q
|
||||
EN(ID) ;Entry Point
|
||||
;
|
||||
S (PROTIEN,PXRM7,PXRM7R,PXRM77,PXRM7ID)=""
|
||||
S PROTIEN=$O(^ORD(101,"B","PXRM7 RECO SERVER",PROTIEN))
|
||||
S HL("EID")=PROTIEN
|
||||
D INIT^HLFNC2(PROTIEN,.PXRM7)
|
||||
S PXRM7("PID")="HI^D"
|
||||
S HLA("HLS",1)=PXRM77
|
||||
D GENERATE^HLMA(HL("EID"),"GM",1,.PXRM7R,.PXRM7ID,)
|
||||
D STORE^PXRM7API
|
||||
S ID=ZMID
|
||||
Q
|
||||
PXRM7M1 ;SLC/JVS HL7 PUT MESSAGE IN 772 FILE; 03/21/2002 ;4/11/02 15:26
|
||||
;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
|
||||
;This routine will use the HL7 Package commands to gather the message
|
||||
;into the file 772
|
||||
Q
|
||||
EN(ID) ;Entry Point
|
||||
;
|
||||
S (PROTIEN,PXRM7,PXRM7R,PXRM77,PXRM7ID)=""
|
||||
S PROTIEN=$O(^ORD(101,"B","PXRM7 RECO SERVER",PROTIEN))
|
||||
S HL("EID")=PROTIEN
|
||||
D INIT^HLFNC2(PROTIEN,.PXRM7)
|
||||
S PXRM7("PID")="HI^D"
|
||||
S HLA("HLS",1)=PXRM77
|
||||
D GENERATE^HLMA(HL("EID"),"GM",1,.PXRM7R,.PXRM7ID,)
|
||||
S ID=ZMID
|
||||
Q
|
||||
|
|
|
|||
|
|
@ -1,254 +1,253 @@
|
|||
PXRM7XT ;SLC/JVS HL7 EXTRACT FROM FILE; 06/01/2007
|
||||
;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
|
||||
;This is the beginning of the extraction from the extract file
|
||||
;
|
||||
;VARIABLE LIST
|
||||
;IEN = IEN OF ENTRY IN EXTRACT FILE 810.3
|
||||
Q
|
||||
SPLIT ;SPLIT MESSAGES
|
||||
;
|
||||
N ORC2
|
||||
I LINE>100 D
|
||||
.S ORCCNT=ORCCNT+1
|
||||
.D EN^PXRM7M1(.ID)
|
||||
.K ^TMP("HLS",$J)
|
||||
.S ORC2=$G(^TMP("PXRM7HLORC",$J))
|
||||
.S $P(ORC2,"|",3)="P"_ORCCNT,ORC=ORC2
|
||||
.S LINE=2
|
||||
.I $D(SEE) W !,ORC
|
||||
.S ^TMP("HLS",$J,1)=ORC
|
||||
Q
|
||||
;
|
||||
EXTRACT(IEN,SEE,ID,MODE) ;
|
||||
N ORCCNT
|
||||
K ERROR,LINE
|
||||
S ORCCNT=1 ;Count of ORC segments or number of messages created
|
||||
S LINE=1 ;Line count for the ^TMP("HL7",$J,LINE) global variable
|
||||
;-Verify Values
|
||||
I '$D(^PXRMXT(810.3,IEN)) S ERROR(1)="No Such IEN in file 810.3 "_IEN
|
||||
I $D(ERROR) D Q
|
||||
.I $D(SEE)=1
|
||||
;-Extracting Value of Nodes in file
|
||||
I $D(ERROR) Q
|
||||
D GETS^DIQ(810.3,IEN,"**","EI","^TMP(""PXRM7"",$J)")
|
||||
D ORCSEG
|
||||
;******Add NTE segment to end of message *******
|
||||
;******change 3rd piece of ORC segement to L (last)****
|
||||
S NTE="NTE||"_LAST_"||"
|
||||
S ^TMP("HLS",$J,LINE)=NTE,LINE=LINE+1
|
||||
I SEE=1 W !,NTE
|
||||
K NTE,LAST
|
||||
S ORC=$G(^TMP("HLS",$J,1)),$P(ORC,"|",3)="F"_ORCCNT,^TMP("HLS",$J,1)=ORC
|
||||
;***********************************************
|
||||
;*******TURN ON BELOW TO TRANSMIT TO AUSTIN *****
|
||||
D EN^PXRM7M1(.ID)
|
||||
;***********************************************
|
||||
K ^TMP("PXRM7",$J)
|
||||
K ^TMP("HLS",$J)
|
||||
K ^TMP("PXRM7HLORC",$J)
|
||||
;********KILL LEFT OVER ARRAYS AND VARIABLES*****
|
||||
K HL("EID"),HLA("HLS"),PROTIEN,PXRM7,PXRM77,PXRM7ID,PXRM7R,ZMID
|
||||
K DA,DISYS,DISYS,EO,HL("EIDS"),HLECH,HLFS,HLN,HLQ,HLSAN,HLX
|
||||
K IENIEN,IENOBR,IENX,IENY,IENZ,L,LINE,NEXT,QTI,RFS,SEQ
|
||||
K STATION,USI
|
||||
;**************************************************
|
||||
Q
|
||||
ORCSEG ;CREATE ORC SEGMENTS
|
||||
;ORDERED IN ORDER OF APPEARANCE IN SEGMENT
|
||||
;QTI=QUANTITY AND TIMING
|
||||
;EO=ENTERING ORGANIZATION
|
||||
;--Below adds extra line feed in front of the message. --
|
||||
;---------------------------------------------------
|
||||
S IENY=IEN_","
|
||||
;---------------------------------------------
|
||||
;0 PLACER ORDER NUMBER ORC.2.1
|
||||
S $P(ORC,"|",3)="P1"
|
||||
;---------------------------------------------
|
||||
;1 REPORTING PERIOD ORC.7.1.1
|
||||
S QTI(1)=$G(^TMP("PXRM7",$J,810.3,IENY,3,"E"))
|
||||
S $P(QTI,"~",1)=QTI(1)
|
||||
;---------------------------------------------
|
||||
;2 QUARTER ORC.7.3
|
||||
S QTI(3)=$G(^TMP("PXRM7",$J,810.3,IENY,7,"E"))
|
||||
S $P(QTI,"~",3)=QTI(3)
|
||||
;---------------------------------------------
|
||||
;3 BEGINNING DATE ORC.7.4.1
|
||||
S QTI(4)=$$HLDATE^HLFNC($G(^TMP("PXRM7",$J,810.3,IENY,.02,"I")),"DT")
|
||||
S $P(QTI,"~",4)=QTI(4)
|
||||
;---------------------------------------------
|
||||
;4 ENDING DATE ORC.7.5.1
|
||||
S QTI(5)=$$HLDATE^HLFNC($G(^TMP("PXRM7",$J,810.3,IENY,.03,"I")),"DT")
|
||||
S $P(QTI,"~",5)=QTI(5)
|
||||
;---------------------------------------------
|
||||
;5 REPORTING YEAR ORC.7.11.2
|
||||
S QTI(11)="&"_$G(^TMP("PXRM7",$J,810.3,IENY,4,"E"))
|
||||
S $P(QTI,"~",11)=QTI(11)
|
||||
;---------------------------------------------
|
||||
;6 EXTRACT DATE ORC.9.1
|
||||
S $P(ORC,"|",10)=$$HLDATE^HLFNC($G(^TMP("PXRM7",$J,810.3,IENY,.06,"I")),"DT")
|
||||
;---------------------------------------------
|
||||
;7 NAME ORC.17.2
|
||||
S EO(2)=$G(^TMP("PXRM7",$J,810.3,IENY,.01,"E"))
|
||||
S $P(EO,"~",2)=EO(2)
|
||||
;---------------------------------------------
|
||||
;8 REPORT EXTRACT PARAMETER ORC.17.5
|
||||
S EO(5)=$G(^TMP("PXRM7",$J,810.3,IENY,1,"E"))
|
||||
S $P(EO,"~",5)=EO(5)
|
||||
;---------------------------------------------
|
||||
;9 REPORT EXTRACT TYPE ORC.18.2
|
||||
S $P(ORC,"|",19)="~"_$G(^TMP("PXRM7",$J,810.3,IENY,2,"E"))
|
||||
;---------------------------------------------
|
||||
;FINISH POPULATING ORC SEGMENT
|
||||
S $P(ORC,"|",8)=QTI
|
||||
S $P(ORC,"|",18)=EO
|
||||
S $P(ORC,"|",1)="ORC"
|
||||
;---------------------------------------------
|
||||
;SET HL7 TMP ARRAY AND SHOW SEGMENT
|
||||
S ^TMP("HLS",$J,LINE)=ORC,LINE=LINE+1
|
||||
I SEE=1 W !,ORC
|
||||
S ^TMP("PXRM7HLORC",$J)=ORC
|
||||
K ORC
|
||||
OBRSEG ;CREATE OBR SEGMENTS
|
||||
;N IENOBR,SEQ,USI,QTI,NEXT,STATION
|
||||
;USI=UNIVERSAL SERVICE ID
|
||||
;RFS=REASON FOR STUDY
|
||||
;
|
||||
S NEXT=1,LAST=0
|
||||
S IENOBR=0 F S IENOBR=$O(^PXRMXT(810.3,IEN,3,IENOBR)) Q:IENOBR<1 D
|
||||
.S IENIEN=-1 F S IENIEN=$O(^PXRMXT(810.3,IEN,3,IENOBR,1,IENIEN)) Q:IENIEN="B" D Q:IENIEN=""
|
||||
..S L=$S(IENIEN=0:1,IENIEN>0:2,IENIEN="":1,1:"")
|
||||
..;###---Set Sequence Number
|
||||
..S IENX=IENOBR_","_IEN_","
|
||||
..S IENZ=IENIEN_","_IENOBR_","_IEN_","
|
||||
..S SEQ=$G(^TMP("PXRM7",$J,810.33,IENX,.01,"E"))
|
||||
..S OBR(+SEQ_L)="OBR|1|||||||||||||||||||||||||||||||"
|
||||
..S $P(OBR(+SEQ_L),"|",2)=NEXT,LAST=NEXT,NEXT=NEXT+1
|
||||
..;--------------------------------------------------
|
||||
..;10 COUNT TYPE OBR.4.2
|
||||
..;R=REMINDER COUNTS F=FINDING COUNTS
|
||||
..S USI(2)=$S(L=1:"R",L=2:"F",1:"")
|
||||
..S $P(USI,"~",2)=USI(2)
|
||||
..;--------------------------------------------------
|
||||
..;11 REMINDER OBR.4.5
|
||||
..S USI(5)=$G(^TMP("PXRM7",$J,810.33,IENX,.02,"E"))
|
||||
..S $P(USI,"~",5)=USI(5)
|
||||
..;--------------------------------------------------
|
||||
..;12 STATION OBR.3.1
|
||||
..S STATION=$G(^TMP("PXRM7",$J,810.33,IENX,.03,"I"))_","
|
||||
..D GETS^DIQ(4,STATION,"**","E","^TMP(""PXRM7"",$J)")
|
||||
..S $P(OBR(+SEQ_L),"|",4)=$G(^TMP("PXRM7",$J,4,STATION,99,"E"))
|
||||
..;--------------------------------------------------
|
||||
..;13 PATIENT LIST OBR.31.2
|
||||
..S RFS(2)=$G(^TMP("PXRM7",$J,810.33,IENX,.04,"E"))
|
||||
..S $P(RFS,"~",2)=RFS(2)
|
||||
..;--------------------------------------------------
|
||||
..;19 REMINDER TERM OBR.31.1
|
||||
..S RFS(1)=$S(L=2:$G(^TMP("PXRM7",$J,810.331,IENZ,.02,"E")),1:"")
|
||||
..S $P(RFS,"~",1)=RFS(1)
|
||||
..;--------------------------------------------------
|
||||
..;20 FINDING TOTAL TYPE OBR.31.4
|
||||
..S RFS(4)=$S(L=2:$G(^TMP("PXRM7",$J,810.331,IENZ,.03,"E")),1:"")
|
||||
..S $P(RFS,"~",4)=RFS(4)
|
||||
..;--------------------------------------------------
|
||||
..;21 GROUP NAME OBR.31.5
|
||||
..S RFS(5)=$S(L=2:$G(^TMP("PXRM7",$J,810.331,IENZ,.04,"E")),1:"")
|
||||
..S $P(RFS,"~",5)=RFS(5)
|
||||
..;--------------------------------------------------
|
||||
..;22 REMINDER STATUS OBR.4.4
|
||||
..S USI(4)=$S(L=2:$G(^TMP("PXRM7",$J,810.331,IENZ,.05,"I")),1:"")
|
||||
..S $P(USI,"~",4)=USI(4)
|
||||
..;-------------------------------------------------
|
||||
..;FINISH POPULATING OBR SEGMENT
|
||||
..S $P(OBR(+SEQ_L),"|",5)=USI
|
||||
..S $P(OBR(+SEQ_L),"|",32)=RFS
|
||||
..;-------------------------------------------------
|
||||
..;---Set message in HL7 array
|
||||
..;I $L($G(OBR(+SEQ_L)))=255 S OBR(+SEQ_L)=OBR(+SEQ_L)_"|||"
|
||||
..S ^TMP("HLS",$J,LINE)=$G(OBR(+SEQ_L)),LINE=LINE+1
|
||||
..;
|
||||
..I SEE=1 W !," ",OBR(+SEQ_L)
|
||||
..K OBR
|
||||
..D OBXSEG
|
||||
..D SPLIT
|
||||
..I (L=1)&(IENIEN="") Q
|
||||
Q
|
||||
OBXSEG ;CREATE THE OBX SEGMENTS
|
||||
N TERM
|
||||
;OV=OBSERVATION VALUE
|
||||
S $P(OBX(+SEQ_L),"|",3)="MO"
|
||||
S $P(OBX(+SEQ_L),"|",1)="OBX"
|
||||
;---------------------------------------------------
|
||||
;###---SET SEQUENCE NUMBER
|
||||
S $P(OBX(+SEQ_L),"|",2)=1
|
||||
;---------------------------------------------------
|
||||
;14 TOTAL PATIENTS EVALUATED - REMINDER OBX.5.1
|
||||
I L=1 D
|
||||
.S TERM="TOTAL PATIENTS EVALUATED"
|
||||
.S OV(1)=$G(^TMP("PXRM7",$J,810.33,IENX,2,"E"))_"~"_TERM
|
||||
.S $P(OV,"^",1)=OV(1)
|
||||
;---------------------------------------------------
|
||||
;15 TOTAL PATIENTS APPLICABLE - REMINDER OBX.5.2
|
||||
I L=1 D
|
||||
.S TERM="TOTAL PATIENTS APPLICABLE"
|
||||
.S OV(2)=$G(^TMP("PXRM7",$J,810.33,IENX,3,"E"))_"~"_TERM
|
||||
.S $P(OV,"^",2)=OV(2)
|
||||
;---------------------------------------------------
|
||||
;16 TOTAL PATIENTS NOT APPLICABLE - REMINDER OBX.5.3
|
||||
I L=1 D
|
||||
.S TERM="TOTAL PATIENTS NOT APPLICABLE"
|
||||
.S OV(3)=$G(^TMP("PXRM7",$J,810.33,IENX,4,"E"))_"~"_TERM
|
||||
.S $P(OV,"^",3)=OV(3)
|
||||
;---------------------------------------------------
|
||||
;17 TOTAL PATIENTS DUE - REMINDER OBX.5.4
|
||||
I L=1 D
|
||||
.S TERM="TOTAL PATIENTS DUE"
|
||||
.S OV(4)=$G(^TMP("PXRM7",$J,810.33,IENX,5,"E"))_"~"_TERM
|
||||
.S $P(OV,"^",4)=OV(4)
|
||||
;---------------------------------------------------
|
||||
;18 TOTAL PATIENTS NOT DUE - REMINDER OBX.5.5
|
||||
I L=1 D
|
||||
.S TERM="TOTAL PATIENTS NOT DUE"
|
||||
.S OV(5)=$G(^TMP("PXRM7",$J,810.33,IENX,6,"E"))_"~"_TERM
|
||||
.S $P(OV,"^",5)=OV(5)
|
||||
;---------------------------------------------------
|
||||
;23 TOTAL COUNT - FINDING OBX.5.1
|
||||
I L=2 D
|
||||
.S TERM="TOTAL COUNT"
|
||||
.S OV(1)=$G(^TMP("PXRM7",$J,810.331,IENZ,1,"E"))_"~"_TERM
|
||||
.S $P(OV,"^",1)=OV(1)
|
||||
;---------------------------------------------------
|
||||
;24 APPLICABLE COUNT - FINDING OBX.5.2
|
||||
I L=2 D
|
||||
.S TERM="APPLICABLE COUNT"
|
||||
.S OV(2)=$G(^TMP("PXRM7",$J,810.331,IENZ,2,"E"))_"~"_TERM
|
||||
.S $P(OV,"^",2)=OV(2)
|
||||
;---------------------------------------------------
|
||||
;25 NOT APPLICABLE COUNT- FINDING OBX.5.3
|
||||
I L=2 D
|
||||
.S TERM="NOT APPLICABLE COUNT"
|
||||
.S OV(3)=$G(^TMP("PXRM7",$J,810.331,IENZ,3,"E"))_"~"_TERM
|
||||
.S $P(OV,"^",3)=OV(3)
|
||||
;---------------------------------------------------
|
||||
;26 DUE COUNT - FINDING OBX.5.4
|
||||
I L=2 D
|
||||
.S TERM="DUE COUNT"
|
||||
.S OV(4)=$G(^TMP("PXRM7",$J,810.331,IENZ,4,"E"))_"~"_TERM
|
||||
.S $P(OV,"^",4)=OV(4)
|
||||
;---------------------------------------------------
|
||||
;27 NOT DUE COUNT - FINDING OBX.5.5
|
||||
I L=2 D
|
||||
.S TERM="NOT DUE COUNT"
|
||||
.S OV(5)=$G(^TMP("PXRM7",$J,810.331,IENZ,5,"E"))_"~"_TERM
|
||||
.S $P(OV,"^",5)=OV(5)
|
||||
;---------------------------------------------------
|
||||
;FINISH POPULATING OBX SEGMENT
|
||||
S $P(OBX(+SEQ_L),"|",6)=OV
|
||||
K OV
|
||||
;---------------------------------------------------
|
||||
;###---Set message in HL7 array
|
||||
S ^TMP("HLS",$J,LINE)=$G(OBX(+SEQ_L)),LINE=LINE+1
|
||||
;
|
||||
I SEE=1 W !," ",OBX(+SEQ_L)
|
||||
K OBX
|
||||
;---------------------------------------------------
|
||||
Q
|
||||
PXRM7XT ;SLC/JVS HL7 EXTRACT FROM FILE; 03/21/2002 ;4/11/02 15:26
|
||||
;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
|
||||
;This is the beginning of the extraction from the extract file
|
||||
;
|
||||
;VARIABLE LIST
|
||||
;IEN = IEN OF ENTRY IN EXTRACT FILE 810.3
|
||||
Q
|
||||
SPLIT ;SPLIT MESSAGES
|
||||
N ORC2
|
||||
I LINE>100 D
|
||||
.S ORCCNT=ORCCNT+1
|
||||
.D EN^PXRM7M1(.ID)
|
||||
.K ^TMP("HLS",$J)
|
||||
.S ORC2=$G(^TMP("PXRM7HLORC",$J))
|
||||
.S $P(ORC2,"|",3)="P"_ORCCNT,ORC=ORC2
|
||||
.S LINE=2
|
||||
.I $D(SEE) W !,ORC
|
||||
.S ^TMP("HLS",$J,1)=ORC
|
||||
Q
|
||||
;
|
||||
EXTRACT(IEN,SEE,ID,MODE) ;
|
||||
N ORCCNT
|
||||
K ERROR,LINE
|
||||
S ORCCNT=1 ;Count of ORC segments or number of messages created
|
||||
S LINE=1 ;Line count for the ^TMP("HL7",$J,LINE) global variable
|
||||
;-Verify Values
|
||||
I '$D(^PXRMXT(810.3,IEN)) S ERROR(1)="No Such IEN in file 810.3 "_IEN
|
||||
I $D(ERROR) D Q
|
||||
.I $D(SEE)=1
|
||||
;-Extracting Value of Nodes in file
|
||||
I $D(ERROR) Q
|
||||
D GETS^DIQ(810.3,IEN,"**","EI","^TMP(""PXRM7"",$J)")
|
||||
D ORCSEG
|
||||
;******Add NTE segment to end of message *******
|
||||
;******change 3rd piece of ORC segement to L (last)****
|
||||
S NTE="NTE||"_LAST_"||"
|
||||
S ^TMP("HLS",$J,LINE)=NTE,LINE=LINE+1
|
||||
I SEE=1 W !,NTE
|
||||
K NTE,LAST
|
||||
S ORC=$G(^TMP("HLS",$J,1)),$P(ORC,"|",3)="F"_ORCCNT,^TMP("HLS",$J,1)=ORC
|
||||
;***********************************************
|
||||
;*******TURN ON BELOW TO TRANSMIT TO AUSTIN *****
|
||||
D EN^PXRM7M1(.ID)
|
||||
;***********************************************
|
||||
K ^TMP("PXRM7",$J)
|
||||
K ^TMP("HLS",$J)
|
||||
K ^TMP("PXRM7HLORC",$J)
|
||||
;********KILL LEFT OVER ARRAYS AND VARIABLES*****
|
||||
K HL("EID"),HLA("HLS"),PROTIEN,PXRM7,PXRM77,PXRM7ID,PXRM7R,ZMID
|
||||
K DA,DISYS,DISYS,EO,HL("EIDS"),HLECH,HLFS,HLN,HLQ,HLSAN,HLX
|
||||
K IENIEN,IENOBR,IENX,IENY,IENZ,L,LINE,NEXT,QTI,RFS,SEQ
|
||||
K STATION,USI
|
||||
;**************************************************
|
||||
Q
|
||||
ORCSEG ;CREATE ORC SEGMENTS
|
||||
;ORDERED IN ORDER OF APPEARANCE IN SEGMENT
|
||||
;QTI=QUANTITY AND TIMING
|
||||
;EO=ENTERING ORGANIZATION
|
||||
;--Below adds extra line feed in front of the message. --
|
||||
;---------------------------------------------------
|
||||
S IENY=IEN_","
|
||||
;---------------------------------------------
|
||||
;0 PLACER ORDER NUMBER ORC.2.1
|
||||
S $P(ORC,"|",3)="P1"
|
||||
;---------------------------------------------
|
||||
;1 REPORTING PERIOD ORC.7.1.1
|
||||
S QTI(1)=$G(^TMP("PXRM7",$J,810.3,IENY,3,"E"))
|
||||
S $P(QTI,"~",1)=QTI(1)
|
||||
;---------------------------------------------
|
||||
;2 QUARTER ORC.7.3
|
||||
S QTI(3)=$G(^TMP("PXRM7",$J,810.3,IENY,7,"E"))
|
||||
S $P(QTI,"~",3)=QTI(3)
|
||||
;---------------------------------------------
|
||||
;3 BEGINNING DATE ORC.7.4.1
|
||||
S QTI(4)=$$HLDATE^HLFNC($G(^TMP("PXRM7",$J,810.3,IENY,.02,"I")),"DT")
|
||||
S $P(QTI,"~",4)=QTI(4)
|
||||
;---------------------------------------------
|
||||
;4 ENDING DATE ORC.7.5.1
|
||||
S QTI(5)=$$HLDATE^HLFNC($G(^TMP("PXRM7",$J,810.3,IENY,.03,"I")),"DT")
|
||||
S $P(QTI,"~",5)=QTI(5)
|
||||
;---------------------------------------------
|
||||
;5 REPORTING YEAR ORC.7.11.2
|
||||
S QTI(11)="&"_$G(^TMP("PXRM7",$J,810.3,IENY,4,"E"))
|
||||
S $P(QTI,"~",11)=QTI(11)
|
||||
;---------------------------------------------
|
||||
;6 EXTRACT DATE ORC.9.1
|
||||
S $P(ORC,"|",10)=$$HLDATE^HLFNC($G(^TMP("PXRM7",$J,810.3,IENY,.06,"I")),"DT")
|
||||
;---------------------------------------------
|
||||
;7 NAME ORC.17.2
|
||||
S EO(2)=$G(^TMP("PXRM7",$J,810.3,IENY,.01,"E"))
|
||||
S $P(EO,"~",2)=EO(2)
|
||||
;---------------------------------------------
|
||||
;8 REPORT EXTRACT PARAMETER ORC.17.5
|
||||
S EO(5)=$G(^TMP("PXRM7",$J,810.3,IENY,1,"E"))
|
||||
S $P(EO,"~",5)=EO(5)
|
||||
;---------------------------------------------
|
||||
;9 REPORT EXTRACT TYPE ORC.18.2
|
||||
S $P(ORC,"|",19)="~"_$G(^TMP("PXRM7",$J,810.3,IENY,2,"E"))
|
||||
;---------------------------------------------
|
||||
;FINISH POPULATING ORC SEGMENT
|
||||
S $P(ORC,"|",8)=QTI
|
||||
S $P(ORC,"|",18)=EO
|
||||
S $P(ORC,"|",1)="ORC"
|
||||
;---------------------------------------------
|
||||
;SET HL7 TMP ARRAY AND SHOW SEGMENT
|
||||
S ^TMP("HLS",$J,LINE)=ORC,LINE=LINE+1
|
||||
I SEE=1 W !,ORC
|
||||
S ^TMP("PXRM7HLORC",$J)=ORC
|
||||
K ORC
|
||||
OBRSEG ;CREATE OBR SEGMENTS
|
||||
;N IENOBR,SEQ,USI,QTI,NEXT,STATION
|
||||
;USI=UNIVERSAL SERVICE ID
|
||||
;RFS=REASON FOR STUDY
|
||||
;
|
||||
S NEXT=1,LAST=0
|
||||
S IENOBR=0 F S IENOBR=$O(^PXRMXT(810.3,IEN,3,IENOBR)) Q:IENOBR<1 D
|
||||
.S IENIEN=-1 F S IENIEN=$O(^PXRMXT(810.3,IEN,3,IENOBR,1,IENIEN)) Q:IENIEN="B" D Q:IENIEN=""
|
||||
..S L=$S(IENIEN=0:1,IENIEN>0:2,IENIEN="":1,1:"")
|
||||
..;###---Set Sequence Number
|
||||
..S IENX=IENOBR_","_IEN_","
|
||||
..S IENZ=IENIEN_","_IENOBR_","_IEN_","
|
||||
..S SEQ=$G(^TMP("PXRM7",$J,810.33,IENX,.01,"E"))
|
||||
..S OBR(+SEQ_L)="OBR|1|||||||||||||||||||||||||||||||"
|
||||
..S $P(OBR(+SEQ_L),"|",2)=NEXT,LAST=NEXT,NEXT=NEXT+1
|
||||
..;--------------------------------------------------
|
||||
..;10 COUNT TYPE OBR.4.2
|
||||
..;R=REMINDER COUNTS F=FINDING COUNTS
|
||||
..S USI(2)=$S(L=1:"R",L=2:"F",1:"")
|
||||
..S $P(USI,"~",2)=USI(2)
|
||||
..;--------------------------------------------------
|
||||
..;11 REMINDER OBR.4.5
|
||||
..S USI(5)=$G(^TMP("PXRM7",$J,810.33,IENX,.02,"E"))
|
||||
..S $P(USI,"~",5)=USI(5)
|
||||
..;--------------------------------------------------
|
||||
..;12 STATION OBR.3.1
|
||||
..S STATION=$G(^TMP("PXRM7",$J,810.33,IENX,.03,"I"))_","
|
||||
..D GETS^DIQ(4,STATION,"**","E","^TMP(""PXRM7"",$J)")
|
||||
..S $P(OBR(+SEQ_L),"|",4)=$G(^TMP("PXRM7",$J,4,STATION,99,"E"))
|
||||
..;--------------------------------------------------
|
||||
..;13 PATIENT LIST OBR.31.2
|
||||
..S RFS(2)=$G(^TMP("PXRM7",$J,810.33,IENX,.04,"E"))
|
||||
..S $P(RFS,"~",2)=RFS(2)
|
||||
..;--------------------------------------------------
|
||||
..;19 REMINDER TERM OBR.31.1
|
||||
..S RFS(1)=$S(L=2:$G(^TMP("PXRM7",$J,810.331,IENZ,.02,"E")),1:"")
|
||||
..S $P(RFS,"~",1)=RFS(1)
|
||||
..;--------------------------------------------------
|
||||
..;20 FINDING TOTAL TYPE OBR.31.4
|
||||
..S RFS(4)=$S(L=2:$G(^TMP("PXRM7",$J,810.331,IENZ,.03,"E")),1:"")
|
||||
..S $P(RFS,"~",4)=RFS(4)
|
||||
..;--------------------------------------------------
|
||||
..;21 GROUP NAME OBR.31.5
|
||||
..S RFS(5)=$S(L=2:$G(^TMP("PXRM7",$J,810.331,IENZ,.04,"E")),1:"")
|
||||
..S $P(RFS,"~",5)=RFS(5)
|
||||
..;--------------------------------------------------
|
||||
..;22 REMINDER STATUS OBR.4.4
|
||||
..S USI(4)=$S(L=2:$G(^TMP("PXRM7",$J,810.331,IENZ,.05,"I")),1:"")
|
||||
..S $P(USI,"~",4)=USI(4)
|
||||
..;-------------------------------------------------
|
||||
..;FINISH POPULATING OBR SEGMENT
|
||||
..S $P(OBR(+SEQ_L),"|",5)=USI
|
||||
..S $P(OBR(+SEQ_L),"|",32)=RFS
|
||||
..;-------------------------------------------------
|
||||
..;---Set message in HL7 array
|
||||
..;I $L($G(OBR(+SEQ_L)))=255 S OBR(+SEQ_L)=OBR(+SEQ_L)_"|||"
|
||||
..S ^TMP("HLS",$J,LINE)=$G(OBR(+SEQ_L)),LINE=LINE+1
|
||||
..;
|
||||
..I SEE=1 W !," ",OBR(+SEQ_L)
|
||||
..K OBR
|
||||
..D OBXSEG
|
||||
..D SPLIT
|
||||
..I (L=1)&(IENIEN="") Q
|
||||
Q
|
||||
OBXSEG ;CREATE THE OBX SEGMENTS
|
||||
N TERM
|
||||
;OV=OBSERVATION VALUE
|
||||
S $P(OBX(+SEQ_L),"|",3)="MO"
|
||||
S $P(OBX(+SEQ_L),"|",1)="OBX"
|
||||
;---------------------------------------------------
|
||||
;###---SET SEQUENCE NUMBER
|
||||
S $P(OBX(+SEQ_L),"|",2)=1
|
||||
;---------------------------------------------------
|
||||
;14 TOTAL PATIENTS EVALUATED - REMINDER OBX.5.1
|
||||
I L=1 D
|
||||
.S TERM="TOTAL PATIENTS EVALUATED"
|
||||
.S OV(1)=$G(^TMP("PXRM7",$J,810.33,IENX,2,"E"))_"~"_TERM
|
||||
.S $P(OV,"^",1)=OV(1)
|
||||
;---------------------------------------------------
|
||||
;15 TOTAL PATIENTS APPLICABLE - REMINDER OBX.5.2
|
||||
I L=1 D
|
||||
.S TERM="TOTAL PATIENTS APPLICABLE"
|
||||
.S OV(2)=$G(^TMP("PXRM7",$J,810.33,IENX,3,"E"))_"~"_TERM
|
||||
.S $P(OV,"^",2)=OV(2)
|
||||
;---------------------------------------------------
|
||||
;16 TOTAL PATIENTS NOT APPLICABLE - REMINDER OBX.5.3
|
||||
I L=1 D
|
||||
.S TERM="TOTAL PATIENTS NOT APPLICABLE"
|
||||
.S OV(3)=$G(^TMP("PXRM7",$J,810.33,IENX,4,"E"))_"~"_TERM
|
||||
.S $P(OV,"^",3)=OV(3)
|
||||
;---------------------------------------------------
|
||||
;17 TOTAL PATIENTS DUE - REMINDER OBX.5.4
|
||||
I L=1 D
|
||||
.S TERM="TOTAL PATIENTS DUE"
|
||||
.S OV(4)=$G(^TMP("PXRM7",$J,810.33,IENX,5,"E"))_"~"_TERM
|
||||
.S $P(OV,"^",4)=OV(4)
|
||||
;---------------------------------------------------
|
||||
;18 TOTAL PATIENTS NOT DUE - REMINDER OBX.5.5
|
||||
I L=1 D
|
||||
.S TERM="TOTAL PATIENTS NOT DUE"
|
||||
.S OV(5)=$G(^TMP("PXRM7",$J,810.33,IENX,6,"E"))_"~"_TERM
|
||||
.S $P(OV,"^",5)=OV(5)
|
||||
;---------------------------------------------------
|
||||
;23 TOTAL COUNT - FINDING OBX.5.1
|
||||
I L=2 D
|
||||
.S TERM="TOTAL COUNT"
|
||||
.S OV(1)=$G(^TMP("PXRM7",$J,810.331,IENZ,1,"E"))_"~"_TERM
|
||||
.S $P(OV,"^",1)=OV(1)
|
||||
;---------------------------------------------------
|
||||
;24 APPLICABLE COUNT - FINDING OBX.5.2
|
||||
I L=2 D
|
||||
.S TERM="APPLICABLE COUNT"
|
||||
.S OV(2)=$G(^TMP("PXRM7",$J,810.331,IENZ,2,"E"))_"~"_TERM
|
||||
.S $P(OV,"^",2)=OV(2)
|
||||
;---------------------------------------------------
|
||||
;25 NOT APPLICABLE COUNT- FINDING OBX.5.3
|
||||
I L=2 D
|
||||
.S TERM="NOT APPLICABLE COUNT"
|
||||
.S OV(3)=$G(^TMP("PXRM7",$J,810.331,IENZ,3,"E"))_"~"_TERM
|
||||
.S $P(OV,"^",3)=OV(3)
|
||||
;---------------------------------------------------
|
||||
;26 DUE COUNT - FINDING OBX.5.4
|
||||
I L=2 D
|
||||
.S TERM="DUE COUNT"
|
||||
.S OV(4)=$G(^TMP("PXRM7",$J,810.331,IENZ,4,"E"))_"~"_TERM
|
||||
.S $P(OV,"^",4)=OV(4)
|
||||
;---------------------------------------------------
|
||||
;27 NOT DUE COUNT - FINDING OBX.5.5
|
||||
I L=2 D
|
||||
.S TERM="NOT DUE COUNT"
|
||||
.S OV(5)=$G(^TMP("PXRM7",$J,810.331,IENZ,5,"E"))_"~"_TERM
|
||||
.S $P(OV,"^",5)=OV(5)
|
||||
;---------------------------------------------------
|
||||
;FINISH POPULATING OBX SEGMENT
|
||||
S $P(OBX(+SEQ_L),"|",6)=OV
|
||||
K OV
|
||||
;---------------------------------------------------
|
||||
;###---Set message in HL7 array
|
||||
S ^TMP("HLS",$J,LINE)=$G(OBX(+SEQ_L)),LINE=LINE+1
|
||||
;
|
||||
I SEE=1 W !," ",OBX(+SEQ_L)
|
||||
K OBX
|
||||
;---------------------------------------------------
|
||||
Q
|
||||
|
|
|
|||
|
|
@ -1,166 +1,165 @@
|
|||
PXRMCDUE ;SLC/PKR - Custom date due calculation routines. ;09/05/2007
|
||||
;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
|
||||
;
|
||||
;========================================================
|
||||
CDBUILD(STRING,DA) ;Given a custom date due string build the data
|
||||
;structure. This is called by a new-style cross-reference after
|
||||
;the date due string has passed the input transform so we don't need
|
||||
;to validate the elements.
|
||||
;Do not execute as part of a verify fields.
|
||||
I $G(DIUTIL)="VERIFY FIELDS" Q
|
||||
;Do not execute as part of exchange.
|
||||
I $G(PXRMEXCH) Q
|
||||
N FDA,FILIST,FREQLIST,FUNCTION,IENB,IENS,IND,MSG,NARGS,PFSTACK
|
||||
S STRING=$$UP^XLFSTR(STRING)
|
||||
D PARSE(STRING,.FUNCTION,.NARGS,.FILIST,.FREQLIST)
|
||||
S IENS=DA_","
|
||||
S FDA(811.9,IENS,46)=FUNCTION,FDA(811.9,IENS,47)=NARGS
|
||||
S IENB=DA
|
||||
F IND=1:1:NARGS D
|
||||
. S IENB=IENB+1
|
||||
. S IENS="+"_IENB_","_DA_","
|
||||
. S FDA(811.948,IENS,.01)=FILIST(IND)
|
||||
. S FDA(811.948,IENS,.02)=FREQLIST(IND)
|
||||
D UPDATE^DIE("","FDA","","MSG")
|
||||
I $D(MSG) D
|
||||
. W !,"The update failed, UPDATE^DIE returned the following error message:"
|
||||
. D AWRITE^PXRMUTIL("MSG")
|
||||
Q
|
||||
;
|
||||
;========================================================
|
||||
CDUEDATE(DEFARR,FIEVAL) ;Do the custom date due calculation and return
|
||||
;the due date.
|
||||
N DATE,DDUE,DLIST,FI,FREQ,FUNCTION,IND,NARGS,TEMP
|
||||
S FUNCTION=$P(DEFARR(46),U,1)
|
||||
S NARGS=$P(DEFARR(46),U,2)
|
||||
F IND=1:1:NARGS D
|
||||
. S TEMP=DEFARR(47,IND,0)
|
||||
. S FI=$P(TEMP,U,1)
|
||||
. S FREQ=$P(TEMP,U,2)
|
||||
. S DATE=$S(FIEVAL(FI):+FIEVAL(FI,"DATE"),1:0)
|
||||
. I DATE>0 S DATE=$$FULLDATE^PXRMDATE(DATE)
|
||||
. S DLIST(IND)=$$NEWDATE^PXRMDATE(DATE,FREQ)
|
||||
S TEMP=$S(FUNCTION="MAX_DATE":$$MAXDATE(NARGS,.DLIST),FUNCTION="MIN_DATE":$$MINDATE(NARGS,.DLIST),1:0)
|
||||
S DDUE=$P(TEMP,U,1)
|
||||
I DDUE=0 Q -1
|
||||
S IND=$P(TEMP,U,2)
|
||||
S TEMP=DEFARR(47,IND,0)
|
||||
S FI=$P(TEMP,U,1)
|
||||
S FREQ=$P(TEMP,U,2)
|
||||
S DATE=+$G(FIEVAL(FI,"DATE"))
|
||||
S ^TMP(PXRMPID,$J,PXRMITEM,"zCDUE")=FI_U_FREQ_U_DATE
|
||||
Q DDUE
|
||||
;
|
||||
;========================================================
|
||||
CDKILL(X,DA) ;
|
||||
;Do not execute as part of a verify fields.
|
||||
I $G(DIUTIL)="VERIFY FIELDS" Q
|
||||
;Do not execute as part of exchange.
|
||||
I $G(PXRMEXCH) Q
|
||||
K ^PXD(811.9,DA,46),^PXD(811.9,DA,47)
|
||||
Q
|
||||
;
|
||||
;========================================================
|
||||
MAXDATE(NARGS,DLIST) ;Return the maximum date from a list of dates in DLIST.
|
||||
N IND,INDS,MAXDATE
|
||||
S (INDS,MAXDATE)=0
|
||||
F IND=1:1:NARGS I DLIST(IND)>MAXDATE S MAXDATE=DLIST(IND),INDS=IND
|
||||
Q MAXDATE_U_INDS
|
||||
;
|
||||
;========================================================
|
||||
MINDATE(NARGS,DLIST) ;Return the minimum date from a list of dates in DLIST.
|
||||
;Only return 0 if there is no "real" date in the list.
|
||||
N DATE,IND,INDS,MINDATE
|
||||
S INDS=0
|
||||
S MINDATE=9991231
|
||||
F IND=1:1:NARGS S DATE=DLIST(IND) I DATE<MINDATE,DATE'=0 S MINDATE=DATE,INDS=IND
|
||||
I MINDATE=9991231 S MINDATE=0
|
||||
Q MINDATE_U_INDS
|
||||
;
|
||||
;========================================================
|
||||
OUTPUT(CDUEDATA,DEFARR) ;Build the custom date due output text.
|
||||
N CDUEFI,ENTRY,FINAME,TEXT,VPTR
|
||||
S CDUEFI=$P(CDUEDATA,U,1)
|
||||
S VPTR=$P(^PXD(811.9,DEFARR("IEN"),20,CDUEFI,0),U,1)
|
||||
S ENTRY="^"_$P(VPTR,";",2)_$P(VPTR,";",1)_",0)"
|
||||
S FINAME=$P(@ENTRY,U,1)
|
||||
S TEXT="Custom date due based on date of finding "_CDUEFI_" ("_FINAME_")"
|
||||
S TEXT=TEXT_" plus frequency of "_$P(CDUEDATA,U,2)_"."
|
||||
Q TEXT
|
||||
;
|
||||
;========================================================
|
||||
PARSE(STRING,FUNCTION,NARGS,FILIST,FREQLIST) ;Parse a custom date due
|
||||
;string and return the function, number of arguments, finding list,
|
||||
;and frequency list. An argument has the form M+NF where M is a
|
||||
;finding number, N is an integer, and F is D, M, or Y.
|
||||
N IND,OPER,PFSTACK
|
||||
S OPER=","
|
||||
D POSTFIX^PXRMSTAC(STRING,OPER,.PFSTACK)
|
||||
S FUNCTION=$$UP^XLFSTR(PFSTACK(1))
|
||||
S NARGS=0
|
||||
F IND=2:1:PFSTACK(0) D
|
||||
. I PFSTACK(IND)=OPER Q
|
||||
. S NARGS=NARGS+1
|
||||
. S FILIST(NARGS)=$P(PFSTACK(IND),"+",1)
|
||||
. S FREQLIST(NARGS)=$P(PFSTACK(IND),"+",2)
|
||||
Q
|
||||
;
|
||||
;========================================================
|
||||
VFREQ(FREQ) ;Make sure FREQ is a valid frequency.
|
||||
N VALID
|
||||
S VALID=1
|
||||
S FREQ=$$UP^XLFSTR(FREQ)
|
||||
I (FREQ'?1N.N1"D"),(FREQ'?1N.N1"M"),(FREQ'?1N.N1"Y") S VALID=0
|
||||
Q VALID
|
||||
;
|
||||
;========================================================
|
||||
VCDUE(STRING,DA) ;Make sure a custom date due string is valid.
|
||||
;Do not execute as part of a verify fields.
|
||||
I $G(DIUTIL)="VERIFY FIELDS" Q 1
|
||||
;Do not execute as part of exchange.
|
||||
I $G(PXRMEXCH) Q 1
|
||||
I '$D(DA) Q 1
|
||||
I $L(STRING)>245 Q 0
|
||||
N FILIST,FREQLIST,FUNCTION,IND,NARGS,TEXT,VALID
|
||||
D PARSE(STRING,.FUNCTION,.NARGS,.FILIST,.FREQLIST)
|
||||
S VALID=1
|
||||
I FUNCTION'="MIN_DATE",FUNCTION'="MAX_DATE" D
|
||||
. S TEXT=FUNCTION_" is not a valid custom date due function"
|
||||
. D EN^DDIOL(TEXT)
|
||||
. S VALID=0
|
||||
F IND=1:1:NARGS D
|
||||
. I '$D(^PXD(811.9,DA,20,FILIST(IND),0)) D
|
||||
.. S TEXT="Finding number "_FILIST(IND)_" is not a valid reminder finding"
|
||||
.. D EN^DDIOL(TEXT)
|
||||
.. S VALID=0
|
||||
. I '$$VFREQ(FREQLIST(IND)) D
|
||||
.. S TEXT=FREQLIST(IND)_" is not a valid frequency"
|
||||
.. D EN^DDIOL(TEXT)
|
||||
.. S VALID=0
|
||||
Q VALID
|
||||
;
|
||||
;========================================================
|
||||
XHELP ;Executable help for custom date due.
|
||||
N DONE,IND,TEXT
|
||||
S DONE=0
|
||||
F IND=1:1 Q:DONE D
|
||||
. S TEXT=$P($T(TEXT+IND),";",3)
|
||||
. I TEXT="**End Text**" S DONE=1 Q
|
||||
. W !,TEXT
|
||||
Q
|
||||
;
|
||||
;========================================================
|
||||
TEXT ;Custom Date Due help text.
|
||||
;;The general form for a Custom Date Due string is:
|
||||
;; FUNCTION(ARG1,ARG2,...,ARGN)
|
||||
;;where FUNCTION is MAX_DATE or MIN_DATE and the arguments have the form
|
||||
;;M+FREQ where M is a finding number and FREQ is a number followed by
|
||||
;;D for days, M for months, or Y for years.
|
||||
;;Here is an example:
|
||||
;; MAX_DATE(1+6M,3+1Y)
|
||||
;;This will take the date of finding 1 and add 6 months, the date of finding 3
|
||||
;;and add 1 year and set the date due to the maximum of those two dates.
|
||||
;;
|
||||
;;**End Text**
|
||||
Q
|
||||
;
|
||||
PXRMCDUE ;SLC/PKR - Custom date due calculation routines. ;06/30/2006
|
||||
;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
|
||||
;
|
||||
;========================================================
|
||||
CDBUILD(STRING,DA) ;Given a custom date due string build the data
|
||||
;structure. This is called by a new-style cross-reference after
|
||||
;the date due string has passed the input transform so we don't need
|
||||
;to validate the elements.
|
||||
;Do not execute as part of a verify fields.
|
||||
I $G(DIUTIL)="VERIFY FIELDS" Q
|
||||
;Do not execute as part of exchange.
|
||||
I $G(PXRMEXCH) Q
|
||||
N FDA,FILIST,FREQLIST,FUNCTION,IENB,IENS,IND,MSG,NARGS,PFSTACK
|
||||
S STRING=$$UP^XLFSTR(STRING)
|
||||
D PARSE(STRING,.FUNCTION,.NARGS,.FILIST,.FREQLIST)
|
||||
S IENS=DA_","
|
||||
S FDA(811.9,IENS,46)=FUNCTION,FDA(811.9,IENS,47)=NARGS
|
||||
S IENB=DA
|
||||
F IND=1:1:NARGS D
|
||||
. S IENB=IENB+1
|
||||
. S IENS="+"_IENB_","_DA_","
|
||||
. S FDA(811.948,IENS,.01)=FILIST(IND)
|
||||
. S FDA(811.948,IENS,.02)=FREQLIST(IND)
|
||||
D UPDATE^DIE("","FDA","","MSG")
|
||||
I $D(MSG) D
|
||||
. W !,"The update failed, UPDATE^DIE returned the following error message:"
|
||||
. D AWRITE^PXRMUTIL("MSG")
|
||||
Q
|
||||
;
|
||||
;========================================================
|
||||
CDUEDATE(DEFARR,FIEVAL) ;Do the custom date due calculation and return
|
||||
;the due date.
|
||||
N DATE,DDUE,DLIST,FI,FREQ,FUNCTION,IND,NARGS,TEMP
|
||||
S FUNCTION=$P(DEFARR(46),U,1)
|
||||
S NARGS=$P(DEFARR(46),U,2)
|
||||
F IND=1:1:NARGS D
|
||||
. S TEMP=DEFARR(47,IND,0)
|
||||
. S FI=$P(TEMP,U,1)
|
||||
. S FREQ=$P(TEMP,U,2)
|
||||
. S DATE=+$G(FIEVAL(FI,"DATE"))
|
||||
. S DLIST(IND)=$$NEWDATE^PXRMDATE(DATE,FREQ)
|
||||
S TEMP=$S(FUNCTION="MAX_DATE":$$MAXDATE(NARGS,.DLIST),FUNCTION="MIN_DATE":$$MINDATE(NARGS,.DLIST))
|
||||
S DDUE=$P(TEMP,U,1)
|
||||
I DDUE=0 Q -1
|
||||
S IND=$P(TEMP,U,2)
|
||||
S TEMP=DEFARR(47,IND,0)
|
||||
S FI=$P(TEMP,U,1)
|
||||
S FREQ=$P(TEMP,U,2)
|
||||
S DATE=+$G(FIEVAL(FI,"DATE"))
|
||||
S ^TMP(PXRMPID,$J,PXRMITEM,"zCDUE")=FI_U_FREQ_U_DATE
|
||||
Q DDUE
|
||||
;
|
||||
;========================================================
|
||||
CDKILL(X,DA) ;
|
||||
;Do not execute as part of a verify fields.
|
||||
I $G(DIUTIL)="VERIFY FIELDS" Q
|
||||
;Do not execute as part of exchange.
|
||||
I $G(PXRMEXCH) Q
|
||||
K ^PXD(811.9,DA,46),^PXD(811.9,DA,47)
|
||||
Q
|
||||
;
|
||||
;========================================================
|
||||
MAXDATE(NARGS,DLIST) ;Return the maximum date from a list of dates in DLIST.
|
||||
N IND,INDS,MAXDATE
|
||||
S (INDS,MAXDATE)=0
|
||||
F IND=1:1:NARGS I DLIST(IND)>MAXDATE S MAXDATE=DLIST(IND),INDS=IND
|
||||
Q MAXDATE_U_INDS
|
||||
;
|
||||
;========================================================
|
||||
MINDATE(NARGS,DLIST) ;Return the minimum date from a list of dates in DLIST.
|
||||
;Only return 0 if there is no "real" date in the list.
|
||||
N DATE,IND,INDS,MINDATE
|
||||
S INDS=0
|
||||
S MINDATE=9991231
|
||||
F IND=1:1:NARGS S DATE=DLIST(IND) I DATE<MINDATE,DATE'=0 S MINDATE=DATE,INDS=IND
|
||||
I MINDATE=9991231 S MINDATE=0
|
||||
Q MINDATE_U_INDS
|
||||
;
|
||||
;========================================================
|
||||
OUTPUT(CDUEDATA,DEFARR) ;Build the custom date due output text.
|
||||
N CDUEFI,ENTRY,FINAME,TEXT,VPTR
|
||||
S CDUEFI=$P(CDUEDATA,U,1)
|
||||
S VPTR=$P(^PXD(811.9,DEFARR("IEN"),20,CDUEFI,0),U,1)
|
||||
S ENTRY="^"_$P(VPTR,";",2)_$P(VPTR,";",1)_",0)"
|
||||
S FINAME=$P(@ENTRY,U,1)
|
||||
S TEXT="Custom date due based on date of finding "_CDUEFI_" ("_FINAME_")"
|
||||
S TEXT=TEXT_" plus frequency of "_$P(CDUEDATA,U,2)_"."
|
||||
Q TEXT
|
||||
;
|
||||
;========================================================
|
||||
PARSE(STRING,FUNCTION,NARGS,FILIST,FREQLIST) ;Parse a custom date due
|
||||
;string and return the function, number of arguments, finding list,
|
||||
;and frequency list. An argument has the form M+NF where M is a
|
||||
;finding number, N is an integer, and F is D, M, or Y.
|
||||
N IND,OPER,PFSTACK
|
||||
S OPER=","
|
||||
D POSTFIX^PXRMSTAC(STRING,OPER,.PFSTACK)
|
||||
S FUNCTION=$$UP^XLFSTR(PFSTACK(1))
|
||||
S NARGS=0
|
||||
F IND=2:1:PFSTACK(0) D
|
||||
. I PFSTACK(IND)=OPER Q
|
||||
. S NARGS=NARGS+1
|
||||
. S FILIST(NARGS)=$P(PFSTACK(IND),"+",1)
|
||||
. S FREQLIST(NARGS)=$P(PFSTACK(IND),"+",2)
|
||||
Q
|
||||
;
|
||||
;========================================================
|
||||
VFREQ(FREQ) ;Make sure FREQ is a valid frequency.
|
||||
N VALID
|
||||
S VALID=1
|
||||
S FREQ=$$UP^XLFSTR(FREQ)
|
||||
I (FREQ'?1N.N1"D"),(FREQ'?1N.N1"M"),(FREQ'?1N.N1"Y") S VALID=0
|
||||
Q VALID
|
||||
;
|
||||
;========================================================
|
||||
VCDUE(STRING,DA) ;Make sure a custom date due string is valid.
|
||||
;Do not execute as part of a verify fields.
|
||||
I $G(DIUTIL)="VERIFY FIELDS" Q 1
|
||||
;Do not execute as part of exchange.
|
||||
I $G(PXRMEXCH) Q 1
|
||||
I '$D(DA) Q 1
|
||||
I $L(STRING)>245 Q 0
|
||||
N FILIST,FREQLIST,FUNCTION,IND,NARGS,TEXT,VALID
|
||||
D PARSE(STRING,.FUNCTION,.NARGS,.FILIST,.FREQLIST)
|
||||
S VALID=1
|
||||
I FUNCTION'="MIN_DATE",FUNCTION'="MAX_DATE" D
|
||||
. S TEXT=FUNCTION_" is not a valid custom date due function"
|
||||
. D EN^DDIOL(TEXT)
|
||||
. S VALID=0
|
||||
F IND=1:1:NARGS D
|
||||
. I '$D(^PXD(811.9,DA,20,FILIST(IND),0)) D
|
||||
.. S TEXT="Finding number "_FILIST(IND)_" is not a valid reminder finding"
|
||||
.. D EN^DDIOL(TEXT)
|
||||
.. S VALID=0
|
||||
. I '$$VFREQ(FREQLIST(IND)) D
|
||||
.. S TEXT=FREQLIST(IND)_" is not a valid frequency"
|
||||
.. D EN^DDIOL(TEXT)
|
||||
.. S VALID=0
|
||||
Q VALID
|
||||
;
|
||||
;========================================================
|
||||
XHELP ;Executable help for custom date due.
|
||||
N DONE,IND,TEXT
|
||||
S DONE=0
|
||||
F IND=1:1 Q:DONE D
|
||||
. S TEXT=$P($T(TEXT+IND),";",3)
|
||||
. I TEXT="**End Text**" S DONE=1 Q
|
||||
. W !,TEXT
|
||||
Q
|
||||
;
|
||||
;========================================================
|
||||
TEXT ;Custom Date Due help text.
|
||||
;;The general form for a Custom Date Due string is:
|
||||
;; FUNCTION(ARG1,ARG2,...,ARGN)
|
||||
;;where FUNCTION is MAX_DATE or MIN_DATE and the arguments have the form
|
||||
;;M+FREQ where M is a finding number and FREQ is a number followed by
|
||||
;;D for days, M for months, or Y for years.
|
||||
;;Here is an example:
|
||||
;; MAX_DATE(1+6M,3+1Y)
|
||||
;;This will take the date of finding 1 and add 6 months, the date of finding 3
|
||||
;;and add 1 year and set the date due to the maximum of those two dates.
|
||||
;;
|
||||
;;**End Text**
|
||||
Q
|
||||
;
|
||||
|
|
|
|||
|
|
@ -1,195 +1,194 @@
|
|||
PXRMCF ; SLC/PKR - Handle computed findings. ;07/25/2007
|
||||
;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
|
||||
;
|
||||
;=======================================================
|
||||
EVALFI(DFN,DEFARR,ENODE,FIEVAL) ;Evaluate computed findings.
|
||||
N FIEVT,FILENUM,FINDING,FINDPA,ITEM
|
||||
S FILENUM=$$GETFNUM^PXRMDATA(ENODE)
|
||||
S ITEM=""
|
||||
F S ITEM=$O(DEFARR("E",ENODE,ITEM)) Q:+ITEM=0 D
|
||||
. S FINDING=""
|
||||
. F S FINDING=$O(DEFARR("E",ENODE,ITEM,FINDING)) Q:+FINDING=0 D
|
||||
.. K FINDPA
|
||||
.. M FINDPA=DEFARR(20,FINDING)
|
||||
.. K FIEVT
|
||||
.. D FIEVAL(FILENUM,DFN,ITEM,.FINDPA,.FIEVT)
|
||||
.. M FIEVAL(FINDING)=FIEVT
|
||||
.. S FIEVAL(FINDING,"FINDING")=$P(FINDPA(0),U,1)
|
||||
Q
|
||||
;
|
||||
;=======================================================
|
||||
EVALPL(FINDPA,ENODE,TERMARR,PLIST) ;Patient list evaluator.
|
||||
;Return the list in ^TMP($J,PLIST)
|
||||
N ITEM,FILENUM,PFINDPA
|
||||
N TEMP,TFINDING,TFINDPA
|
||||
S FILENUM=$$GETFNUM^PXRMDATA(ENODE)
|
||||
S ITEM=""
|
||||
F S ITEM=$O(TERMARR("E",ENODE,ITEM)) Q:+ITEM=0 D
|
||||
. S TFINDING=""
|
||||
. F S TFINDING=$O(TERMARR("E",ENODE,ITEM,TFINDING)) Q:+TFINDING=0 D
|
||||
.. K PFINDPA,TFINDPA
|
||||
.. M TFINDPA=TERMARR(20,TFINDING)
|
||||
..;Set the finding parameters.
|
||||
.. D SPFINDPA^PXRMTERM(.FINDPA,.TFINDPA,.PFINDPA)
|
||||
.. D GPLIST(FILENUM,ITEM,.PFINDPA,PLIST)
|
||||
Q
|
||||
;
|
||||
;=======================================================
|
||||
EVALTERM(DFN,FINDPA,ENODE,TERMARR,TFIEVAL) ;General term
|
||||
;evaluator.
|
||||
N FIEVT,FILENUM,ITEM,PFINDPA
|
||||
N TEMP,TFINDING,TFINDPA
|
||||
S FILENUM=$$GETFNUM^PXRMDATA(ENODE)
|
||||
S ITEM=""
|
||||
F S ITEM=$O(TERMARR("E",ENODE,ITEM)) Q:+ITEM=0 D
|
||||
. S TFINDING=""
|
||||
. F S TFINDING=$O(TERMARR("E",ENODE,ITEM,TFINDING)) Q:+TFINDING=0 D
|
||||
.. K FIEVT,PFINDPA,TFINDPA
|
||||
.. M TFINDPA=TERMARR(20,TFINDING)
|
||||
..;Set the finding parameters.
|
||||
.. D SPFINDPA^PXRMTERM(.FINDPA,.TFINDPA,.PFINDPA)
|
||||
.. D FIEVAL(FILENUM,DFN,ITEM,.PFINDPA,.FIEVT)
|
||||
.. M TFIEVAL(TFINDING)=FIEVT
|
||||
.. S TFIEVAL(TFINDING,"FINDING")=$P(TFINDPA(0),U,1)
|
||||
Q
|
||||
;
|
||||
;=======================================================
|
||||
FIEVAL(FILENUM,DFN,ITEM,PFINDPA,FIEVAL) ;
|
||||
;Evaluate regular patient findings.
|
||||
N BDT,CASESEN,COND,CONVAL,DAS,DATA,DATE,EDT,FLIST,ICOND,IND
|
||||
N NFOUND,NGET,NOCC,NP,PDATA,ROUTINE
|
||||
N SAVE,SDIR,STATUSA,TEMP,TEST,TEXT,TYPE,UCIFS,VALUE,VSLIST
|
||||
;Set the finding search parameters.
|
||||
D SSPAR^PXRMUTIL(PFINDPA(0),.NOCC,.BDT,.EDT)
|
||||
S SDIR=$S(NOCC<0:+1,1:-1)
|
||||
S TEST=PFINDPA(15)
|
||||
D SCPAR^PXRMCOND(.PFINDPA,.CASESEN,.COND,.UCIFS,.ICOND,.VSLIST)
|
||||
S NGET=$S(UCIFS:50,$D(STATUSA):50,1:NOCC)
|
||||
;Make sure NGET has the same sign as NOCC.
|
||||
I NGET'=NOCC S NGET=NGET*($$ABS^XLFMTH(NOCC)/NOCC)
|
||||
S TEMP=^PXRMD(811.4,ITEM,0)
|
||||
S TYPE=$P(TEMP,U,5)
|
||||
I TYPE="" S TYPE="S"
|
||||
I TYPE="S" D
|
||||
. S ROUTINE=$P(TEMP,U,3)_"^"_$P(TEMP,U,2)_"(DFN,.TEST,.DATE,.VALUE,.TEXT)"
|
||||
. D @ROUTINE
|
||||
.;Make sure that the date is in range.
|
||||
. I TEST,DATE'<BDT,DATE'>EDT S NFOUND=1
|
||||
. E S NFOUND=0
|
||||
. I NFOUND D
|
||||
.. S TEST(1)=TEST,DATE(1)=DATE,TEXT(1)=$G(TEXT)
|
||||
.. S DATA(1,"VALUE")=$G(VALUE)
|
||||
.. I $D(VALUE)=11 S IND="" F S IND=$O(VALUE(IND)) Q:IND="" S DATA(1,IND)=VALUE(IND)
|
||||
I TYPE="M" D
|
||||
. S ROUTINE=$P(TEMP,U,3)_"^"_$P(TEMP,U,2)_"(DFN,NGET,BDT,EDT,.NFOUND,.TEST,.DATE,.DATA,.TEXT)"
|
||||
. D @ROUTINE
|
||||
I TYPE'="S",TYPE'="M" D
|
||||
. S NFOUND=0
|
||||
. S ^TMP(PXRMPID,$J,PXRMITEM,"WARNING","COMPUTED FINDING","WRONG TYPE")=TYPE_" IS NOT SUITABLE FOR REMINDER EVALUATION"
|
||||
I NFOUND=0 S FIEVAL=0 Q
|
||||
S NP=0
|
||||
F IND=1:1:NFOUND Q:NP=NOCC D
|
||||
. I TEST(IND),COND'="" D
|
||||
.. K PDATA M PDATA=DATA(IND)
|
||||
.. S CONVAL=$$COND^PXRMCOND(CASESEN,ICOND,VSLIST,.PDATA)
|
||||
. E S CONVAL=TEST(IND)
|
||||
. S SAVE=$S('UCIFS:1,(UCIFS&CONVAL):1,1:0)
|
||||
. I SAVE D
|
||||
.. S NP=NP+1
|
||||
.. S FIEVAL(NP)=CONVAL
|
||||
.. I COND'="" S FIEVAL(NP,"CONDITION")=CONVAL
|
||||
.. S FIEVAL(NP,"DATE")=DATE(IND)
|
||||
.. S FIEVAL(NP,"TEXT")=$G(TEXT(IND))
|
||||
.. M FIEVAL(NP)=DATA(IND)
|
||||
.. I $G(PXRMDEBG) M FIEVAL(NP,"CSUB")=DATA(IND)
|
||||
;
|
||||
;Save the finding result.
|
||||
D SFRES^PXRMUTIL(SDIR,NP,.FIEVAL)
|
||||
S FIEVAL("FILE NUMBER")=FILENUM
|
||||
Q
|
||||
;
|
||||
;=======================================================
|
||||
GPLIST(FILENUM,CFIEN,PFINDPA,PLIST) ;Add to the patient list
|
||||
;for a regular file.
|
||||
N BDT,CASESEN,COND,CONVAL,DAS,DATE,EDT,DATA,DFN,FLIST
|
||||
N ICOND,IND,IPLIST
|
||||
N NOCC,NOCCABS,NFOUND,NGET,NP,PARAM,ROUTINE
|
||||
N SAVE,SOURCE,STATUSA,TEMP,TEXT,TGLIST,TPLIST,TYPE
|
||||
N UCIFS,VALUE,VSLIST
|
||||
S TEMP=^PXRMD(811.4,CFIEN,0)
|
||||
S TYPE=$P(TEMP,U,5)
|
||||
I TYPE'="L" Q
|
||||
S TGLIST="GPLIST_PXRMCF"
|
||||
S PARAM=PFINDPA(15)
|
||||
S SOURCE=FILENUM_";"_CFIEN
|
||||
;Set the finding search parameters.
|
||||
D SSPAR^PXRMUTIL(PFINDPA(0),.NOCC,.BDT,.EDT)
|
||||
S NOCCABS=$$ABS^XLFMTH(NOCC)
|
||||
D SCPAR^PXRMCOND(.PFINDPA,.CASESEN,.COND,.UCIFS,.ICOND,.VSLIST)
|
||||
S NGET=$S(UCIFS:50,$D(STATUSA):50,1:NOCCABS)
|
||||
K ^TMP($J,TGLIST)
|
||||
S ROUTINE=$P(TEMP,U,3)_"^"_$P(TEMP,U,2)_"(NGET,BDT,EDT,TGLIST,PARAM)"
|
||||
D @ROUTINE
|
||||
;Routine should return:
|
||||
;^TMP($J,TGLIST,DFN,N)=DAS_U_DATE_U_FILENUM_U_ITEM_U_VALUE
|
||||
;Data values for condition are returned in
|
||||
;^TMP($J,TGLIST,DFN,N,SUB)=DATA(SUB)
|
||||
S DFN=""
|
||||
F S DFN=$O(^TMP($J,TGLIST,DFN)) Q:DFN="" D
|
||||
. K TPLIST
|
||||
. M TPLIST=^TMP($J,TGLIST,DFN)
|
||||
. S (IND,NFOUND)=0
|
||||
. K IPLIST
|
||||
. F S IND=$O(TPLIST(IND)) Q:(IND="")!(NFOUND=NOCCABS) D
|
||||
.. S TEMP=TPLIST(IND)
|
||||
.. K DATA M DATA=TPLIST(IND)
|
||||
.. S CONVAL=$S(COND'="":$$COND^PXRMCOND(CASESEN,ICOND,VSLIST,.DATA),1:1)
|
||||
.. S SAVE=$S('UCIFS:1,(UCIFS&CONVAL):1,1:0)
|
||||
.. I SAVE D
|
||||
... S NFOUND=NFOUND+1
|
||||
... S IPLIST(CONVAL,DFN,NFOUND,SOURCE)=TEMP
|
||||
. M ^TMP($J,PLIST)=IPLIST
|
||||
K ^TMP($J,TGLIST)
|
||||
Q
|
||||
;
|
||||
;=======================================================
|
||||
MHVOUT(INDENT,IFIEVAL,NLINES,TEXT) ;Produce the MHV output.
|
||||
N DATA,DATE,FIEN,IND,JND,NAME,NOUT,PNAME,TEMP,TEXTOUT,VALUE
|
||||
S FIEN=$P(IFIEVAL("FINDING"),";",1)
|
||||
S TEMP=^PXRMD(811.4,FIEN,0)
|
||||
S PNAME=$P(TEMP,U,4)
|
||||
I PNAME="" S PNAME=$P(TEMP,U,1)
|
||||
S NAME="Computed Finding: "_PNAME_" = "
|
||||
S IND=0
|
||||
F S IND=+$O(IFIEVAL(IND)) Q:IND=0 D
|
||||
. S VALUE=$G(IFIEVAL(IND,"VALUE"))
|
||||
. S DATE=IFIEVAL(IND,"DATE")
|
||||
. S TEMP=NAME_VALUE_" ("_$$EDATE^PXRMDATE(DATE)_")"
|
||||
. D FORMATS^PXRMTEXT(INDENT+2,PXRMRM,TEMP,.NOUT,.TEXTOUT)
|
||||
. F JND=1:1:NOUT S NLINES=NLINES+1,TEXT(NLINES)=TEXTOUT(JND)
|
||||
S NLINES=NLINES+1,TEXT(NLINES)=""
|
||||
Q
|
||||
;
|
||||
;=======================================================
|
||||
OUTPUT(INDENT,IFIEVAL,NLINES,TEXT) ;Produce the clinical
|
||||
;maintenance output.
|
||||
N DATA,DATE,FIEN,IND,JND,NOUT,PNAME,TEMP,TEXTOUT,VALUE
|
||||
S FIEN=$P(IFIEVAL("FINDING"),";",1)
|
||||
S TEMP=^PXRMD(811.4,FIEN,0)
|
||||
S PNAME=$P(TEMP,U,4)
|
||||
I PNAME="" S PNAME=$P(TEMP,U,1)
|
||||
S NLINES=NLINES+1
|
||||
S TEXT(NLINES)=$$INSCHR^PXRMEXLC(INDENT," ")_"Computed Finding: "_PNAME
|
||||
S IND=0
|
||||
F S IND=+$O(IFIEVAL(IND)) Q:IND=0 D
|
||||
. S DATE=IFIEVAL(IND,"DATE")
|
||||
. S TEMP=$$EDATE^PXRMDATE(DATE)
|
||||
. S VALUE=$G(IFIEVAL(IND,"VALUE"))
|
||||
. I VALUE'="" S TEMP=TEMP_" value - "_VALUE
|
||||
.;If there is text append it.
|
||||
. I $G(IFIEVAL(IND,"TEXT"))'="" S TEMP=TEMP_"; "_IFIEVAL(IND,"TEXT")
|
||||
. D FORMATS^PXRMTEXT(INDENT+2,PXRMRM,TEMP,.NOUT,.TEXTOUT)
|
||||
. F JND=1:1:NOUT S NLINES=NLINES+1,TEXT(NLINES)=TEXTOUT(JND)
|
||||
S NLINES=NLINES+1,TEXT(NLINES)=""
|
||||
Q
|
||||
;
|
||||
PXRMCF ; SLC/PKR - Handle computed findings. ;12/15/2004
|
||||
;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
|
||||
;
|
||||
;=======================================================
|
||||
EVALFI(DFN,DEFARR,ENODE,FIEVAL) ;Evaluate computed findings.
|
||||
N FIEVT,FILENUM,FINDING,FINDPA,ITEM
|
||||
S FILENUM=$$GETFNUM^PXRMDATA(ENODE)
|
||||
S ITEM=""
|
||||
F S ITEM=$O(DEFARR("E",ENODE,ITEM)) Q:+ITEM=0 D
|
||||
. S FINDING=""
|
||||
. F S FINDING=$O(DEFARR("E",ENODE,ITEM,FINDING)) Q:+FINDING=0 D
|
||||
.. K FINDPA
|
||||
.. M FINDPA=DEFARR(20,FINDING)
|
||||
.. K FIEVT
|
||||
.. D FIEVAL(FILENUM,DFN,ITEM,.FINDPA,.FIEVT)
|
||||
.. M FIEVAL(FINDING)=FIEVT
|
||||
.. S FIEVAL(FINDING,"FINDING")=$P(FINDPA(0),U,1)
|
||||
Q
|
||||
;
|
||||
;=======================================================
|
||||
EVALPL(FINDPA,ENODE,TERMARR,PLIST) ;Patient list evaluator.
|
||||
;Return the list in ^TMP($J,PLIST)
|
||||
N ITEM,FILENUM,PFINDPA
|
||||
N TEMP,TFINDING,TFINDPA
|
||||
S FILENUM=$$GETFNUM^PXRMDATA(ENODE)
|
||||
S ITEM=""
|
||||
F S ITEM=$O(TERMARR("E",ENODE,ITEM)) Q:+ITEM=0 D
|
||||
. S TFINDING=""
|
||||
. F S TFINDING=$O(TERMARR("E",ENODE,ITEM,TFINDING)) Q:+TFINDING=0 D
|
||||
.. K PFINDPA,TFINDPA
|
||||
.. M TFINDPA=TERMARR(20,TFINDING)
|
||||
..;Set the finding parameters.
|
||||
.. D SPFINDPA^PXRMTERM(.FINDPA,.TFINDPA,.PFINDPA)
|
||||
.. D GPLIST(FILENUM,ITEM,.PFINDPA,PLIST)
|
||||
Q
|
||||
;
|
||||
;=======================================================
|
||||
EVALTERM(DFN,FINDPA,ENODE,TERMARR,TFIEVAL) ;General term
|
||||
;evaluator.
|
||||
N FIEVT,FILENUM,ITEM,PFINDPA
|
||||
N TEMP,TFINDING,TFINDPA
|
||||
S FILENUM=$$GETFNUM^PXRMDATA(ENODE)
|
||||
S ITEM=""
|
||||
F S ITEM=$O(TERMARR("E",ENODE,ITEM)) Q:+ITEM=0 D
|
||||
. S TFINDING=""
|
||||
. F S TFINDING=$O(TERMARR("E",ENODE,ITEM,TFINDING)) Q:+TFINDING=0 D
|
||||
.. K FIEVT,PFINDPA,TFINDPA
|
||||
.. M TFINDPA=TERMARR(20,TFINDING)
|
||||
..;Set the finding parameters.
|
||||
.. D SPFINDPA^PXRMTERM(.FINDPA,.TFINDPA,.PFINDPA)
|
||||
.. D FIEVAL(FILENUM,DFN,ITEM,.PFINDPA,.FIEVT)
|
||||
.. M TFIEVAL(TFINDING)=FIEVT
|
||||
.. S TFIEVAL(TFINDING,"FINDING")=$P(TFINDPA(0),U,1)
|
||||
Q
|
||||
;
|
||||
;=======================================================
|
||||
FIEVAL(FILENUM,DFN,ITEM,PFINDPA,FIEVAL) ;
|
||||
;Evaluate regular patient findings.
|
||||
N BDT,CASESEN,COND,CONVAL,DAS,DATA,DATE,EDT,FLIST,ICOND,IND
|
||||
N NFOUND,NGET,NOCC,NP,PDATA,ROUTINE
|
||||
N SAVE,SDIR,STATUSA,TEMP,TEST,TEXT,TYPE,UCIFS,VALUE,VSLIST
|
||||
;Set the finding search parameters.
|
||||
D SSPAR^PXRMUTIL(PFINDPA(0),.NOCC,.BDT,.EDT)
|
||||
S SDIR=$S(NOCC<0:+1,1:-1)
|
||||
S NOCC=$S(NOCC<0:-NOCC,1:NOCC)
|
||||
S TEST=PFINDPA(15)
|
||||
D SCPAR^PXRMCOND(.PFINDPA,.CASESEN,.COND,.UCIFS,.ICOND,.VSLIST)
|
||||
S NGET=$S(UCIFS:"*",$D(STATUSA):"*",1:NOCC)
|
||||
S TEMP=^PXRMD(811.4,ITEM,0)
|
||||
S TYPE=$P(TEMP,U,5)
|
||||
I TYPE="" S TYPE="S"
|
||||
I TYPE="S" D
|
||||
. S ROUTINE=$P(TEMP,U,3)_"^"_$P(TEMP,U,2)_"(DFN,.TEST,.DATE,.VALUE,.TEXT)"
|
||||
. D @ROUTINE
|
||||
.;Make sure that the date is in range.
|
||||
. I TEST,DATE'<BDT,DATE'>EDT S NFOUND=1
|
||||
. E S NFOUND=0
|
||||
. I NFOUND D
|
||||
.. S TEST(1)=TEST,DATE(1)=DATE,TEXT(1)=$G(TEXT)
|
||||
.. S DATA(1,"VALUE")=$G(VALUE)
|
||||
.. I $D(VALUE)=11 S IND="" F S IND=$O(VALUE(IND)) Q:IND="" S DATA(1,IND)=VALUE(IND)
|
||||
I TYPE="M" D
|
||||
. S ROUTINE=$P(TEMP,U,3)_"^"_$P(TEMP,U,2)_"(DFN,NGET,BDT,EDT,.NFOUND,.TEST,.DATE,.DATA,.TEXT)"
|
||||
. D @ROUTINE
|
||||
I TYPE'="S",TYPE'="M" D
|
||||
. S NFOUND=0
|
||||
. S ^TMP(PXRMPID,$J,PXRMITEM,"WARNING","COMPUTED FINDING","WRONG TYPE")=TYPE_" IS NOT SUITABLE FOR REMINDER EVALUATION"
|
||||
I NFOUND=0 S FIEVAL=0 Q
|
||||
S NP=0
|
||||
F IND=1:1:NFOUND Q:NP=NOCC D
|
||||
. I TEST(IND),COND'="" D
|
||||
.. K PDATA M PDATA=DATA(IND)
|
||||
.. S CONVAL=$$COND^PXRMCOND(CASESEN,ICOND,VSLIST,.PDATA)
|
||||
. E S CONVAL=TEST(IND)
|
||||
. S SAVE=$S('UCIFS:1,(UCIFS&CONVAL):1,1:0)
|
||||
. I SAVE D
|
||||
.. S NP=NP+1
|
||||
.. S FIEVAL(NP)=CONVAL
|
||||
.. I COND'="" S FIEVAL(NP,"CONDITION")=CONVAL
|
||||
.. S FIEVAL(NP,"DATE")=DATE(IND)
|
||||
.. S FIEVAL(NP,"TEXT")=$G(TEXT(IND))
|
||||
.. M FIEVAL(NP)=DATA(IND)
|
||||
.. I $G(PXRMDEBG) M FIEVAL(NP,"CSUB")=DATA(IND)
|
||||
;
|
||||
;Save the finding result.
|
||||
D SFRES^PXRMUTIL(SDIR,NP,.FIEVAL)
|
||||
S FIEVAL("FILE NUMBER")=FILENUM
|
||||
Q
|
||||
;
|
||||
;=======================================================
|
||||
GPLIST(FILENUM,CFIEN,PFINDPA,PLIST) ;Add to the patient list
|
||||
;for a regular file.
|
||||
N BDT,CASESEN,COND,CONVAL,DAS,DATE,EDT,DATA,DFN,FLIST
|
||||
N ICOND,IND,IPLIST
|
||||
N NOCC,NOCCABS,NFOUND,NGET,NP,PARAM,ROUTINE
|
||||
N SAVE,SOURCE,STATUSA,TEMP,TEXT,TGLIST,TPLIST,TYPE
|
||||
N UCIFS,VALUE,VSLIST
|
||||
S TEMP=^PXRMD(811.4,CFIEN,0)
|
||||
S TYPE=$P(TEMP,U,5)
|
||||
I TYPE'="L" Q
|
||||
S TGLIST="GPLIST_PXRMCF"
|
||||
S PARAM=PFINDPA(15)
|
||||
S SOURCE=FILENUM_";"_CFIEN
|
||||
;Set the finding search parameters.
|
||||
D SSPAR^PXRMUTIL(PFINDPA(0),.NOCC,.BDT,.EDT)
|
||||
S NOCCABS=$$ABS^XLFMTH(NOCC)
|
||||
D SCPAR^PXRMCOND(.PFINDPA,.CASESEN,.COND,.UCIFS,.ICOND,.VSLIST)
|
||||
S NGET=$S(UCIFS:"*",$D(STATUSA):"*",1:NOCCABS)
|
||||
K ^TMP($J,TGLIST)
|
||||
S ROUTINE=$P(TEMP,U,3)_"^"_$P(TEMP,U,2)_"(NGET,BDT,EDT,TGLIST,PARAM)"
|
||||
D @ROUTINE
|
||||
;Routine should return:
|
||||
;^TMP($J,TGLIST,DFN,N)=DAS_U_DATE_U_FILENUM_U_ITEM_U_VALUE
|
||||
;Data values for condition are returned in
|
||||
;^TMP($J,TGLIST,DFN,N,SUB)=DATA(SUB)
|
||||
S DFN=""
|
||||
F S DFN=$O(^TMP($J,TGLIST,DFN)) Q:DFN="" D
|
||||
. K TPLIST
|
||||
. M TPLIST=^TMP($J,TGLIST,DFN)
|
||||
. S (IND,NFOUND)=0
|
||||
. K IPLIST
|
||||
. F S IND=$O(TPLIST(IND)) Q:(IND="")!(NFOUND=NOCCABS) D
|
||||
.. S TEMP=TPLIST(IND)
|
||||
.. K DATA M DATA=TPLIST(IND)
|
||||
.. S CONVAL=$S(COND'="":$$COND^PXRMCOND(CASESEN,ICOND,VSLIST,.DATA),1:1)
|
||||
.. S SAVE=$S('UCIFS:1,(UCIFS&CONVAL):1,1:0)
|
||||
.. I SAVE D
|
||||
... S NFOUND=NFOUND+1
|
||||
... S IPLIST(CONVAL,DFN,NFOUND,SOURCE)=TEMP
|
||||
. M ^TMP($J,PLIST)=IPLIST
|
||||
K ^TMP($J,TGLIST)
|
||||
Q
|
||||
;
|
||||
;=======================================================
|
||||
MHVOUT(INDENT,IFIEVAL,NLINES,TEXT) ;Produce the MHV output.
|
||||
N DATA,DATE,FIEN,IND,JND,NAME,NOUT,PNAME,TEMP,TEXTOUT,VALUE
|
||||
S FIEN=$P(IFIEVAL("FINDING"),";",1)
|
||||
S TEMP=^PXRMD(811.4,FIEN,0)
|
||||
S PNAME=$P(TEMP,U,4)
|
||||
I PNAME="" S PNAME=$P(TEMP,U,1)
|
||||
S NAME="Computed Finding: "_PNAME_" = "
|
||||
S IND=0
|
||||
F S IND=+$O(IFIEVAL(IND)) Q:IND=0 D
|
||||
. S VALUE=$G(IFIEVAL(IND,"VALUE"))
|
||||
. S DATE=IFIEVAL(IND,"DATE")
|
||||
. S TEMP=NAME_VALUE_" ("_$$EDATE^PXRMDATE(DATE)_")"
|
||||
. D FORMATS^PXRMTEXT(INDENT+2,PXRMRM,TEMP,.NOUT,.TEXTOUT)
|
||||
. F JND=1:1:NOUT S NLINES=NLINES+1,TEXT(NLINES)=TEXTOUT(JND)
|
||||
S NLINES=NLINES+1,TEXT(NLINES)=""
|
||||
Q
|
||||
;
|
||||
;=======================================================
|
||||
OUTPUT(INDENT,IFIEVAL,NLINES,TEXT) ;Produce the clinical
|
||||
;maintenance output.
|
||||
N DATA,DATE,FIEN,IND,JND,NOUT,PNAME,TEMP,TEXTOUT,VALUE
|
||||
S FIEN=$P(IFIEVAL("FINDING"),";",1)
|
||||
S TEMP=^PXRMD(811.4,FIEN,0)
|
||||
S PNAME=$P(TEMP,U,4)
|
||||
I PNAME="" S PNAME=$P(TEMP,U,1)
|
||||
S NLINES=NLINES+1
|
||||
S TEXT(NLINES)=$$INSCHR^PXRMEXLC(INDENT," ")_"Computed Finding: "_PNAME
|
||||
S IND=0
|
||||
F S IND=+$O(IFIEVAL(IND)) Q:IND=0 D
|
||||
. S DATE=IFIEVAL(IND,"DATE")
|
||||
. S TEMP=$$EDATE^PXRMDATE(DATE)
|
||||
. S VALUE=$G(IFIEVAL(IND,"VALUE"))
|
||||
. I VALUE'="" S TEMP=TEMP_" value - "_VALUE
|
||||
.;If there is text append it.
|
||||
. I $G(IFIEVAL(IND,"TEXT"))'="" S TEMP=TEMP_"; "_IFIEVAL(IND,"TEXT")
|
||||
. D FORMATS^PXRMTEXT(INDENT+2,PXRMRM,TEMP,.NOUT,.TEXTOUT)
|
||||
. F JND=1:1:NOUT S NLINES=NLINES+1,TEXT(NLINES)=TEXTOUT(JND)
|
||||
S NLINES=NLINES+1,TEXT(NLINES)=""
|
||||
Q
|
||||
;
|
||||
|
|
|
|||
|
|
@ -1,231 +1,230 @@
|
|||
PXRMCOND ; SLC/PKR - Routines for evaluating conditions. ;06/01/2007
|
||||
;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
|
||||
;
|
||||
;============================================================
|
||||
CASESEN(X,DA,FILENUM) ;
|
||||
;Called by xref on condition case sensitive field in 811.5 and 811.9.
|
||||
N COND,GBL
|
||||
S GBL=$$GET1^DID(FILENUM,"","","GLOBAL NAME")
|
||||
S GBL=GBL_DA(1)_",20,"_DA_",3)"
|
||||
S COND=$P(@GBL,U,1)
|
||||
D SICOND(COND,.DA,FILENUM)
|
||||
Q
|
||||
;
|
||||
;============================================================
|
||||
COND(CASESEN,ICOND,VSLIST,VA) ;Evaluate the condition.
|
||||
N CONVAL,IND,JND,NSTAR,SUB,TEMP,V,VSTAR
|
||||
S CONVAL=""
|
||||
;If there is no condition return true.
|
||||
I $L($G(ICOND))=0 Q 1
|
||||
S NSTAR=0
|
||||
F IND=1:1 S SUB=$P(VSLIST,";",IND) Q:SUB="" D
|
||||
. I SUB["*" S NSTAR=NSTAR+1,VSTAR(NSTAR)=$L(SUB,",")_U_SUB
|
||||
S V=$G(VA("VALUE"))
|
||||
I 'CASESEN S V=$$UP^XLFSTR(V)
|
||||
;Move all non "*" elements of VA into V.
|
||||
I VSLIST'="" D MV(VSLIST,CASESEN,.V,.VA)
|
||||
I NSTAR=0 X ICOND S CONVAL=$T
|
||||
I NSTAR>0 S CONVAL=$$STARCOND(CASESEN,ICOND,.V,.VA,NSTAR,.VSTAR)
|
||||
Q CONVAL
|
||||
;
|
||||
;============================================================
|
||||
KICOND(X,DA,FILENUM) ;
|
||||
;Do not execute as part of a verify fields.
|
||||
I $G(DIUTIL)="VERIFY FIELDS" Q
|
||||
;Do not execute as part of exchange.
|
||||
I $G(PXRMEXCH) Q
|
||||
S FILENUM=$G(FILENUM)
|
||||
I FILENUM=811.5 K ^PXRMD(811.5,DA(1),20,DA,10),^PXRMD(811.5,DA(1),20,DA,11)
|
||||
I FILENUM=811.9 K ^PXD(811.9,DA(1),20,DA,10),^PXD(811.9,DA(1),20,DA,11)
|
||||
Q
|
||||
;
|
||||
;============================================================
|
||||
MV(VSLIST,CASESEN,V,VA) ;Move the elements of VA included in VSLIST
|
||||
;into V and uppercase if necessary.
|
||||
N IND,NE,RV,RVA,SUB
|
||||
S NE=$L(VSLIST,";")-1
|
||||
F IND=1:1:NE D
|
||||
. S SUB=$P(VSLIST,";",IND)
|
||||
. I SUB["*" Q
|
||||
. S RV="V("_SUB_")",RVA="VA("_SUB_")"
|
||||
.;If VA(SUB) does not exist skip it.
|
||||
. I '$D(@RVA) Q
|
||||
. S @RV=$S('CASESEN:$$UP^XLFSTR(@RVA),1:@RVA)
|
||||
Q
|
||||
;
|
||||
;============================================================
|
||||
RECSUB(IND,V,VA,NSTAR,VSTAR,NM,VM,CASESEN,ICOND,CONVAL) ;Called recursively,
|
||||
;first substitutes V array elements with "*" in subscript with a
|
||||
;replacement value. Once all have been replaced test condition and
|
||||
;quit if true. If not true continue until all combinations have been
|
||||
;tested.
|
||||
N JND,RV,RVA,VSUB,VASUB
|
||||
F JND=1:1:NM(IND) Q:CONVAL D
|
||||
. S VASUB=VM(IND,JND)
|
||||
. S RVA="VA("_VASUB_")"
|
||||
. S SUB=$P(VSTAR(IND),U,2)
|
||||
. S RV="V("_SUB_")"
|
||||
. S @RV=$S('CASESEN:$$UP^XLFSTR(@RVA),1:@RVA)
|
||||
. I IND<NSTAR D RECSUB(IND+1,.V,.VA,NSTAR,.VSTAR,.NM,.VM,CASESEN,ICOND,.CONVAL)
|
||||
. I IND=NSTAR X ICOND S CONVAL=$T
|
||||
;If there were no substitutions to make, make sure the condition is
|
||||
;evaluated.
|
||||
I 'CONVAL,IND=NSTAR,NM(IND)=0 X ICOND S CONVAL=$T
|
||||
Q
|
||||
;
|
||||
;============================================================
|
||||
SCPAR(FINDPA,CASESEN,COND,UCIFS,ICOND,VSLIST) ;Set the Condition parameters.
|
||||
N CONDS
|
||||
S CONDS=$G(FINDPA(3))
|
||||
S COND=$P(CONDS,U,1)
|
||||
;Even if there is no condition UCIFS could be used for status search.
|
||||
S UCIFS=$P(CONDS,U,3)
|
||||
I COND="" Q
|
||||
S CASESEN=$P(CONDS,U,2)
|
||||
I CASESEN="" S CASESEN=1
|
||||
S ICOND=FINDPA(10),VSLIST=FINDPA(11)
|
||||
Q
|
||||
;
|
||||
;============================================================
|
||||
SICOND(X,DA,FILENUM) ;Set the internal condition field. Wrap all V() in $G.
|
||||
;Called by xref on condition field in 811.5 and 811.9.
|
||||
I X="" Q
|
||||
;Do not execute as part of a verify fields.
|
||||
I $G(DIUTIL)="VERIFY FIELDS" Q
|
||||
;Do not execute as part of exchange.
|
||||
I $G(PXRMEXCH) Q
|
||||
N CASESEN,GBL,ICOND,IND,SE,SS,SUB,SUBLIST,TEMP,VSLIST,VWSUB,XUP
|
||||
S GBL=$$GET1^DID(FILENUM,"","","GLOBAL NAME")
|
||||
S GBL=GBL_DA(1)_",20,"_DA_",3)"
|
||||
S CASESEN=$P(@GBL,U,2)
|
||||
I CASESEN="" S CASESEN=1
|
||||
;Find each V("sub") entry.
|
||||
S XUP=$$UP^XLFSTR(X)
|
||||
I 'CASESEN S (ICOND,X)=XUP
|
||||
I CASESEN S ICOND=$$STRREP^PXRMUTIL(X,"v(","V(")
|
||||
S SS=1,VSLIST=""
|
||||
F S SS=$F(XUP,"V(",SS) Q:SS=0 D
|
||||
. S SE=$F(X,")",SS)
|
||||
. S SUB=$E(X,SS,SE-2)
|
||||
. I $D(SUBLIST(SUB)) Q
|
||||
. S SUBLIST(SUB)=""
|
||||
. S VSLIST=VSLIST_SUB_";"
|
||||
. S VWSUB="V("_SUB_")"
|
||||
. S TEMP="$G("_VWSUB_")"
|
||||
. S ICOND=$$STRREP^PXRMUTIL(ICOND,VWSUB,TEMP)
|
||||
I FILENUM=811.5 S ^PXRMD(811.5,DA(1),20,DA,10)=ICOND,^PXRMD(811.5,DA(1),20,DA,11)=VSLIST
|
||||
I FILENUM=811.9 S ^PXD(811.9,DA(1),20,DA,10)=ICOND,^PXD(811.9,DA(1),20,DA,11)=VSLIST
|
||||
Q
|
||||
;
|
||||
;============================================================
|
||||
STARCOND(CASESEN,ICOND,V,VA,NSTAR,VSTAR) ;Execute a star condition,
|
||||
;look for any replacements for the * subscripts that will make the
|
||||
;Condition true.
|
||||
N CONVAL,IND,JND,KND,MATCH,NEWV,NM,NVA,ORV,REF,SUB,SUBL,TCOND,TEMP
|
||||
N VASUB,VSSUB,VM
|
||||
;Build a list of the subscripts in VA.
|
||||
S NVA=0,REF="VA"
|
||||
F S REF=$Q(@REF) Q:REF="" D
|
||||
. S SUB=$P(REF,"(",2)
|
||||
. S SUB=$P(SUB,")",1)
|
||||
. S SUBL=$L(SUB,",")
|
||||
. S NVA=NVA+1,VASUB(NVA)=SUBL_U_SUB
|
||||
;Build a list of replacements for the * subscripts.
|
||||
F IND=1:1:NSTAR D
|
||||
. S NM=0
|
||||
. S VSSUB=$P(VSTAR(IND),U,2)
|
||||
. S SUBL=+VSTAR(IND)
|
||||
. F JND=1:1:NVA D
|
||||
.. I +VASUB(JND)'=SUBL Q
|
||||
.. S SUB=$P(VASUB(JND),U,2)
|
||||
.. S MATCH=1
|
||||
.. F KND=1:1:SUBL D
|
||||
... S TEMP=$P(VSSUB,",",KND)
|
||||
... I TEMP["*" Q
|
||||
... I $P(SUB,",",KND)'=TEMP S MATCH=0,KND=SUBL
|
||||
.. I MATCH S NM=NM+1,VM(IND,NM)=SUB
|
||||
. S NM(IND)=NM
|
||||
S CONVAL=0
|
||||
F IND=1:1:NSTAR Q:CONVAL D RECSUB(IND,.V,.VA,NSTAR,.VSTAR,.NM,.VM,CASESEN,ICOND,.CONVAL)
|
||||
Q CONVAL
|
||||
;
|
||||
;============================================================
|
||||
VCOND(X) ;
|
||||
;Input transform on Condition field.
|
||||
;Do not execute as part of exchange.
|
||||
I $G(PXRMEXCH) Q 1
|
||||
;The CONDITION must start with "I ".
|
||||
S X=$$UP^XLFSTR(X)
|
||||
I $E(X,1,2)'="I " D Q 0
|
||||
. S X=""
|
||||
. D EN^DDIOL("CONDITION must start with ""I"" followed by a single space")
|
||||
;The CONDITION cannot contain "^".
|
||||
I X["^" D Q 0
|
||||
. S X=""
|
||||
. D EN^DDIOL("CONDITION cannot contain ""^""")
|
||||
;The CONDITION cannot contain "@".
|
||||
I X["@" D Q 0
|
||||
. S X=""
|
||||
. D EN^DDIOL("CONDITION cannot contain ""@""")
|
||||
;The rest of the condition can only contain spaces if they are in
|
||||
;a string.
|
||||
N COND,TEMP,VALID
|
||||
S COND=$E(X,3,$L(X))
|
||||
S VALID=$S(COND[" ":$$VSPACE(COND),1:1)
|
||||
I VALID S VALID=$S(COND["V(":$$VSUB(COND),1:1)
|
||||
I VALID D
|
||||
. D ^DIM
|
||||
. I '$D(X) D
|
||||
.. D EN^DDIOL("Not a valid MUMPS string")
|
||||
.. S VALID=0
|
||||
Q VALID
|
||||
;
|
||||
;============================================================
|
||||
VSPACE(COND) ;Make sure all spaces in the condition that come after
|
||||
;the beginning I are inside a quoted string.
|
||||
N CHAR,IND,IQ,JND,LQ,NIQ,NQP,NSP,QP,SP,SPACE,VALID
|
||||
S VALID=1
|
||||
S (LQ,NQP,NSP)=0
|
||||
F IND=1:1:$L(COND) D
|
||||
. S CHAR=$E(COND,IND)
|
||||
. I CHAR="""" D
|
||||
.. I LQ S NQP=NQP+1,QP(NQP)=LQ_U_IND,LQ=0
|
||||
.. E S LQ=IND
|
||||
. I CHAR=" " S NSP=NSP+1,SP(NSP)=IND
|
||||
S NIQ=0
|
||||
F IND=1:1:NSP D
|
||||
. S SPACE=SP(NSP)
|
||||
. S IQ=0
|
||||
. F JND=1:1:NQP D
|
||||
.. I SPACE>$P(QP(JND),U,1),SPACE<$P(QP(JND),U,2) S IQ=1,JND=NQP Q
|
||||
. S NIQ=$S(IQ:0,1:1)
|
||||
. I NIQ S IND=NSP Q
|
||||
I NIQ D
|
||||
. D EN^DDIOL("No spaces are allowed except in quoted strings!")
|
||||
. S VALID=0
|
||||
Q VALID
|
||||
;
|
||||
;============================================================
|
||||
VSUB(COND) ;Make sure all V subscripts are quoted strings, numbers
|
||||
;or quoted * strings.
|
||||
N IND,RP,SS,SUB,SUBL,VALID
|
||||
S (SS,VALID)=1
|
||||
F S SS=$F(COND,"V(",SS) Q:('VALID)!(SS=0) D
|
||||
. S RP=$F(COND,")",SS)-2
|
||||
. I RP=-2 D Q
|
||||
.. N TEXT
|
||||
.. S TEXT=$E(COND,SS-2,$L(COND))_" is missing a "")"""
|
||||
.. D EN^DDIOL(TEXT)
|
||||
.. S VALID=0
|
||||
. S SUBL=$E(COND,SS,RP)
|
||||
. F IND=1:1:$L(SUBL,",") D
|
||||
.. S SUB=$P(SUBL,",",IND)
|
||||
..;Check for a number.
|
||||
.. I SUB=+SUB Q
|
||||
..;Check for a wildcard, must be in quotes any number of * allowed.
|
||||
.. I SUB?1"""1"*"."*"""" Q
|
||||
.. ;Check for first and last character = to a ".
|
||||
.. I ($E(SUB,1)'="""")!($E(SUB,$L(SUB))'="""") S VALID=0
|
||||
I 'VALID D EN^DDIOL("All V subscripts must be quoted strings, numbers or *!")
|
||||
Q VALID
|
||||
;
|
||||
PXRMCOND ; SLC/PKR - Routines for evaluating conditions. ;11/01/2004
|
||||
;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
|
||||
;
|
||||
;============================================================
|
||||
CASESEN(X,DA,FILENUM) ;
|
||||
;Called by xref on condition case sensitive field in 811.5 and 811.9.
|
||||
N COND,GBL
|
||||
S GBL=$$GET1^DID(FILENUM,"","","GLOBAL NAME")
|
||||
S GBL=GBL_DA(1)_",20,"_DA_",3)"
|
||||
S COND=$P(@GBL,U,1)
|
||||
D SICOND(COND,.DA,FILENUM)
|
||||
Q
|
||||
;
|
||||
;============================================================
|
||||
COND(CASESEN,ICOND,VSLIST,VA) ;Evaluate the condition.
|
||||
N CONVAL,IND,JND,NSTAR,SUB,TEMP,V,VSTAR
|
||||
S CONVAL=""
|
||||
;If there is no condition return true.
|
||||
I $L($G(ICOND))=0 Q 1
|
||||
S NSTAR=0
|
||||
F IND=1:1 S SUB=$P(VSLIST,";",IND) Q:SUB="" D
|
||||
. I SUB["*" S NSTAR=NSTAR+1,VSTAR(NSTAR)=$L(SUB,",")_U_SUB
|
||||
S V=$G(VA("VALUE"))
|
||||
I 'CASESEN S V=$$UP^XLFSTR(V)
|
||||
;Move all non "*" elements of VA into V.
|
||||
I VSLIST'="" D MV(VSLIST,CASESEN,.V,.VA)
|
||||
I NSTAR=0 X ICOND S CONVAL=$T
|
||||
I NSTAR>0 S CONVAL=$$STARCOND(CASESEN,ICOND,.V,.VA,NSTAR,.VSTAR)
|
||||
Q CONVAL
|
||||
;
|
||||
;============================================================
|
||||
KICOND(X,DA,FILENUM) ;
|
||||
;Do not execute as part of a verify fields.
|
||||
I $G(DIUTIL)="VERIFY FIELDS" Q
|
||||
;Do not execute as part of exchange.
|
||||
I $G(PXRMEXCH) Q
|
||||
S FILENUM=$G(FILENUM)
|
||||
I FILENUM=811.5 K ^PXRMD(811.5,DA(1),20,DA,10),^PXRMD(811.5,DA(1),20,DA,11)
|
||||
I FILENUM=811.9 K ^PXD(811.9,DA(1),20,DA,10),^PXD(811.9,DA(1),20,DA,11)
|
||||
Q
|
||||
;
|
||||
;============================================================
|
||||
MV(VSLIST,CASESEN,V,VA) ;Move the elements of VA included in VSLIST
|
||||
;into V and uppercase if necessary.
|
||||
N IND,NE,RV,RVA,SUB
|
||||
S NE=$L(VSLIST,";")-1
|
||||
F IND=1:1:NE D
|
||||
. S SUB=$P(VSLIST,";",IND)
|
||||
. I SUB["*" Q
|
||||
. S RV="V("_SUB_")",RVA="VA("_SUB_")"
|
||||
.;If VA(SUB) does not exist skip it.
|
||||
. I '$D(@RVA) Q
|
||||
. S @RV=$S('CASESEN:$$UP^XLFSTR(@RVA),1:@RVA)
|
||||
Q
|
||||
;
|
||||
;============================================================
|
||||
RECSUB(IND,V,VA,NSTAR,VSTAR,NM,VM,CASESEN,ICOND,CONVAL) ;Called recursively,
|
||||
;first substitutes V array elements with "*" in subscript with a
|
||||
;replacement value. Once all have been replaced test condition and
|
||||
;quit if true. If not true continue until all combinations have been
|
||||
;tested.
|
||||
N JND,RV,RVA,VSUB,VASUB
|
||||
F JND=1:1:NM(IND) Q:CONVAL D
|
||||
. S VASUB=VM(IND,JND)
|
||||
. S RVA="VA("_VASUB_")"
|
||||
. S SUB=$P(VSTAR(IND),U,2)
|
||||
. S RV="V("_SUB_")"
|
||||
. S @RV=$S('CASESEN:$$UP^XLFSTR(@RVA),1:@RVA)
|
||||
. I IND<NSTAR D RECSUB(IND+1,.V,.VA,NSTAR,.VSTAR,.NM,.VM,CASESEN,ICOND,.CONVAL)
|
||||
. I IND=NSTAR X ICOND S CONVAL=$T
|
||||
;If there were no substitutions to make, make sure the condition is
|
||||
;evaluated.
|
||||
I 'CONVAL,IND=NSTAR,NM(IND)=0 X ICOND S CONVAL=$T
|
||||
Q
|
||||
;
|
||||
;============================================================
|
||||
SCPAR(FINDPA,CASESEN,COND,UCIFS,ICOND,VSLIST) ;Set the Condition parameters.
|
||||
N CONDS
|
||||
S CONDS=$G(FINDPA(3))
|
||||
S COND=$P(CONDS,U,1)
|
||||
S UCIFS=$S(COND="":0,1:$P(CONDS,U,3))
|
||||
I COND="" Q
|
||||
S CASESEN=$P(CONDS,U,2)
|
||||
I CASESEN="" S CASESEN=1
|
||||
S ICOND=FINDPA(10),VSLIST=FINDPA(11)
|
||||
Q
|
||||
;
|
||||
;============================================================
|
||||
SICOND(X,DA,FILENUM) ;Set the internal condition field. Wrap all V() in $G.
|
||||
;Called by xref on condition field in 811.5 and 811.9.
|
||||
I X="" Q
|
||||
;Do not execute as part of a verify fields.
|
||||
I $G(DIUTIL)="VERIFY FIELDS" Q
|
||||
;Do not execute as part of exchange.
|
||||
I $G(PXRMEXCH) Q
|
||||
N CASESEN,GBL,ICOND,IND,SE,SS,SUB,SUBLIST,TEMP,VSLIST,VWSUB,XUP
|
||||
S GBL=$$GET1^DID(FILENUM,"","","GLOBAL NAME")
|
||||
S GBL=GBL_DA(1)_",20,"_DA_",3)"
|
||||
S CASESEN=$P(@GBL,U,2)
|
||||
I CASESEN="" S CASESEN=1
|
||||
;Find each V("sub") entry.
|
||||
S XUP=$$UP^XLFSTR(X)
|
||||
I 'CASESEN S (ICOND,X)=XUP
|
||||
I CASESEN S ICOND=$$STRREP^PXRMUTIL(X,"v(","V(")
|
||||
S SS=1,VSLIST=""
|
||||
F S SS=$F(XUP,"V(",SS) Q:SS=0 D
|
||||
. S SE=$F(X,")",SS)
|
||||
. S SUB=$E(X,SS,SE-2)
|
||||
. I $D(SUBLIST(SUB)) Q
|
||||
. S SUBLIST(SUB)=""
|
||||
. S VSLIST=VSLIST_SUB_";"
|
||||
. S VWSUB="V("_SUB_")"
|
||||
. S TEMP="$G("_VWSUB_")"
|
||||
. S ICOND=$$STRREP^PXRMUTIL(ICOND,VWSUB,TEMP)
|
||||
I FILENUM=811.5 S ^PXRMD(811.5,DA(1),20,DA,10)=ICOND,^PXRMD(811.5,DA(1),20,DA,11)=VSLIST
|
||||
I FILENUM=811.9 S ^PXD(811.9,DA(1),20,DA,10)=ICOND,^PXD(811.9,DA(1),20,DA,11)=VSLIST
|
||||
Q
|
||||
;
|
||||
;============================================================
|
||||
STARCOND(CASESEN,ICOND,V,VA,NSTAR,VSTAR) ;Execute a star condition,
|
||||
;look for any replacements for the * subscripts that will make the
|
||||
;Condition true.
|
||||
N CONVAL,IND,JND,KND,MATCH,NEWV,NM,NVA,ORV,REF,SUB,SUBL,TCOND,TEMP
|
||||
N VASUB,VSSUB,VM
|
||||
;Build a list of the subscripts in VA.
|
||||
S NVA=0,REF="VA"
|
||||
F S REF=$Q(@REF) Q:REF="" D
|
||||
. S SUB=$P(REF,"(",2)
|
||||
. S SUB=$P(SUB,")",1)
|
||||
. S SUBL=$L(SUB,",")
|
||||
. S NVA=NVA+1,VASUB(NVA)=SUBL_U_SUB
|
||||
;Build a list of replacements for the * subscripts.
|
||||
F IND=1:1:NSTAR D
|
||||
. S NM=0
|
||||
. S VSSUB=$P(VSTAR(IND),U,2)
|
||||
. S SUBL=+VSTAR(IND)
|
||||
. F JND=1:1:NVA D
|
||||
.. I +VASUB(JND)'=SUBL Q
|
||||
.. S SUB=$P(VASUB(JND),U,2)
|
||||
.. S MATCH=1
|
||||
.. F KND=1:1:SUBL D
|
||||
... S TEMP=$P(VSSUB,",",KND)
|
||||
... I TEMP["*" Q
|
||||
... I $P(SUB,",",KND)'=TEMP S MATCH=0,KND=SUBL
|
||||
.. I MATCH S NM=NM+1,VM(IND,NM)=SUB
|
||||
. S NM(IND)=NM
|
||||
S CONVAL=0
|
||||
F IND=1:1:NSTAR Q:CONVAL D RECSUB(IND,.V,.VA,NSTAR,.VSTAR,.NM,.VM,CASESEN,ICOND,.CONVAL)
|
||||
Q CONVAL
|
||||
;
|
||||
;============================================================
|
||||
VCOND(X) ;
|
||||
;Input transform on Condition field.
|
||||
;Do not execute as part of exchange.
|
||||
I $G(PXRMEXCH) Q 1
|
||||
;The CONDITION must start with "I ".
|
||||
S X=$$UP^XLFSTR(X)
|
||||
I $E(X,1,2)'="I " D Q 0
|
||||
. S X=""
|
||||
. D EN^DDIOL("CONDITION must start with ""I"" followed by a single space")
|
||||
;The CONDITION cannot contain "^".
|
||||
I X["^" D Q 0
|
||||
. S X=""
|
||||
. D EN^DDIOL("CONDITION cannot contain ""^""")
|
||||
;The CONDITION cannot contain "@".
|
||||
I X["@" D Q 0
|
||||
. S X=""
|
||||
. D EN^DDIOL("CONDITION cannot contain ""@""")
|
||||
;The rest of the condition can only contain spaces if they are in
|
||||
;a string.
|
||||
N COND,TEMP,VALID
|
||||
S COND=$E(X,3,$L(X))
|
||||
S VALID=$S(COND[" ":$$VSPACE(COND),1:1)
|
||||
I VALID S VALID=$S(COND["V(":$$VSUB(COND),1:1)
|
||||
I VALID D
|
||||
. D ^DIM
|
||||
. I '$D(X) D
|
||||
.. D EN^DDIOL("Not a valid MUMPS string")
|
||||
.. S VALID=0
|
||||
Q VALID
|
||||
;
|
||||
;============================================================
|
||||
VSPACE(COND) ;Make sure all spaces in the condition that come after
|
||||
;the beginning I are inside a quoted string.
|
||||
N CHAR,IND,IQ,JND,LQ,NIQ,NQP,NSP,QP,SP,SPACE,VALID
|
||||
S VALID=1
|
||||
S (LQ,NQP,NSP)=0
|
||||
F IND=1:1:$L(COND) D
|
||||
. S CHAR=$E(COND,IND)
|
||||
. I CHAR="""" D
|
||||
.. I LQ S NQP=NQP+1,QP(NQP)=LQ_U_IND,LQ=0
|
||||
.. E S LQ=IND
|
||||
. I CHAR=" " S NSP=NSP+1,SP(NSP)=IND
|
||||
S NIQ=0
|
||||
F IND=1:1:NSP D
|
||||
. S SPACE=SP(NSP)
|
||||
. S IQ=0
|
||||
. F JND=1:1:NQP D
|
||||
.. I SPACE>$P(QP(JND),U,1),SPACE<$P(QP(JND),U,2) S IQ=1,JND=NQP Q
|
||||
. S NIQ=$S(IQ:0,1:1)
|
||||
. I NIQ S IND=NSP Q
|
||||
I NIQ D
|
||||
. D EN^DDIOL("No spaces are allowed except in quoted strings!")
|
||||
. S VALID=0
|
||||
Q VALID
|
||||
;
|
||||
;============================================================
|
||||
VSUB(COND) ;Make sure all V subscripts are quoted strings, numbers
|
||||
;or quoted * strings.
|
||||
N IND,RP,SS,SUB,SUBL,VALID
|
||||
S (SS,VALID)=1
|
||||
F S SS=$F(COND,"V(",SS) Q:('VALID)!(SS=0) D
|
||||
. S RP=$F(COND,")",SS)-2
|
||||
. I RP=-2 D Q
|
||||
.. N TEXT
|
||||
.. S TEXT=$E(COND,SS-2,$L(COND))_" is missing a "")"""
|
||||
.. D EN^DDIOL(TEXT)
|
||||
.. S VALID=0
|
||||
. S SUBL=$E(COND,SS,RP)
|
||||
. F IND=1:1:$L(SUBL,",") D
|
||||
.. S SUB=$P(SUBL,",",IND)
|
||||
..;Check for a number.
|
||||
.. I SUB=+SUB Q
|
||||
..;Check for a wildcard, must be in quotes any number of * allowed.
|
||||
.. I SUB?1"""1"*"."*"""" Q
|
||||
.. ;Check for first and last character = to a ".
|
||||
.. I ($E(SUB,1)'="""")!($E(SUB,$L(SUB))'="""") S VALID=0
|
||||
I 'VALID D EN^DDIOL("All V subscripts must be quoted strings, numbers or *!")
|
||||
Q VALID
|
||||
;
|
||||
|
|
|
|||
|
|
@ -1,173 +1,164 @@
|
|||
PXRMCOPY ; SLC/PKR,PJH - Copy various reminder files. ;09/13/2007
|
||||
;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
|
||||
;
|
||||
;=====================================================
|
||||
COPY(PROMPT,ROOT,WHAT) ;Copy an entry of ROOT into a new entry.
|
||||
N DIROUT,DTOUT,DUOUT
|
||||
F D GETORGR Q:$D(DIROUT) Q:$D(DTOUT)
|
||||
Q
|
||||
;
|
||||
;=====================================================
|
||||
GETORGR ;Look-up logic to get and copy source entry to destination.
|
||||
N DA,DIE,DIC,DIK,DIR,DIRUT,FDA,FIELDLEN,FILE
|
||||
N IENN,IENO,IENS,MSG,NAME,ORGNAME,X,Y
|
||||
S DIC=ROOT,DIC(0)="AEMQ",DIC("A")=PROMPT
|
||||
W !
|
||||
D ^DIC
|
||||
I $D(DUOUT)!$D(DTOUT) S DIROUT="" Q
|
||||
S IENO=$P(Y,U,1)
|
||||
I IENO=-1 S DIROUT="" Q
|
||||
;
|
||||
;Set the starting place for additions.
|
||||
D SETSTART^PXRMCOPY(DIC)
|
||||
S IENN=$$GETFOIEN(ROOT)
|
||||
D MERGE(IENN,IENO,ROOT)
|
||||
;
|
||||
;Get the new name.
|
||||
S ORGNAME=$P(@(ROOT_IENO_",0)"),U,1)
|
||||
S FILE=$$FNFR^PXRMUTIL(ROOT)
|
||||
S FIELDLEN=$$GET1^DID(FILE,.01,"","FIELD LENGTH")
|
||||
S DIR(0)="F"_U_"3:"_FIELDLEN_U_"K:(X?.N)!'(X'?1P.E) X"
|
||||
S DIR("A")="PLEASE ENTER A UNIQUE NAME"
|
||||
GETNAM D ^DIR
|
||||
I $D(DIRUT) D DELETE(ROOT,IENN) Q
|
||||
S NAME=Y
|
||||
;
|
||||
;Make sure the new name is valid.
|
||||
I '$$VNAME^PXRMINTR(NAME,FILE) G GETNAM
|
||||
;
|
||||
;Change to the new name.
|
||||
S IENS=IENN_","
|
||||
S FDA(FILE,IENS,.01)=NAME
|
||||
K MSG
|
||||
D FILE^DIE("","FDA","MSG")
|
||||
;Check to make sure the name was not a duplicate.
|
||||
I $G(MSG("DIERR",1))=740 D G GETNAM
|
||||
. W !,NAME," is not a unique name!"
|
||||
;Change the class to local and delete the sponsor.
|
||||
D SCAS(FILE,IENN,"L","")
|
||||
;Initialize the edit history.
|
||||
D INIEH(FILE,ROOT,IENN,IENO)
|
||||
;
|
||||
;Reindex the cross-references.
|
||||
S DIK=ROOT,DA=IENN
|
||||
D IX^DIK
|
||||
W !
|
||||
;
|
||||
;Tell the user what has happened and allow for editing of the new item.
|
||||
S DIR(0)="Y"
|
||||
S DIR("A")="Do you want to edit it now"
|
||||
S DIR("A",1)="The original "_WHAT_" "_ORGNAME_" has been copied into "_NAME_"."
|
||||
D ^DIR Q:$D(DIRUT)
|
||||
I Y D EDIT^PXRMEDIT(ROOT,IENN)
|
||||
Q
|
||||
;
|
||||
;=====================================================
|
||||
COPYLL ;Copy a location list.
|
||||
N PROMPT,ROOT,WHAT
|
||||
S WHAT="location list"
|
||||
S ROOT="^PXRMD(810.9,"
|
||||
S PROMPT="Select the reminder location list to copy: "
|
||||
D COPY(PROMPT,ROOT,WHAT)
|
||||
Q
|
||||
;
|
||||
;=====================================================
|
||||
COPYREM ;Copy a reminder definition.
|
||||
N PROMPT,ROOT,WHAT
|
||||
S WHAT="reminder"
|
||||
S ROOT="^PXD(811.9,"
|
||||
S PROMPT="Select the reminder definition to copy: "
|
||||
D COPY(PROMPT,ROOT,WHAT)
|
||||
Q
|
||||
;
|
||||
;=====================================================
|
||||
COPYTAX ;Copy a taxonomy.
|
||||
N PROMPT,ROOT,WHAT
|
||||
S WHAT="taxonomy"
|
||||
S ROOT="^PXD(811.2,"
|
||||
S PROMPT="Select the reminder taxonomy to copy: "
|
||||
D COPY(PROMPT,ROOT,WHAT)
|
||||
Q
|
||||
;
|
||||
;=====================================================
|
||||
COPYTERM ;Copy a reminder term.
|
||||
N PROMPT,ROOT,WHAT
|
||||
S WHAT="reminder term"
|
||||
S ROOT="^PXRMD(811.5,"
|
||||
S PROMPT="Select the reminder term to copy: "
|
||||
D COPY(PROMPT,ROOT,WHAT)
|
||||
Q
|
||||
;
|
||||
;=====================================================
|
||||
DELETE(DIK,DA) ;Delete the entry just added.
|
||||
D ^DIK
|
||||
W !!,"New entry not created due to invalid name!",!
|
||||
Q
|
||||
;
|
||||
;=====================================================
|
||||
GETFOIEN(ROOT) ;Return the first open IEN in ROOT. This should be called
|
||||
;after a call to SETSTART.
|
||||
N ENTRY,NIEN,OIEN
|
||||
S ENTRY=ROOT_0_")"
|
||||
S OIEN=$P(@ENTRY,U,3)
|
||||
S ENTRY=ROOT_OIEN_")"
|
||||
F S NIEN=$O(@ENTRY) Q:+(NIEN-OIEN)>1 Q:+NIEN'>0 S OIEN=NIEN,ENTRY=ROOT_NIEN_")"
|
||||
Q OIEN+1
|
||||
;
|
||||
;=====================================================
|
||||
INIEH(FILENUM,ROOT,IENN,IENO) ;Initialize the edit history after a copy.
|
||||
;First delete any existing history entries.
|
||||
N ENTRY,IND,IENS,FDA,FDAIEN,MSG,SFN,TARGET,WP
|
||||
D FIELD^DID(FILENUM,"EDIT HISTORY","","SPECIFIER","TARGET")
|
||||
S SFN=+$G(TARGET("SPECIFIER"))
|
||||
I SFN=0 Q
|
||||
S ENTRY=ROOT_IENN_",110)"
|
||||
S IND=0
|
||||
F S IND=$O(@ENTRY@(IND)) Q:+IND=0 D
|
||||
. S IENS=IND_","_IENN_","
|
||||
. S FDA(SFN,IENS,.01)="@"
|
||||
I $D(FDA(SFN)) D FILE^DIE("K","FDA","MSG")
|
||||
I $D(MSG) D AWRITE^PXRMUTIL("MSG")
|
||||
;Establish an initial entry in the edit history.
|
||||
K FDA,MSG
|
||||
S IENS="+1,"_IENN_","
|
||||
S FDAIEN(IENN)=IENN
|
||||
S FDA(SFN,IENS,.01)=$$FMTE^XLFDT($$NOW^XLFDT,"5Z")
|
||||
S FDA(SFN,IENS,1)=$$GET1^DIQ(200,DUZ,.01)
|
||||
S FDA(SFN,IENS,2)="WP(1,1)"
|
||||
S WP(1,1,1)="Copied from "_$$GET1^DIQ(FILENUM,IENO,.01)
|
||||
D UPDATE^DIE("E","FDA","FDAIEN","MSG")
|
||||
I $D(MSG) D AWRITE^PXRMUTIL("MSG")
|
||||
Q
|
||||
;
|
||||
;=====================================================
|
||||
MERGE(IENN,IENO,ROOT) ;Use MERGE to copy ROOT(IENO into ROOT(IENN.
|
||||
N DEST,SOURCE
|
||||
S DEST=ROOT_IENN_")"
|
||||
;Lock the file before merging.
|
||||
L +@DEST:10
|
||||
S SOURCE=ROOT_IENO_")"
|
||||
M @DEST=@SOURCE
|
||||
;Unlock the file
|
||||
L -@DEST
|
||||
Q
|
||||
;
|
||||
;=====================================================
|
||||
SCAS(FILENUM,IEN,CLASS,SPONSOR) ;Set the class field to CLASS and the sponsor
|
||||
;field to SPONSOR.
|
||||
N IENS,FDA,MSG
|
||||
S IENS=IEN_","
|
||||
S FDA(FILENUM,IENS,100)=CLASS
|
||||
S FDA(FILENUM,IENS,101)=SPONSOR
|
||||
D FILE^DIE("K","FDA","MSG")
|
||||
I $D(MSG) D AWRITE^PXRMUTIL("MSG")
|
||||
Q
|
||||
;
|
||||
;=====================================================
|
||||
SETSTART(ROOT) ;Set the starting value to add new entries. Start
|
||||
;at the begining so empty spaces are filled in.
|
||||
N CUR,ENTRY
|
||||
S ENTRY=ROOT_"0)"
|
||||
S $P(@ENTRY,U,3)=1
|
||||
Q
|
||||
;
|
||||
PXRMCOPY ; SLC/PKR,PJH - Copy various reminder files. ;05/11/2001
|
||||
;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
|
||||
;
|
||||
;=====================================================
|
||||
COPY(PROMPT,ROOT,WHAT) ;Copy an entry of ROOT into a new entry.
|
||||
N DIROUT,DTOUT,DUOUT
|
||||
F D GETORGR Q:$D(DIROUT) Q:$D(DTOUT)
|
||||
Q
|
||||
;
|
||||
;=====================================================
|
||||
GETORGR ;Look-up logic to get and copy source entry to destination.
|
||||
N DA,DIE,DIC,DIK,DIR,DIRUT,FDA,FIELDLEN,FILE
|
||||
N IENN,IENO,IENS,MSG,NAME,ORGNAME,X,Y
|
||||
S DIC=ROOT,DIC(0)="AEQ",DIC("A")=PROMPT
|
||||
W !
|
||||
D ^DIC
|
||||
I $D(DUOUT)!$D(DTOUT) S DIROUT="" Q
|
||||
S IENO=$P(Y,U,1)
|
||||
I IENO=-1 S DIROUT="" Q
|
||||
;
|
||||
;Set the starting place for additions.
|
||||
D SETSTART^PXRMCOPY(DIC)
|
||||
S IENN=$$GETFOIEN(ROOT)
|
||||
D MERGE(IENN,IENO,ROOT)
|
||||
;
|
||||
;Get the new name.
|
||||
S ORGNAME=$P(@(ROOT_IENO_",0)"),U,1)
|
||||
S FILE=$$FNFR^PXRMUTIL(ROOT)
|
||||
S FIELDLEN=$$GET1^DID(FILE,.01,"","FIELD LENGTH")
|
||||
S DIR(0)="F"_U_"3:"_FIELDLEN_U_"K:(X?.N)!'(X'?1P.E) X"
|
||||
S DIR("A")="PLEASE ENTER A UNIQUE NAME"
|
||||
GETNAM D ^DIR
|
||||
I $D(DIRUT) D DELETE(ROOT,IENN) Q
|
||||
S NAME=Y
|
||||
;
|
||||
;Make sure the new name is valid.
|
||||
I '$$VNAME^PXRMINTR(NAME,FILE) G GETNAM
|
||||
;
|
||||
;Change to the new name.
|
||||
S IENS=IENN_","
|
||||
S FDA(FILE,IENS,.01)=NAME
|
||||
K MSG
|
||||
D FILE^DIE("","FDA","MSG")
|
||||
;Check to make sure the name was not a duplicate.
|
||||
I $G(MSG("DIERR",1))=740 D G GETNAM
|
||||
. W !,NAME," is not a unique name!"
|
||||
;Change the class to local and delete the sponsor.
|
||||
D SCAS(FILE,IENN,"L","")
|
||||
;Initialize the edit history.
|
||||
D INIEH(FILE,ROOT,IENN,IENO)
|
||||
;
|
||||
;Reindex the cross-references.
|
||||
S DIK=ROOT,DA=IENN
|
||||
D IX^DIK
|
||||
W !
|
||||
;
|
||||
;Tell the user what has happened and allow for editing of the new item.
|
||||
S DIR(0)="Y"
|
||||
S DIR("A")="Do you want to edit it now"
|
||||
S DIR("A",1)="The original "_WHAT_" "_ORGNAME_" has been copied into "_NAME_"."
|
||||
D ^DIR Q:$D(DIRUT)
|
||||
I Y D EDIT^PXRMEDIT(ROOT,IENN)
|
||||
Q
|
||||
;
|
||||
;=====================================================
|
||||
COPYREM ;Copy a reminder definition.
|
||||
N PROMPT,ROOT,WHAT
|
||||
S WHAT="reminder"
|
||||
S ROOT="^PXD(811.9,"
|
||||
S PROMPT="Select the reminder item to copy: "
|
||||
D COPY(PROMPT,ROOT,WHAT)
|
||||
Q
|
||||
;
|
||||
;=====================================================
|
||||
COPYTAX ;Copy a taxonomy.
|
||||
N PROMPT,ROOT,WHAT
|
||||
S WHAT="taxonomy"
|
||||
S ROOT="^PXD(811.2,"
|
||||
S PROMPT="Select the taxonomy item to copy: "
|
||||
D COPY(PROMPT,ROOT,WHAT)
|
||||
Q
|
||||
;
|
||||
;=====================================================
|
||||
COPYTERM ;Copy a reminder term.
|
||||
N PROMPT,ROOT,WHAT
|
||||
S WHAT="reminder term"
|
||||
S ROOT="^PXRMD(811.5,"
|
||||
S PROMPT="Select the reminder term to copy: "
|
||||
D COPY(PROMPT,ROOT,WHAT)
|
||||
Q
|
||||
;
|
||||
;=====================================================
|
||||
DELETE(DIK,DA) ;Delete the entry just added.
|
||||
D ^DIK
|
||||
W !!,"New entry not created due to invalid name!",!
|
||||
Q
|
||||
;
|
||||
;=====================================================
|
||||
GETFOIEN(ROOT) ;Return the first open IEN in ROOT. This should be called
|
||||
;after a call to SETSTART.
|
||||
N ENTRY,NIEN,OIEN
|
||||
S ENTRY=ROOT_0_")"
|
||||
S OIEN=$P(@ENTRY,U,3)
|
||||
S ENTRY=ROOT_OIEN_")"
|
||||
F S NIEN=$O(@ENTRY) Q:+(NIEN-OIEN)>1 Q:+NIEN'>0 S OIEN=NIEN,ENTRY=ROOT_NIEN_")"
|
||||
Q OIEN+1
|
||||
;
|
||||
;=====================================================
|
||||
INIEH(FILENUM,ROOT,IENN,IENO) ;Initialize the edit history after a copy.
|
||||
;First delete any existing history entries.
|
||||
N ENTRY,IND,IENS,FDA,FDAIEN,MSG,SFN,TARGET,WP
|
||||
D FIELD^DID(FILENUM,"EDIT HISTORY","","SPECIFIER","TARGET")
|
||||
S SFN=+$G(TARGET("SPECIFIER"))
|
||||
I SFN=0 Q
|
||||
S ENTRY=ROOT_IENN_",110)"
|
||||
S IND=0
|
||||
F S IND=$O(@ENTRY@(IND)) Q:+IND=0 D
|
||||
. S IENS=IND_","_IENN_","
|
||||
. S FDA(SFN,IENS,.01)="@"
|
||||
I $D(FDA(SFN)) D FILE^DIE("K","FDA","MSG")
|
||||
I $D(MSG) D AWRITE^PXRMUTIL("MSG")
|
||||
;Establish an initial entry in the edit history.
|
||||
K FDA,MSG
|
||||
S IENS="+1,"_IENN_","
|
||||
S FDAIEN(IENN)=IENN
|
||||
S FDA(SFN,IENS,.01)=$$FMTE^XLFDT($$NOW^XLFDT,"5Z")
|
||||
S FDA(SFN,IENS,1)=$$GET1^DIQ(200,DUZ,.01)
|
||||
S FDA(SFN,IENS,2)="WP(1,1)"
|
||||
S WP(1,1,1)="Copied from "_$$GET1^DIQ(FILENUM,IENO,.01)
|
||||
D UPDATE^DIE("E","FDA","FDAIEN","MSG")
|
||||
I $D(MSG) D AWRITE^PXRMUTIL("MSG")
|
||||
Q
|
||||
;
|
||||
;=====================================================
|
||||
MERGE(IENN,IENO,ROOT) ;Use MERGE to copy ROOT(IENO into ROOT(IENN.
|
||||
N DEST,SOURCE
|
||||
S DEST=ROOT_IENN_")"
|
||||
;Lock the file before merging.
|
||||
L +@DEST:10
|
||||
S SOURCE=ROOT_IENO_")"
|
||||
M @DEST=@SOURCE
|
||||
;Unlock the file
|
||||
L -@DEST
|
||||
Q
|
||||
;
|
||||
;=====================================================
|
||||
SCAS(FILENUM,IEN,CLASS,SPONSOR) ;Set the class field to CLASS and the sponsor
|
||||
;field to SPONSOR.
|
||||
N IENS,FDA,MSG
|
||||
S IENS=IEN_","
|
||||
S FDA(FILENUM,IENS,100)=CLASS
|
||||
S FDA(FILENUM,IENS,101)=SPONSOR
|
||||
D FILE^DIE("K","FDA","MSG")
|
||||
I $D(MSG) D AWRITE^PXRMUTIL("MSG")
|
||||
Q
|
||||
;
|
||||
;=====================================================
|
||||
SETSTART(ROOT) ;Set the starting value to add new entries. Start
|
||||
;at the begining so empty spaces are filled in.
|
||||
N CUR,ENTRY
|
||||
S ENTRY=ROOT_"0)"
|
||||
S $P(@ENTRY,U,3)=1
|
||||
Q
|
||||
;
|
||||
|
|
|
|||
|
|
@ -1,61 +1,61 @@
|
|||
PXRMDATA ; SLC/PKR - Routines for getting data. ;04/02/2007
|
||||
;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
|
||||
;
|
||||
;===============================================
|
||||
GETDATA(FILENUM,DAS,FIEVT) ;Return data for a finding.
|
||||
K FIEVT
|
||||
I FILENUM=45 D GETDATA^PXRMDGPT(DAS,.FIEVT) Q
|
||||
I FILENUM=52 D GETDATA^PXRMDOUT(DAS,.FIEVT) Q
|
||||
I FILENUM=55 D GETDATA^PXRMDIN(DAS,.FIEVT) Q
|
||||
I FILENUM="55NVA" D GETDATA^PXRMDNVA(DAS,.FIEVT) Q
|
||||
I FILENUM=63 D GETDATA^PXRMLAB(DAS,.FIEVT) Q
|
||||
I FILENUM=70 D GETDATA^PXRMRAD(DAS,.FIEVT) Q
|
||||
I FILENUM=100 D GETDATA^PXRMORDR(DAS,.FIEVT) Q
|
||||
I FILENUM=120.5 D GETDATA^PXRMVITL(DAS,.FIEVT) Q
|
||||
I FILENUM=601.84 D GETDATA^PXRMMH(DAS,.FIEVT) Q
|
||||
I FILENUM=9000010 D GETDATA^PXRMVSIT(DAS,.FIEVT,1) Q
|
||||
I FILENUM=9000010.07 D GETDATA^PXRMVPOV(DAS,.FIEVT) Q
|
||||
I FILENUM=9000010.11 D GETDATA^PXRMIMM(DAS,.FIEVT) Q
|
||||
I FILENUM=9000010.12 D GETDATA^PXRMSKIN(DAS,.FIEVT) Q
|
||||
I FILENUM=9000010.13 D GETDATA^PXRMEXAM(DAS,.FIEVT) Q
|
||||
I FILENUM=9000010.16 D GETDATA^PXRMEDU(DAS,.FIEVT) Q
|
||||
I FILENUM=9000010.18 D GETDATA^PXRMVCPT(DAS,.FIEVT) Q
|
||||
I FILENUM=9000010.23 D GETDATA^PXRMHF(DAS,.FIEVT) Q
|
||||
I FILENUM=9000011 D GETDATA^PXRMPROB(DAS,.FIEVT) Q
|
||||
Q
|
||||
;
|
||||
;===============================================
|
||||
GETFNAME(FINDING) ;Given a finding of the form IEN;GLOBAL return its name.
|
||||
N DIC,DO,IEN,FNUM,GLOBAL
|
||||
S IEN=$P(FINDING,";",1)
|
||||
S GLOBAL=$P(FINDING,";",2)
|
||||
S GLOBAL=$S(GLOBAL="PS(55NVA,":"PS(50.7,",GLOBAL="PS(55,":"PSDRUG(",1:GLOBAL)
|
||||
S DIC="^"_GLOBAL
|
||||
D DO^DIC1
|
||||
S FNUM=+$P(DO,U,2)
|
||||
Q $$GET1^DIQ(FNUM,IEN,.01)
|
||||
;
|
||||
;===============================================
|
||||
GETFNUM(ENODE) ;Given an ENODE return the file number for the data source.
|
||||
I ENODE="AUTTEDT(" Q 9000010.16
|
||||
I ENODE="AUTTEXAM(" Q 9000010.13
|
||||
I ENODE="AUTTHF(" Q 9000010.23
|
||||
I ENODE="AUTTIMM(" Q 9000010.11
|
||||
I ENODE="AUTTSK(" Q 9000010.12
|
||||
I ENODE="GMRD(120.51," Q 120.5
|
||||
I ENODE="LAB(60," Q 63
|
||||
I ENODE="ORD(101.43," Q 100
|
||||
I ENODE="PXD(811.2," Q 811.2
|
||||
I ENODE="PXRMD(810.9," Q 9000010
|
||||
I ENODE="PXRMD(811.4," Q 811.4
|
||||
I ENODE="PXRMD(811.5," Q 811.5
|
||||
I ENODE="PS(50.605," Q 52_U_55_U_"55NVA"
|
||||
I ENODE="PS(55," Q 55
|
||||
I ENODE="PS(55NVA," Q "55NVA"
|
||||
I ENODE="PSDRUG(" Q 52_U_55_U_"55NVA"
|
||||
I ENODE="PSNDF(50.6," Q 52_U_55_U_"55NVA"
|
||||
I ENODE="PSRX(" Q 52
|
||||
I ENODE="RAMIS(71," Q 70
|
||||
I ENODE="YTT(601.71," Q 601.84
|
||||
Q 0
|
||||
;
|
||||
PXRMDATA ; SLC/PKR - Routines for getting data. ;07/17/2006
|
||||
;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
|
||||
;
|
||||
;===============================================
|
||||
GETDATA(FILENUM,DAS,FIEVT) ;Return data for a finding.
|
||||
K FIEVT
|
||||
I FILENUM=45 D GETDATA^PXRMDGPT(DAS,.FIEVT) Q
|
||||
I FILENUM=52 D GETDATA^PXRMDOUT(DAS,.FIEVT) Q
|
||||
I FILENUM=55 D GETDATA^PXRMDIN(DAS,.FIEVT) Q
|
||||
I FILENUM="55NVA" D GETDATA^PXRMDNVA(DAS,.FIEVT) Q
|
||||
I FILENUM=63 D GETDATA^PXRMLAB(DAS,.FIEVT) Q
|
||||
I FILENUM=70 D GETDATA^PXRMRAD(DAS,.FIEVT) Q
|
||||
I FILENUM=100 D GETDATA^PXRMORDR(DAS,.FIEVT) Q
|
||||
I FILENUM=120.5 D GETDATA^PXRMVITL(DAS,.FIEVT) Q
|
||||
I FILENUM=601.2 D GETDATA^PXRMMH(DAS,.FIEVT) Q
|
||||
I FILENUM=9000010 D GETDATA^PXRMVSIT(DAS,.FIEVT,1) Q
|
||||
I FILENUM=9000010.07 D GETDATA^PXRMVPOV(DAS,.FIEVT) Q
|
||||
I FILENUM=9000010.11 D GETDATA^PXRMIMM(DAS,.FIEVT) Q
|
||||
I FILENUM=9000010.12 D GETDATA^PXRMSKIN(DAS,.FIEVT) Q
|
||||
I FILENUM=9000010.13 D GETDATA^PXRMEXAM(DAS,.FIEVT) Q
|
||||
I FILENUM=9000010.16 D GETDATA^PXRMEDU(DAS,.FIEVT) Q
|
||||
I FILENUM=9000010.18 D GETDATA^PXRMVCPT(DAS,.FIEVT) Q
|
||||
I FILENUM=9000010.23 D GETDATA^PXRMHF(DAS,.FIEVT) Q
|
||||
I FILENUM=9000011 D GETDATA^PXRMPROB(DAS,.FIEVT) Q
|
||||
Q
|
||||
;
|
||||
;===============================================
|
||||
GETFNAME(FINDING) ;Given a finding of the form IEN;GLOBAL return its name.
|
||||
N DIC,DO,IEN,FNUM,GLOBAL
|
||||
S IEN=$P(FINDING,";",1)
|
||||
S GLOBAL=$P(FINDING,";",2)
|
||||
S GLOBAL=$S(GLOBAL="PS(55NVA,":"PS(50.7,",GLOBAL="PS(55,":"PSDRUG(",1:GLOBAL)
|
||||
S DIC="^"_GLOBAL
|
||||
D DO^DIC1
|
||||
S FNUM=+$P(DO,U,2)
|
||||
Q $$GET1^DIQ(FNUM,IEN,.01)
|
||||
;
|
||||
;===============================================
|
||||
GETFNUM(ENODE) ;Given an ENODE return the file number for the data source.
|
||||
I ENODE="AUTTEDT(" Q 9000010.16
|
||||
I ENODE="AUTTEXAM(" Q 9000010.13
|
||||
I ENODE="AUTTHF(" Q 9000010.23
|
||||
I ENODE="AUTTIMM(" Q 9000010.11
|
||||
I ENODE="AUTTSK(" Q 9000010.12
|
||||
I ENODE="GMRD(120.51," Q 120.5
|
||||
I ENODE="LAB(60," Q 63
|
||||
I ENODE="ORD(101.43," Q 100
|
||||
I ENODE="PXD(811.2," Q 811.2
|
||||
I ENODE="PXRMD(810.9," Q 9000010
|
||||
I ENODE="PXRMD(811.4," Q 811.4
|
||||
I ENODE="PXRMD(811.5," Q 811.5
|
||||
I ENODE="PS(50.605," Q 52_U_55_U_"55NVA"
|
||||
I ENODE="PS(55," Q 55
|
||||
I ENODE="PS(55NVA," Q "55NVA"
|
||||
I ENODE="PSDRUG(" Q 52_U_55_U_"55NVA"
|
||||
I ENODE="PSNDF(50.6," Q 52_U_55_U_"55NVA"
|
||||
I ENODE="PSRX(" Q 52
|
||||
I ENODE="RAMIS(71," Q 70
|
||||
I ENODE="YTT(601," Q 601.2
|
||||
Q 0
|
||||
;
|
||||
|
|
|
|||
|
|
@ -1,255 +1,252 @@
|
|||
PXRMDATE ; SLC/PKR - Clinical Reminders date utilities. ;01/24/2007
|
||||
;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
|
||||
;
|
||||
;==================================================
|
||||
CEFD(FDA) ;Called by the Exchange Utility only if the input packed
|
||||
;reminder was packed under v1.5 Move Effective Date to Beginning Date.
|
||||
N IND
|
||||
S IND=""
|
||||
F S IND=$O(FDA(811.902,IND)) Q:IND="" D
|
||||
. I '$D(FDA(811.902,IND,12)) Q
|
||||
.;If the EFFECTIVE PERIOD exists don't do anything.
|
||||
. I $D(FDA(811.902,IND,9)) Q
|
||||
. S FDA(811.902,IND,9)=FDA(811.902,IND,12)
|
||||
. K FDA(811.902,IND,12)
|
||||
Q
|
||||
;
|
||||
;==================================================
|
||||
COMPARE(X) ;Compare beginning and ending dates, give a warning if
|
||||
;Ending Date comes before Beginning Date. Called by ADATE xref in
|
||||
;definitions and terms.
|
||||
;Do not execute as part of exchange.
|
||||
I $G(PXRMEXCH) Q
|
||||
N BDT,EDT
|
||||
S BDT=$S(X(1)'="":$$CTFMD^PXRMDATE(X(1)),1:0)
|
||||
S EDT=X(2)
|
||||
I EDT="" S EDT="T"
|
||||
S EDT=$$CTFMD^PXRMDATE(EDT)
|
||||
;If EDT does not contain a time set it to the end of the day.
|
||||
I EDT'["." S EDT=EDT_".235959"
|
||||
I EDT<BDT D
|
||||
. S BDT=$S(X(1)'="":X(1),1:"")
|
||||
. S EDT=$S(X(2)'="":X(2),1:"T@2400")
|
||||
. S TEXT="Warning the ending date ("_EDT_") is before the beginning date ("_BDT_")"
|
||||
. D EN^DDIOL(TEXT)
|
||||
Q
|
||||
;
|
||||
;==================================================
|
||||
COTN(EFP) ;Convert an Effective Period to the new date/time format.
|
||||
;Possible effective periods are ND, NM, or NY where N is an integer.
|
||||
S EFP=$$UP^XLFSTR(EFP)
|
||||
I (EFP?1N.N1"D")!(EFP?1N.N1"M")!(EFP?1N.N1"Y") D
|
||||
. S NUM=+EFP
|
||||
. S EFP=$S(NUM=0:"T",1:"T-"_EFP)
|
||||
Q EFP
|
||||
;
|
||||
;==================================================
|
||||
CTFMD(DATE) ;Convert DATE which may be in any of the FileMan acceptable
|
||||
;forms as well as T-NY to a FileMan date. Also understands LAD for
|
||||
;Last Admission Date.
|
||||
N %DT,ND,X,Y
|
||||
;Already a FileMan date?
|
||||
S ND=+DATE
|
||||
I (ND'<1000000),(ND'>9991231) Q DATE
|
||||
;Check for a date FileMan understands.
|
||||
S X=DATE,%DT="ST"
|
||||
D ^%DT
|
||||
;If it is not a FileMan date check for a symbolic date.
|
||||
I Y=-1 S Y=$$SYMDATE(DATE)
|
||||
;If it is not a date that is understood by SYMDATE return -1
|
||||
I Y=-1 Q -1
|
||||
I $G(PXRMDATE)'="",$$ISVSYMD(DATE) D
|
||||
. N DIFFS
|
||||
. S DIFFS=-$$FMDIFF^XLFDT(DT,PXRMDATE,2)
|
||||
. S Y=$$FMADD^XLFDT(Y,0,0,0,DIFFS)
|
||||
I DATE["LAD" D
|
||||
. I $G(PXRMLAD)="" S Y=0
|
||||
. E D
|
||||
.. N DIFFS
|
||||
.. S DIFFS=-$$FMDIFF^XLFDT(DT,$G(PXRMLAD),2)
|
||||
.. S Y=$$FMADD^XLFDT(Y,0,0,0,DIFFS)
|
||||
Q Y
|
||||
;
|
||||
;=================================================
|
||||
DCHECK(DATE) ;Trap for special characters before calling CTFMD^PXRMDATE.
|
||||
;Used in DIR("PRE") for date inputs.
|
||||
I $D(DTOUT) Q DATE
|
||||
I DATE="" Q DATE
|
||||
I DATE["^" Q DATE
|
||||
I DATE["?" Q DATE
|
||||
Q $$CTFMD^PXRMDATE(DATE)
|
||||
;
|
||||
;==================================================
|
||||
DUE(DEFARR,RESDATE,FREQ,DUE,DUEDATE,FIEVAL) ;Compute the due date.
|
||||
;This is the date of the resolution finding + the reminder frequency.
|
||||
;Subtract the due in advance time to see if the reminder should be
|
||||
;marked as due soon.
|
||||
;
|
||||
N DATE,DIAT,DIATOK,LDATE,PXRMITEM,TDDUE,TODAY
|
||||
S PXRMITEM=DEFARR("IEN")
|
||||
;If the final frequency is 0Y then the reminder is not due.
|
||||
I FREQ="0Y" S DUE=0,DUEDATE="" Q
|
||||
;
|
||||
S DUEDATE=""
|
||||
;Check for custom date due.
|
||||
I DEFARR(45)'="" S DUEDATE=$$CDUEDATE^PXRMCDUE(.DEFARR,.FIEVAL)
|
||||
I DUEDATE'="",DUEDATE'=-1 G SETDUE
|
||||
;
|
||||
;No custom date due, do regular date calculation.
|
||||
I (FREQ="")!(FREQ=-1) D Q
|
||||
. S ^TMP(PXRMPID,$J,PXRMITEM,"WARNING","NOFREQ")="No reminder frequency - cannot compute due date!"
|
||||
. S (DUE,DUEDATE)="CNBD"
|
||||
;
|
||||
S LDATE=$S(RESDATE["X":0,1:+RESDATE)
|
||||
I LDATE=0 S (DUE,DUEDATE)="DUE NOW" Q
|
||||
S DATE=$$FULLDATE(LDATE),DUEDATE=$$NEWDATE(DATE,FREQ)
|
||||
;
|
||||
SETDUE ;If the due date is less than or equal to today's date the reminder
|
||||
;is due.
|
||||
S TODAY=$$NOW^PXRMDATE
|
||||
I +DUEDATE'>TODAY S DUE="DUE NOW" Q
|
||||
;
|
||||
S DIAT="-"_$P(DEFARR(0),U,4)
|
||||
I DIAT="-" D
|
||||
. S DIATOK=0
|
||||
. S ^TMP(PXRMPID,$J,PXRMITEM,"WARNING","DIAT")="Warning no do in advance time"
|
||||
E S DIATOK=1
|
||||
;
|
||||
S TDDUE=$S(DIATOK=1:$$NEWDATE(DUEDATE,DIAT),1:DUEDATE)
|
||||
S DUE=$S(TDDUE'>TODAY:"DUE SOON",1:"RESOLVED")
|
||||
Q
|
||||
;
|
||||
;==================================================
|
||||
DURATION(START,STOP) ;Return the number days between the Start Date and
|
||||
;Stop Date.
|
||||
I +START=0 Q 0
|
||||
N PXRMNOW
|
||||
S PXRMNOW=$$NOW^PXRMDATE
|
||||
I START>PXRMNOW Q 0
|
||||
I (STOP="")!(STOP>PXRMNOW) S STOP=PXRMNOW
|
||||
Q $$FMDIFF^XLFDT(STOP,START)
|
||||
;
|
||||
;==================================================
|
||||
EDATE(DATE) ;Check for an historical (event) date, format as appropriate.
|
||||
Q $$FMTE^XLFDT(DATE,"5DZ")
|
||||
;
|
||||
;==================================================
|
||||
FULLDATE(DATE) ;See if DATE is a full date, i.e., it has a month and
|
||||
;a day along with a year. If the month is missing assume Jan. If the
|
||||
;day is missing assume the first. Issue a warning so the user knows
|
||||
;what happened. DATE should be in Fileman format.
|
||||
N DAY,MISSING,MONTH,TDATE,YEAR
|
||||
S TDATE=DATE
|
||||
S MISSING=0
|
||||
S DAY=$E(DATE,6,7)
|
||||
S MONTH=$E(DATE,4,5)
|
||||
S YEAR=$E(DATE,1,3)
|
||||
I +DAY=0 D
|
||||
. S DAY=1
|
||||
. S MISSING=1
|
||||
. S ^TMP(PXRMPID,$J,PXRMITEM,"INFO","NO DAY")="Encounter date missing the day, using the first for the date due calculation."
|
||||
I +MONTH=0 D
|
||||
. S MONTH=1
|
||||
. S MISSING=1
|
||||
. S ^TMP(PXRMPID,$J,PXRMITEM,"INFO","NO MONTH")="Encounter date missing the month, using January for the date due calculation."
|
||||
I MISSING D
|
||||
. S TDATE=(YEAR*1E4)+(MONTH*1E2)+DAY
|
||||
. I DATE["E" S TDATE=TDATE_"E"
|
||||
Q TDATE
|
||||
;
|
||||
;==================================================
|
||||
FRQINDAY(FREQ) ;Given a frequency in the form ND, NM, or NY where N is a
|
||||
;number and D stands for days, M for months, and Y for years return
|
||||
;the value in days.
|
||||
I FREQ="" Q ""
|
||||
N CODE,LEN,MULT,NUM
|
||||
S LEN=$L(FREQ)
|
||||
S NUM=$E(FREQ,1,LEN-1)
|
||||
S CODE=$E(FREQ,LEN,LEN)
|
||||
S MULT=1.0
|
||||
I CODE="M" S MULT=30.42
|
||||
I CODE="Y" S MULT=365.25
|
||||
Q +(MULT*NUM)
|
||||
;
|
||||
;==================================================
|
||||
ISVSYMD(DATE) ;Return true if DATE is a valid symbolic date.
|
||||
N P1,P1OK,P2,P2OK,OP,PAT
|
||||
S DATE=$P(DATE,"@",1)
|
||||
S OP=$S(DATE["+":"+",1:"-")
|
||||
S P1=$P(DATE,OP,1),P1OK=0
|
||||
F PAT="T","TODAY","N","NOW" I P1=PAT S P1OK=1 Q:P1OK
|
||||
I PAT=DATE Q 1
|
||||
S P2=$P(DATE,OP,2),P2OK=0
|
||||
F PAT="1N.N","1N.N1""D""","1N.N1""M""","1N.N1""Y""" I P2?@PAT S P2OK=1 Q:P2OK
|
||||
Q P1OK&P2OK
|
||||
;
|
||||
;==================================================
|
||||
NEWDATE(FMDATE,OFFSET) ;Given a date in VA Fileman format (FMDATE) and an
|
||||
;offset of the form NY, NM, ND where N is a number and Y stands for
|
||||
;years, M for months, and D for days return the new date in VA Fileman
|
||||
;format.
|
||||
I FMDATE=0 Q 0
|
||||
N LEN,NEWDATE,NUM,UNIT
|
||||
S LEN=$L(OFFSET)
|
||||
S NUM=+$E(OFFSET,1,LEN-1)
|
||||
S UNIT=$E(OFFSET,LEN)
|
||||
I UNIT="D" G DAY
|
||||
I UNIT="M" G MONTH
|
||||
I UNIT="Y" G YEAR
|
||||
;Unknown unit just return the original date
|
||||
Q FMDATE
|
||||
DAY ;
|
||||
S NEWDATE=+$$FMADD^XLFDT(FMDATE,NUM)
|
||||
Q NEWDATE
|
||||
MONTH ;
|
||||
;Convert the months to days and then add the days using the DAY code.
|
||||
;Multiply the number of months by the average number of days in a month.
|
||||
N INT,FRAC
|
||||
S NUM=30.42*NUM
|
||||
;Round the number of days, FMADD^XLFDT has problems with non-integer
|
||||
;days.
|
||||
S INT=+$P(NUM,".",1)
|
||||
S FRAC=NUM-INT
|
||||
I FRAC<0.5 S NUM=INT
|
||||
E S NUM=INT+1
|
||||
G DAY
|
||||
Q
|
||||
YEAR ;
|
||||
Q FMDATE+(10000*NUM)
|
||||
;
|
||||
;==================================================
|
||||
NOW() ;If the reminder global PXRMDATE is defined return it, otherwise
|
||||
;return the current date and time.
|
||||
Q $S(+$G(PXRMDATE)>0:PXRMDATE,1:$$NOW^XLFDT)
|
||||
;
|
||||
;==================================================
|
||||
SYMDATE(DATE) ;Convert a symbolic date into a FileMan date.
|
||||
N %DT,OPER,PFSTACK,SYM,TIME,X,Y
|
||||
S TIME=$P(DATE,"@",2),DATE=$P(DATE,"@",1)
|
||||
S X=$S(DATE="LAD":$G(PXRMLAD),1:"")
|
||||
I X="" D
|
||||
. S OPER="+-"
|
||||
. D POSTFIX^PXRMSTAC(DATE,OPER,.PFSTACK)
|
||||
I PFSTACK(0)=3 D
|
||||
. S SYM=PFSTACK(1)
|
||||
. S SYM=$S(SYM="LAD":"T",SYM="N":"N",SYM="NOW":"N",SYM="T":"T",SYM="TODAY":"T",1:"")
|
||||
. I SYM="" S Y=-1 Q
|
||||
.;FileMan only handles D, W, or M so convert Y to months.
|
||||
. I PFSTACK(2)["Y" S PFSTACK(2)=+PFSTACK(2)*12_"M"
|
||||
. S X=SYM_PFSTACK(3)_PFSTACK(2)
|
||||
I PFSTACK(0)=1 S X=PFSTACK(1)
|
||||
I TIME'="" S X=X_"@"_TIME
|
||||
S %DT="ST"
|
||||
D ^%DT
|
||||
Q Y
|
||||
;
|
||||
;==================================================
|
||||
VDATE(VIEN) ;Given a visit ien return the visit date.
|
||||
N DATE
|
||||
I +VIEN>0 S DATE=$P($G(^AUPNVSIT(VIEN,0)),U,1)
|
||||
E S DATE=0
|
||||
I $L(DATE)=0 S DATE=0
|
||||
;Check for historical encounter.
|
||||
I $$ISHIST^PXRMVSIT(VIEN) S DATE=DATE_"E"
|
||||
Q DATE
|
||||
;
|
||||
PXRMDATE ; SLC/PKR - Clinical Reminders date utilities. ;06/20/2006
|
||||
;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
|
||||
;
|
||||
;==================================================
|
||||
CEFD(FDA) ;Called by the Exchange Utility only if the input packed
|
||||
;reminder was packed under v1.5 Move Effective Date to Beginning Date.
|
||||
N IND
|
||||
S IND=""
|
||||
F S IND=$O(FDA(811.902,IND)) Q:IND="" D
|
||||
. I '$D(FDA(811.902,IND,12)) Q
|
||||
.;If the EFFECTIVE PERIOD exists don't do anything.
|
||||
. I $D(FDA(811.902,IND,9)) Q
|
||||
. S FDA(811.902,IND,9)=FDA(811.902,IND,12)
|
||||
. K FDA(811.902,IND,12)
|
||||
Q
|
||||
;
|
||||
;==================================================
|
||||
COMPARE(X) ;Compare beginning and ending dates, give a warning if
|
||||
;Ending Date comes before Beginning Date. Called by ADATE xref in
|
||||
;definitions and terms.
|
||||
;Do not execute as part of exchange.
|
||||
I $G(PXRMEXCH) Q
|
||||
N BDT,EDT
|
||||
S BDT=$S(X(1)'="":$$CTFMD^PXRMDATE(X(1)),1:0)
|
||||
S EDT=X(2)
|
||||
I EDT="" S EDT="T"
|
||||
S EDT=$$CTFMD^PXRMDATE(EDT)
|
||||
;If EDT does not contain a time set it to the end of the day.
|
||||
I EDT'["." S EDT=EDT_".235959"
|
||||
I EDT<BDT D
|
||||
. S BDT=$S(X(1)'="":X(1),1:"")
|
||||
. S EDT=$S(X(2)'="":X(2),1:"T@2400")
|
||||
. S TEXT="Warning the ending date ("_EDT_") is before the beginning date ("_BDT_")"
|
||||
. D EN^DDIOL(TEXT)
|
||||
Q
|
||||
;
|
||||
;==================================================
|
||||
COTN(EFP) ;Convert an Effective Period to the new date/time format.
|
||||
;Possible effective periods are ND, NM, or NY where N is an integer.
|
||||
S EFP=$$UP^XLFSTR(EFP)
|
||||
I (EFP?1N.N1"D")!(EFP?1N.N1"M")!(EFP?1N.N1"Y") D
|
||||
. S NUM=+EFP
|
||||
. S EFP=$S(NUM=0:"T",1:"T-"_EFP)
|
||||
Q EFP
|
||||
;
|
||||
;==================================================
|
||||
CTFMD(DATE) ;Convert DATE which may be in any of the FileMan acceptable
|
||||
;forms as well as T-NY to a FileMan date. Also understands LAD for
|
||||
;Last Admission Date.
|
||||
N %DT,X,Y
|
||||
;Check for a date FileMan understands.
|
||||
S X=DATE,%DT="ST"
|
||||
D ^%DT
|
||||
;If it is not a FileMan date check for a symbolic date.
|
||||
I Y=-1 S Y=$$SYMDATE(DATE)
|
||||
;If it is not a date that is understood by SYMDATE return -1
|
||||
I Y=-1 Q -1
|
||||
I $G(PXRMDATE)'="",$$ISVSYMD(DATE) D
|
||||
. N DIFFS
|
||||
. S DIFFS=-$$FMDIFF^XLFDT(DT,PXRMDATE,2)
|
||||
. S Y=$$FMADD^XLFDT(Y,0,0,0,DIFFS)
|
||||
I DATE["LAD" D
|
||||
. I $G(PXRMLAD)="" S Y=0
|
||||
. E D
|
||||
.. N DIFFS
|
||||
.. S DIFFS=-$$FMDIFF^XLFDT(DT,$G(PXRMLAD),2)
|
||||
.. S Y=$$FMADD^XLFDT(Y,0,0,0,DIFFS)
|
||||
Q Y
|
||||
;
|
||||
;=================================================
|
||||
DCHECK(DATE) ;Trap for special characters before calling CTFMD^PXRMDATE.
|
||||
;Used in DIR("PRE") for date inputs.
|
||||
I $D(DTOUT) Q DATE
|
||||
I DATE="" Q DATE
|
||||
I DATE["^" Q DATE
|
||||
I DATE["?" Q DATE
|
||||
Q $$CTFMD^PXRMDATE(DATE)
|
||||
;
|
||||
;==================================================
|
||||
DUE(DEFARR,RESDATE,FREQ,DUE,DUEDATE,FIEVAL) ;Compute the due date.
|
||||
;This is the date of the resolution finding + the reminder frequency.
|
||||
;Subtract the due in advance time to see if the reminder should be
|
||||
;marked as due soon.
|
||||
;
|
||||
N DATE,DIAT,DIATOK,LDATE,PXRMITEM,TDDUE,TODAY
|
||||
S PXRMITEM=DEFARR("IEN")
|
||||
;If the final frequency is 0Y then the reminder is not due.
|
||||
I FREQ="0Y" S DUE=0,DUEDATE="" Q
|
||||
;
|
||||
S DUEDATE=""
|
||||
;Check for custom date due.
|
||||
I DEFARR(45)'="" S DUEDATE=$$CDUEDATE^PXRMCDUE(.DEFARR,.FIEVAL)
|
||||
I DUEDATE'="",DUEDATE'=-1 G SETDUE
|
||||
;
|
||||
;No custom date due, do regular date calculation.
|
||||
I (FREQ="")!(FREQ=-1) D Q
|
||||
. S ^TMP(PXRMPID,$J,PXRMITEM,"WARNING","NOFREQ")="No reminder frequency - cannot compute due date!"
|
||||
. S (DUE,DUEDATE)="CNBD"
|
||||
;
|
||||
S LDATE=$S(RESDATE["X":0,1:+RESDATE)
|
||||
I LDATE=0 S (DUE,DUEDATE)="DUE NOW" Q
|
||||
S DATE=$$FULLDATE(LDATE),DUEDATE=$$NEWDATE(DATE,FREQ)
|
||||
;
|
||||
SETDUE ;If the due date is less than or equal to today's date the reminder
|
||||
;is due.
|
||||
S TODAY=$$NOW^PXRMDATE
|
||||
I +DUEDATE'>TODAY S DUE="DUE NOW" Q
|
||||
;
|
||||
S DIAT="-"_$P(DEFARR(0),U,4)
|
||||
I DIAT="-" D
|
||||
. S DIATOK=0
|
||||
. S ^TMP(PXRMPID,$J,PXRMITEM,"WARNING","DIAT")="Warning no do in advance time"
|
||||
E S DIATOK=1
|
||||
;
|
||||
S TDDUE=$S(DIATOK=1:$$NEWDATE(DUEDATE,DIAT),1:DUEDATE)
|
||||
S DUE=$S(TDDUE'>TODAY:"DUE SOON",1:"RESOLVED")
|
||||
Q
|
||||
;
|
||||
;==================================================
|
||||
DURATION(START,STOP) ;Return the number days between the Start Date and
|
||||
;Stop Date.
|
||||
I +START=0 Q 0
|
||||
N PXRMNOW
|
||||
S PXRMNOW=$$NOW^PXRMDATE
|
||||
I START>PXRMNOW Q 0
|
||||
I (STOP="")!(STOP>PXRMNOW) S STOP=PXRMNOW
|
||||
Q $$FMDIFF^XLFDT(STOP,START)
|
||||
;
|
||||
;==================================================
|
||||
EDATE(DATE) ;Check for an historical (event) date, format as appropriate.
|
||||
Q $$FMTE^XLFDT(DATE,"5DZ")
|
||||
;
|
||||
;==================================================
|
||||
FULLDATE(DATE) ;See if DATE is a full date, i.e., it has a month and
|
||||
;a day along with a year. If the month is missing assume Jan. If the
|
||||
;day is missing assume the first. Issue a warning so the user knows
|
||||
;what happened. DATE should be in Fileman format.
|
||||
N DAY,MISSING,MONTH,TDATE,YEAR
|
||||
S TDATE=DATE
|
||||
S MISSING=0
|
||||
S DAY=$E(DATE,6,7)
|
||||
S MONTH=$E(DATE,4,5)
|
||||
S YEAR=$E(DATE,1,3)
|
||||
I +DAY=0 D
|
||||
. S DAY=1
|
||||
. S MISSING=1
|
||||
. S ^TMP(PXRMPID,$J,PXRMITEM,"INFO","NO DAY")="Encounter date missing the day, using the first for the date due calculation."
|
||||
I +MONTH=0 D
|
||||
. S MONTH=1
|
||||
. S MISSING=1
|
||||
. S ^TMP(PXRMPID,$J,PXRMITEM,"INFO","NO MONTH")="Encounter date missing the month, using January for the date due calculation."
|
||||
I MISSING D
|
||||
. S TDATE=(YEAR*1E4)+(MONTH*1E2)+DAY
|
||||
. I DATE["E" S TDATE=TDATE_"E"
|
||||
Q TDATE
|
||||
;
|
||||
;==================================================
|
||||
FRQINDAY(FREQ) ;Given a frequency in the form ND, NM, or NY where N is a
|
||||
;number and D stands for days, M for months, and Y for years return
|
||||
;the value in days.
|
||||
I FREQ="" Q ""
|
||||
N CODE,LEN,MULT,NUM
|
||||
S LEN=$L(FREQ)
|
||||
S NUM=$E(FREQ,1,LEN-1)
|
||||
S CODE=$E(FREQ,LEN,LEN)
|
||||
S MULT=1.0
|
||||
I CODE="M" S MULT=30.42
|
||||
I CODE="Y" S MULT=365.25
|
||||
Q +(MULT*NUM)
|
||||
;
|
||||
;==================================================
|
||||
ISVSYMD(DATE) ;Return true if DATE is a valid symbolic date.
|
||||
N P1,P1OK,P2,P2OK,OP,PAT
|
||||
S DATE=$P(DATE,"@",1)
|
||||
S OP=$S(DATE["+":"+",1:"-")
|
||||
S P1=$P(DATE,OP,1),P1OK=0
|
||||
F PAT="T","TODAY","N","NOW" I P1=PAT S P1OK=1 Q:P1OK
|
||||
I PAT=DATE Q 1
|
||||
S P2=$P(DATE,OP,2),P2OK=0
|
||||
F PAT="1N.N","1N.N1""D""","1N.N1""M""","1N.N1""Y""" I P2?@PAT S P2OK=1 Q:P2OK
|
||||
Q P1OK&P2OK
|
||||
;
|
||||
;==================================================
|
||||
NEWDATE(FMDATE,OFFSET) ;Given a date in VA Fileman format (FMDATE) and an
|
||||
;offset of the form NY, NM, ND where N is a number and Y stands for
|
||||
;years, M for months, and D for days return the new date in VA Fileman
|
||||
;format.
|
||||
I FMDATE=0 Q 0
|
||||
N LEN,NEWDATE,NUM,UNIT
|
||||
S LEN=$L(OFFSET)
|
||||
S NUM=+$E(OFFSET,1,LEN-1)
|
||||
S UNIT=$E(OFFSET,LEN)
|
||||
I UNIT="D" G DAY
|
||||
I UNIT="M" G MONTH
|
||||
I UNIT="Y" G YEAR
|
||||
;Unknown unit just return the original date
|
||||
Q FMDATE
|
||||
DAY ;
|
||||
S NEWDATE=+$$FMADD^XLFDT(FMDATE,NUM)
|
||||
Q NEWDATE
|
||||
MONTH ;
|
||||
;Convert the months to days and then add the days using the DAY code.
|
||||
;Multiply the number of months by the average number of days in a month.
|
||||
N INT,FRAC
|
||||
S NUM=30.42*NUM
|
||||
;Round the number of days, FMADD^XLFDT has problems with non-integer
|
||||
;days.
|
||||
S INT=+$P(NUM,".",1)
|
||||
S FRAC=NUM-INT
|
||||
I FRAC<0.5 S NUM=INT
|
||||
E S NUM=INT+1
|
||||
G DAY
|
||||
Q
|
||||
YEAR ;
|
||||
Q FMDATE+(10000*NUM)
|
||||
;
|
||||
;==================================================
|
||||
NOW() ;If the reminder global PXRMDATE is defined return it, otherwise
|
||||
;return the current date and time.
|
||||
Q $S(+$G(PXRMDATE)>0:PXRMDATE,1:$$NOW^XLFDT)
|
||||
;
|
||||
;==================================================
|
||||
SYMDATE(DATE) ;Convert a symbolic date into a FileMan date.
|
||||
N %DT,OPER,PFSTACK,SYM,TIME,X,Y
|
||||
S TIME=$P(DATE,"@",2),DATE=$P(DATE,"@",1)
|
||||
S X=$S(DATE="LAD":$G(PXRMLAD),1:"")
|
||||
I X="" D
|
||||
. S OPER="+-"
|
||||
. D POSTFIX^PXRMSTAC(DATE,OPER,.PFSTACK)
|
||||
I PFSTACK(0)=3 D
|
||||
. S SYM=PFSTACK(1)
|
||||
. S SYM=$S(SYM="LAD":"T",SYM="N":"N",SYM="NOW":"N",SYM="T":"T",SYM="TODAY":"T",1:"")
|
||||
. I SYM="" S Y=-1 Q
|
||||
.;FileMan only handles D, W, or M so convert Y to months.
|
||||
. I PFSTACK(2)["Y" S PFSTACK(2)=+PFSTACK(2)*12_"M"
|
||||
. S X=SYM_PFSTACK(3)_PFSTACK(2)
|
||||
I PFSTACK(0)=1 S X=PFSTACK(1)
|
||||
I TIME'="" S X=X_"@"_TIME
|
||||
S %DT="ST"
|
||||
D ^%DT
|
||||
Q Y
|
||||
;
|
||||
;==================================================
|
||||
VDATE(VIEN) ;Given a visit ien return the visit date.
|
||||
N DATE
|
||||
I +VIEN>0 S DATE=$P($G(^AUPNVSIT(VIEN,0)),U,1)
|
||||
E S DATE=0
|
||||
I $L(DATE)=0 S DATE=0
|
||||
;Check for historical encounter.
|
||||
I $$ISHIST^PXRMVSIT(VIEN) S DATE=DATE_"E"
|
||||
Q DATE
|
||||
;
|
||||
|
|
|
|||
|
|
@ -1,158 +1,158 @@
|
|||
PXRMDBL3 ; SLC/PJH - Reminder Dialog Generation. (overflow) ;11/08/2007
|
||||
;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
|
||||
;
|
||||
; Called from PXRMDBL1
|
||||
;
|
||||
;Set number range for site
|
||||
START ;
|
||||
D SETSTART^PXRMCOPY("^PXRMD(801.41,")
|
||||
;Update dialog file for individual dialog items
|
||||
D UPDATE(.ARRAY,.WPTXT,"E")
|
||||
;Create reminder dialog
|
||||
D UPDATE(.DSET,"","R")
|
||||
;
|
||||
W !!,"Dialog build complete" H 3
|
||||
END Q
|
||||
;
|
||||
;Error Handler
|
||||
;-------------
|
||||
ERR(DESC) ;
|
||||
N ERROR,IC,REF
|
||||
S ERROR(1)="Unable to update dialog file : "_DESC
|
||||
S ERROR(2)="Error in UPDATE^DIE, needs further investigation"
|
||||
;Move MSG into ERROR
|
||||
S REF="MSG"
|
||||
F IC=3:1 S REF=$Q(@REF) Q:REF="" S ERROR(IC)=REF_"="_@REF
|
||||
;Screen message
|
||||
D BMES^XPDUTL(.ERROR)
|
||||
Q
|
||||
;
|
||||
;Check if dialog element already exists
|
||||
;--------------------------------------
|
||||
EXISTS(NAME) ;
|
||||
N IEN S IEN=$O(^PXRMD(801.41,"B",NAME,""))
|
||||
I IEN S DSET(1,CNT*5)=IEN Q 1
|
||||
Q 0
|
||||
;
|
||||
;Update edit history
|
||||
;-------------------
|
||||
HIS(IENN) ;
|
||||
;First delete any existing history entries.
|
||||
N ENTRY,IND,IENS,FDA,FDAIEN,MSG,WP
|
||||
S ENTRY="^PXRMD(801.41,"_IENN_",110)"
|
||||
S IND=0
|
||||
F S IND=$O(@ENTRY@(IND)) Q:+IND=0 D
|
||||
. S IENS=IND_","_IENN_","
|
||||
. S FDA(801.44,IENS,.01)="@"
|
||||
I $D(FDA(801.44)) D
|
||||
.D FILE^DIE("K","FDA","MSG") I $D(MSG) D AWRITE^PXRMUTIL("MSG")
|
||||
;Establish an initial entry in the edit history.
|
||||
K FDA,MSG
|
||||
S IENS="+1,"_IENN_","
|
||||
S FDAIEN(IENN)=IENN
|
||||
S FDA(801.44,IENS,.01)=$$FMTE^XLFDT($$NOW^XLFDT,"5Z")
|
||||
S FDA(801.44,IENS,1)=$$GET1^DIQ(200,DUZ,.01)
|
||||
S FDA(801.44,IENS,2)="WP(1,1)"
|
||||
S WP(1,1,1)="Autogenerated"
|
||||
D UPDATE^DIE("E","FDA","FDAIEN","MSG")
|
||||
I $D(MSG) D AWRITE^PXRMUTIL("MSG")
|
||||
Q
|
||||
;
|
||||
;Mental Health
|
||||
;-------------
|
||||
MHOK(IEN) ;
|
||||
N RNAME,TEST,YT S YT=""
|
||||
;Convert ien to name
|
||||
;DBIA #5044
|
||||
S YT("CODE")=$P($G(^YTT(601.71,IEN,0)),U)
|
||||
;Quit if no code found
|
||||
I YT("CODE")="" Q 0
|
||||
I '$$OK^PXRMDLL(IEN) Q 0
|
||||
;Check if valid
|
||||
;I TEST(1)["[ERROR]" Q 0
|
||||
;
|
||||
S DNAME=FTYP_" "_YT("CODE")
|
||||
;Create arrays
|
||||
S CNT=CNT+1
|
||||
;Convert dialog item name to UC
|
||||
S DNAME=$TR(DNAME,LOWER,UPPER)
|
||||
;Truncate the item name - without finesse
|
||||
S DSHORT=DNAME
|
||||
I $L(DSHORT)>40 S DSHORT=$E(DNAME,1,40)
|
||||
;Dialog item name, finding item and result
|
||||
S ARRAY(CNT)=DSHORT_U_U_RESN_U
|
||||
;Commented out Result Group Patch 6 until a decision can be made
|
||||
;Result group name
|
||||
;S RNAME="PXRM "_YT("CODE")_" RESULT GROUP"
|
||||
;Result pointer
|
||||
;S $P(ARRAY(CNT),U,7)=$O(^PXRMD(801.41,"B",RNAME,""))
|
||||
;If aims exclude from p/n
|
||||
I YT("CODE")="AIMS" S $P(ARRAY(CNT),U,6)=1
|
||||
;Prompt text
|
||||
S WPTXT(CNT,1)=YT("CODE")_" (Mental Health Instrument)"
|
||||
;test
|
||||
W !!,CNT,?5,WPTXT(CNT,1)
|
||||
Q 1
|
||||
;
|
||||
;Sub-routine to update dialog file #801.41
|
||||
;-----------------------------------------
|
||||
UPDATE(INP,WPTXT,DTYPE) ;
|
||||
N CNT,DATA,DESC,IEN,STRING,SUB,TEXT
|
||||
N FDA,FDAIEN,MSG
|
||||
;Get each dialog line in turn
|
||||
S STRING="Updating "_$S(DTYPE="E":"Dialog Elements",1:"Reminder Dialog")
|
||||
D BMES^XPDUTL(STRING)
|
||||
;
|
||||
;Create FDA for each entry in array
|
||||
S CNT=""
|
||||
F S CNT=$O(INP(CNT)) Q:CNT="" D Q:$D(MSG)
|
||||
.;If finding is a finding item parameter no need to build an element
|
||||
.I DTYPE="E",$P(INP(CNT),U)=801.43 D Q
|
||||
..S DSET(1,CNT)=$P(INP(CNT),U,2)
|
||||
.;Build FDA array
|
||||
.K FDAIEN,FDA
|
||||
.;If existing element and not in replace mode don't update FDA
|
||||
.I DTYPE="E",'PXRMREPL Q:$$EXISTS($P(INP(CNT),U))
|
||||
.;Name
|
||||
.S FDA(801.41,"?+1,",.01)=$P(INP(CNT),U)
|
||||
.;Dialog type
|
||||
.S FDA(801.41,"?+1,",4)=DTYPE
|
||||
.;Class
|
||||
.S FDA(801.41,"?+1,",100)="L"
|
||||
.;Sponsor
|
||||
.S FDA(801.41,"?+1,",101)=""
|
||||
.;Prompt text/finding entries
|
||||
.I DTYPE="E" D
|
||||
..S FDA(801.41,"?+1,",13)=$P(INP(CNT),U,2)
|
||||
..S FDA(801.41,"?+1,",15)=$P(INP(CNT),U,3)
|
||||
..S FDA(801.41,"?+1,",17)=$P(INP(CNT),U,4)
|
||||
..S FDA(801.41,"?+1,",25)="WPTXT("_CNT_")"
|
||||
..;MH fields (exclude from P/N and results pointer)
|
||||
..S:$P(INP(CNT),U,6) FDA(801.41,"?+1,",54)=$P(INP(CNT),U,6)
|
||||
..;S:$P(INP(CNT),U,7) FDA(801.41,"?+1,",55)=$P(INP(CNT),U,7)
|
||||
.;Reminder dialog associated reminder/DISABLE
|
||||
.I DTYPE="R" D
|
||||
..S FDA(801.41,"?+1,",2)=REM
|
||||
..I PXRMENAB'="Y" S FDA(801.41,"?+1,",3)="DISABLED AT AUTO GENERATE"
|
||||
.;Dialog items point to prompts and actions, Sets point to dialog items
|
||||
.N ACNT,SUB
|
||||
.;S ACNT=0,SUB=2
|
||||
.S ACNT=0,SUB=1
|
||||
.F S ACNT=$O(INP(CNT,ACNT)) Q:ACNT="" D
|
||||
..S SUB=SUB+1,FDA(801.412,"?+"_SUB_",?+1,",.01)=ACNT
|
||||
..S FDA(801.412,"?+"_SUB_",?+1,",2)=$P(INP(CNT,ACNT),U)
|
||||
..S FDA(801.412,"?+"_SUB_",?+1,",6)=$P(INP(CNT,ACNT),U,2)
|
||||
..S FDA(801.412,"?+"_SUB_",?+1,",7)=$P(INP(CNT,ACNT),U,3)
|
||||
..S FDA(801.412,"?+"_SUB_",?+1,",8)=$P(INP(CNT,ACNT),U,4)
|
||||
..S FDA(801.412,"?+"_SUB_",?+1,",9)=$P(INP(CNT,ACNT),U,5)
|
||||
.;Update #801.41
|
||||
.D UPDATE^DIE("","FDA","FDAIEN","MSG")
|
||||
.I $D(MSG) D ERR($G(INP(CNT))) Q
|
||||
.;Save IEN of dialog created/used for later use in building dialog set
|
||||
.I DTYPE="E" S DSET(1,CNT*5)=FDAIEN(1)
|
||||
.;Insert link to reminder
|
||||
.I DTYPE="R",PXRMLINK="Y" D
|
||||
..S $P(^PXD(811.9,REM,51),U)=FDAIEN(1),^PXD(811.9,"AG",FDAIEN(1),REM)=""
|
||||
.;Update Edit History
|
||||
.D HIS(FDAIEN(1))
|
||||
Q
|
||||
PXRMDBL3 ; SLC/PJH - Reminder Dialog Generation. (overflow) ;04/30/2001
|
||||
;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
|
||||
;
|
||||
; Called from PXRMDBL1
|
||||
;
|
||||
;Set number range for site
|
||||
START D SETSTART^PXRMCOPY("^PXRMD(801.41,")
|
||||
;Update dialog file for individual dialog items
|
||||
D UPDATE(.ARRAY,.WPTXT,"E")
|
||||
;Create reminder dialog
|
||||
D UPDATE(.DSET,"","R")
|
||||
;
|
||||
W !!,"Dialog build complete" H 3
|
||||
END Q
|
||||
;
|
||||
;Error Handler
|
||||
;-------------
|
||||
ERR(DESC) ;
|
||||
N ERROR,IC,REF
|
||||
S ERROR(1)="Unable to update dialog file : "_DESC
|
||||
S ERROR(2)="Error in UPDATE^DIE, needs further investigation"
|
||||
;Move MSG into ERROR
|
||||
S REF="MSG"
|
||||
F IC=3:1 S REF=$Q(@REF) Q:REF="" S ERROR(IC)=REF_"="_@REF
|
||||
;Screen message
|
||||
D BMES^XPDUTL(.ERROR)
|
||||
Q
|
||||
;
|
||||
;Check if dialog element already exists
|
||||
;--------------------------------------
|
||||
EXISTS(NAME) ;
|
||||
N IEN S IEN=$O(^PXRMD(801.41,"B",NAME,""))
|
||||
I IEN S DSET(1,CNT*5)=IEN Q 1
|
||||
Q 0
|
||||
;
|
||||
;Update edit history
|
||||
;-------------------
|
||||
HIS(IENN) ;
|
||||
;First delete any existing history entries.
|
||||
N ENTRY,IND,IENS,FDA,FDAIEN,MSG,WP
|
||||
S ENTRY="^PXRMD(801.41,"_IENN_",110)"
|
||||
S IND=0
|
||||
F S IND=$O(@ENTRY@(IND)) Q:+IND=0 D
|
||||
. S IENS=IND_","_IENN_","
|
||||
. S FDA(801.44,IENS,.01)="@"
|
||||
I $D(FDA(801.44)) D
|
||||
.D FILE^DIE("K","FDA","MSG") I $D(MSG) D AWRITE^PXRMUTIL("MSG")
|
||||
;Establish an initial entry in the edit history.
|
||||
K FDA,MSG
|
||||
S IENS="+1,"_IENN_","
|
||||
S FDAIEN(IENN)=IENN
|
||||
S FDA(801.44,IENS,.01)=$$FMTE^XLFDT($$NOW^XLFDT,"5Z")
|
||||
S FDA(801.44,IENS,1)=$$GET1^DIQ(200,DUZ,.01)
|
||||
S FDA(801.44,IENS,2)="WP(1,1)"
|
||||
S WP(1,1,1)="Autogenerated"
|
||||
D UPDATE^DIE("E","FDA","FDAIEN","MSG")
|
||||
I $D(MSG) D AWRITE^PXRMUTIL("MSG")
|
||||
Q
|
||||
;
|
||||
;Mental Health
|
||||
;-------------
|
||||
MHOK(IEN) ;
|
||||
N RNAME,TEST,YT S YT=""
|
||||
;Convert ien to name
|
||||
S YT("CODE")=$P($G(^YTT(601,IEN,0)),U)
|
||||
;Quit if no code found
|
||||
I YT("CODE")="" Q 0
|
||||
;Check if this is an allowable GUI test
|
||||
I (YT("CODE")'="GAF"),($P($G(^YTT(601.6,IEN,0)),U,4)'="Y") Q 0
|
||||
;Get details of test
|
||||
D SHOWALL^YTAPI3(.TEST,.YT)
|
||||
;Check if valid
|
||||
I TEST(1)["[ERROR]" Q 0
|
||||
;
|
||||
S DNAME=FTYP_" "_YT("CODE")
|
||||
;Create arrays
|
||||
S CNT=CNT+1
|
||||
;Convert dialog item name to UC
|
||||
S DNAME=$TR(DNAME,LOWER,UPPER)
|
||||
;Truncate the item name - without finesse
|
||||
S DSHORT=DNAME
|
||||
I $L(DSHORT)>40 S DSHORT=$E(DNAME,1,40)
|
||||
;Dialog item name, finding item and result
|
||||
S ARRAY(CNT)=DSHORT_U_U_RESN_U
|
||||
;Result group name
|
||||
S RNAME="PXRM "_YT("CODE")_" RESULT GROUP"
|
||||
;Result pointer
|
||||
S $P(ARRAY(CNT),U,7)=$O(^PXRMD(801.41,"B",RNAME,""))
|
||||
;If aims exclude from p/n
|
||||
I YT("CODE")="AIMS" S $P(ARRAY(CNT),U,6)=1
|
||||
;Prompt text
|
||||
S WPTXT(CNT,1)=YT("CODE")_" (Mental Health Instrument)"
|
||||
;test
|
||||
W !!,CNT,?5,WPTXT(CNT,1)
|
||||
Q 1
|
||||
;
|
||||
;Sub-routine to update dialog file #801.41
|
||||
;-----------------------------------------
|
||||
UPDATE(INP,WPTXT,DTYPE) ;
|
||||
N CNT,DATA,DESC,IEN,STRING,SUB,TEXT
|
||||
N FDA,FDAIEN,MSG
|
||||
;Get each dialog line in turn
|
||||
S STRING="Updating "_$S(DTYPE="E":"Dialog Elements",1:"Reminder Dialog")
|
||||
D BMES^XPDUTL(STRING)
|
||||
;
|
||||
;Create FDA for each entry in array
|
||||
S CNT=""
|
||||
F S CNT=$O(INP(CNT)) Q:CNT="" D Q:$D(MSG)
|
||||
.;If finding is a finding item parameter no need to build an element
|
||||
.I DTYPE="E",$P(INP(CNT),U)=801.43 D Q
|
||||
..S DSET(1,CNT)=$P(INP(CNT),U,2)
|
||||
.;Build FDA array
|
||||
.K FDAIEN,FDA
|
||||
.;If existing element and not in replace mode don't update FDA
|
||||
.I DTYPE="E",'PXRMREPL Q:$$EXISTS($P(INP(CNT),U))
|
||||
.;Name
|
||||
.S FDA(801.41,"?+1,",.01)=$P(INP(CNT),U)
|
||||
.;Dialog type
|
||||
.S FDA(801.41,"?+1,",4)=DTYPE
|
||||
.;Class
|
||||
.S FDA(801.41,"?+1,",100)="L"
|
||||
.;Sponsor
|
||||
.S FDA(801.41,"?+1,",101)=""
|
||||
.;Prompt text/finding entries
|
||||
.I DTYPE="E" D
|
||||
..S FDA(801.41,"?+1,",13)=$P(INP(CNT),U,2)
|
||||
..S FDA(801.41,"?+1,",15)=$P(INP(CNT),U,3)
|
||||
..S FDA(801.41,"?+1,",17)=$P(INP(CNT),U,4)
|
||||
..S FDA(801.41,"?+1,",25)="WPTXT("_CNT_")"
|
||||
..;MH fields (exclude from P/N and results pointer)
|
||||
..S:$P(INP(CNT),U,6) FDA(801.41,"?+1,",54)=$P(INP(CNT),U,6)
|
||||
..S:$P(INP(CNT),U,7) FDA(801.41,"?+1,",55)=$P(INP(CNT),U,7)
|
||||
.;Reminder dialog associated reminder/DISABLE
|
||||
.I DTYPE="R" D
|
||||
..S FDA(801.41,"?+1,",2)=REM
|
||||
..I PXRMENAB'="Y" S FDA(801.41,"?+1,",3)="DISABLED AT AUTO GENERATE"
|
||||
.;Dialog items point to prompts and actions, Sets point to dialog items
|
||||
.N ACNT,SUB
|
||||
.;S ACNT=0,SUB=2
|
||||
.S ACNT=0,SUB=1
|
||||
.F S ACNT=$O(INP(CNT,ACNT)) Q:ACNT="" D
|
||||
..S SUB=SUB+1,FDA(801.412,"?+"_SUB_",?+1,",.01)=ACNT
|
||||
..S FDA(801.412,"?+"_SUB_",?+1,",2)=$P(INP(CNT,ACNT),U)
|
||||
..S FDA(801.412,"?+"_SUB_",?+1,",6)=$P(INP(CNT,ACNT),U,2)
|
||||
..S FDA(801.412,"?+"_SUB_",?+1,",7)=$P(INP(CNT,ACNT),U,3)
|
||||
..S FDA(801.412,"?+"_SUB_",?+1,",8)=$P(INP(CNT,ACNT),U,4)
|
||||
..S FDA(801.412,"?+"_SUB_",?+1,",9)=$P(INP(CNT,ACNT),U,5)
|
||||
.;Update #801.41
|
||||
.D UPDATE^DIE("","FDA","FDAIEN","MSG")
|
||||
.I $D(MSG) D ERR($G(INP(CNT))) Q
|
||||
.;Save IEN of dialog created/used for later use in building dialog set
|
||||
.I DTYPE="E" S DSET(1,CNT*5)=FDAIEN(1)
|
||||
.;Insert link to reminder
|
||||
.I DTYPE="R",PXRMLINK="Y" D
|
||||
..S $P(^PXD(811.9,REM,51),U)=FDAIEN(1),^PXD(811.9,"AG",FDAIEN(1),REM)=""
|
||||
.;Update Edit History
|
||||
.D HIS(FDAIEN(1))
|
||||
Q
|
||||
|
|
|
|||
|
|
@ -1,304 +1,301 @@
|
|||
PXRMDEDT ; SLC/PJH - Edit PXRM reminder dialog. ;10/18/2007
|
||||
;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
|
||||
;
|
||||
;Used by protocol PXRM SELECTION ADD/PXRM GENERAL ADD
|
||||
;
|
||||
;Add Dialog
|
||||
;----------
|
||||
ADD N DA,DIC,Y,DTOUT,DUOUT,DTYP,DLAYGO,HED
|
||||
S HED="ADD DIALOG"
|
||||
W IORESET
|
||||
F D Q:$D(DTOUT)
|
||||
.S DIC="^PXRMD(801.41,"
|
||||
.;Set the starting place for additions.
|
||||
.D SETSTART^PXRMCOPY(DIC)
|
||||
.S DIC(0)="AELMQ",DLAYGO=801.41
|
||||
.S DIC("A")="Select DIALOG to add: "
|
||||
.S DIC("DR")="4///"_$G(PXRMDTYP)
|
||||
.D ^DIC
|
||||
.I $D(DUOUT) S DTOUT=1
|
||||
.I ($D(DTOUT))!($D(DUOUT)) Q
|
||||
.I Y=-1 K DIC S DTOUT=1 Q
|
||||
.I $P(Y,U,3)'=1 W !,"This dialog name already exists" Q
|
||||
.S DA=$P(Y,U,1)
|
||||
.;Determine dialog type
|
||||
.S DTYP=$P($G(^PXRMD(801.41,DA,0)),U,4)
|
||||
.;Enter dialog type if a new entry
|
||||
.I DTYP="" D Q:$D(Y)
|
||||
..N DIE,DR
|
||||
..S DIE=801.41,DR=4
|
||||
..D ^DIE
|
||||
.;
|
||||
.;Edit Dialog
|
||||
.D EDIT(DTYP,DA,0)
|
||||
Q
|
||||
;
|
||||
;called by protocol PXRM DIALOG EDIT
|
||||
;-----------------------------------
|
||||
EDIT(TYP,DA,OIEN) ;
|
||||
Q:'$$LOCK(DA)
|
||||
W IORESET
|
||||
N CS1,CS2,D1,DIC,DIDEL,DIE,DR,DTOUT,DUOUT,DINUSE,TYP,ODA,Y
|
||||
;Save checksum
|
||||
S VALMBCK=""
|
||||
S CS1=$$FILE^PXRMEXCS(801.41,DA)
|
||||
;
|
||||
;Check dialog type
|
||||
S TYP=$P($G(^PXRMD(801.41,DA,0)),U,4)
|
||||
S DIE="^PXRMD(801.41,",DIDEL=801.41,DINUSE=0,ODA=DA
|
||||
;Reminder Dialog
|
||||
I TYP="R" S DR="[PXRM EDIT REMINDER DIALOG]"
|
||||
;Dialog Element
|
||||
I TYP="E" S DR="[PXRM EDIT ELEMENT]"
|
||||
;Additional Prompt
|
||||
;I TYP="P" S DR="[PXRM EDIT PROMPT]"
|
||||
;Forced Value
|
||||
I TYP="F" S DR="[PXRM EDIT FORCED VALUE]"
|
||||
;Dialog Group (Finding item dialog)
|
||||
I TYP="G" S DR="[PXRM EDIT GROUP]" ;S VALMBCK="R"
|
||||
;Result Group
|
||||
I TYP="S" S DR="[PXRM RESULT GROUP]"
|
||||
;Result Element
|
||||
I TYP="T" S DR="[PXRM RESULT ELEMENT]"
|
||||
;Allows limited edit of national dialogs
|
||||
I $P($G(^PXRMD(801.41,DA,100)),U)="N" D
|
||||
.I TYP="T",+$P($G(^PXMRD(801.41,DA,100)),U,4)=0 Q
|
||||
.I $G(PXRMINST)=1,DUZ(0)="@" Q
|
||||
.S DR="[PXRM EDIT NATIONAL DIALOG]",DINUSE=1
|
||||
;
|
||||
I "GEPF"[TYP D
|
||||
.I '$D(^PXRMD(801.41,"AD",DA)) W !,"Not used by any other dialog",! Q
|
||||
.I PXRMGTYP'="DLG" S DINUSE=1 Q
|
||||
.I PXRMGTYP="DLG" D Q
|
||||
..N SUB
|
||||
..S SUB=0
|
||||
..F S SUB=$O(^PXRMD(801.41,"AD",DA,SUB)) Q:'SUB Q:DINUSE D
|
||||
...I SUB'=PXRMDIEN S DINUSE=1
|
||||
I DINUSE D
|
||||
.W !,"Current dialog element/group name: "_$P($G(^PXRMD(801.41,DA,0)),U)
|
||||
.I TYP="S" Q
|
||||
.I PXRMGTYP="DLGE" D
|
||||
..W !,"Used by:" D USE^PXRMDLST(DA,10,"")
|
||||
..I $D(^PXRMD(801.41,"R",DA))'>0 Q
|
||||
..W !,"Used as a Replacement Element/Group for: " D REPLACE^PXRMDLST(DA,10,"")
|
||||
.I PXRMGTYP'="DLGE" D
|
||||
..W !,"Used by:" D USE^PXRMDLST(DA,10,PXRMDIEN)
|
||||
..I $D(^PXRMD(801.41,"R",DA))'>0 Q
|
||||
..W !,"Used as a Replacement Element/Group for: " D REPLACE^PXRMDLST(DA,10,PXRMDIEN)
|
||||
;
|
||||
;Save list of components
|
||||
N COMP D COMP^PXRMDEDX(DA,.COMP)
|
||||
;Edit dialog then unlock
|
||||
I TYP'="P" D ^DIE D UNLOCK(ODA) I $G(DA)="",$G(OIEN)>0 D
|
||||
.S DA=OIEN,DR="118////@" D ^DIE K DA
|
||||
I TYP="P" D PROMPT(DA) D UNLOCK(ODA)
|
||||
I '$D(DUOUT)&($G(D1)'="") D Q
|
||||
. I $P($G(^PXRMD(801.41,DA,10,D1,0)),U,2)="" D Q
|
||||
. . S DA(1)=DA,DA=D1 Q:'DA
|
||||
. . S DIK="^PXRMD(801.41,"_DA(1)_",10,"
|
||||
. . D ^DIK
|
||||
. . S VALMBG=1
|
||||
I '$D(DA) D Q
|
||||
.;Clear any pointers from #811.9
|
||||
.I $D(PXRMDIEN) D PURGE(PXRMDIEN)
|
||||
.;Option to delete components
|
||||
.I $D(COMP) D DELETE^PXRMDEDX(.COMP)
|
||||
.S VALMBCK="R"
|
||||
;
|
||||
;Update edit history
|
||||
I (TYP'="R") D
|
||||
.S CS2=$$FILE^PXRMEXCS(801.41,DA) Q:CS2=CS1 Q:+CS2=0
|
||||
.S DIC="^PXRMD(801.41,"
|
||||
.D SEHIST^PXRMUTIL(801.41,DIC,DA)
|
||||
;
|
||||
;Redisplay changes (reminder dialog option only)
|
||||
I PXRMGTYP="DLG",TYP="R" D
|
||||
.;Get name of reminder dialog again
|
||||
.S Y=$P($G(^PXRMD(801.41,DA,0)),U)
|
||||
.;Format headings to include dialog name
|
||||
.S PXRMHD="REMINDER DIALOG NAME: "_$P(Y,U)
|
||||
.;Check if the set is disable and add to header if disabled
|
||||
.I $P(^PXRMD(801.41,DA,0),U,3)]"" S PXRMHD=PXRMHD_" (DISABLED)"
|
||||
.;Reset header in case name has changed
|
||||
.S VALMHDR(1)=PXRMHD
|
||||
Q
|
||||
;
|
||||
;Add SINGLE dialog element (protocol PXRM DIALOG SELECTION ITEM)
|
||||
;-------------------------
|
||||
ESEL(PXRMDIEN,SEL) ;
|
||||
N DA,DIC,DLAYGO,DNEW,DTOUT,DUOUT,DTYP,Y
|
||||
;
|
||||
S DIC="^PXRMD(801.41,"
|
||||
S DLAYGO="801.41"
|
||||
;Set the starting place for additions.
|
||||
D SETSTART^PXRMCOPY(DIC)
|
||||
S DIC(0)="AEMQL"
|
||||
S DIC("A")="Select new DIALOG ELEMENT: "
|
||||
S DIC("S")="I ""EG""[$P(^PXRMD(801.41,Y,0),U,4)"
|
||||
S DIC("DR")="4///E"
|
||||
W !
|
||||
D ^DIC
|
||||
I $D(DUOUT) S DTOUT=1
|
||||
I ($D(DTOUT))!($D(DUOUT)) Q
|
||||
I Y=-1 K DIC S DTOUT=1 Q
|
||||
S DA=$P(Y,U,1) Q:'DA
|
||||
S DNEW=$P(Y,U,3)
|
||||
;Group points to itself
|
||||
I 'DNEW,$$VGROUP(DA,PXRMDIEN) Q
|
||||
;Add to dialog
|
||||
D EADD(SEL,DA,PXRMDIEN)
|
||||
;Determine dialog type
|
||||
S DTYP=$P($G(^PXRMD(801.41,DA,0)),U,4)
|
||||
;
|
||||
;Edit Dialog
|
||||
I DNEW D EDIT(DTYP,DA)
|
||||
Q
|
||||
;
|
||||
;Update dialog component multiple
|
||||
;--------------------------------
|
||||
EADD(SEL,NSUB,PXRMDIEN) ;
|
||||
N DA,DATA,NEXT
|
||||
S DATA=$G(^PXRMD(801.41,PXRMDIEN,10,0)),NEXT=$P(DATA,U,3)+1
|
||||
I DATA="" S DATA="^801.412IA"
|
||||
S DA=NSUB,DA(1)=PXRMDIEN
|
||||
S ^PXRMD(801.41,PXRMDIEN,10,NEXT,0)=SEL_U_DA_"^^^^^^^"
|
||||
;Update next slot
|
||||
S $P(DATA,U,4)=$P(DATA,U,4)+1,$P(DATA,U,3)=NEXT
|
||||
S ^PXRMD(801.41,PXRMDIEN,10,0)=DATA
|
||||
;Re-index
|
||||
N DIK,DA S DIK="^PXRMD(801.41,",DA=PXRMDIEN
|
||||
D IX^DIK
|
||||
Q
|
||||
;
|
||||
;Change Dialog Element Type
|
||||
;--------------------------
|
||||
NTYP(TYP) ;
|
||||
N X,Y,DIR K DIROUT,DIRUT,DTOUT,DUOUT
|
||||
S DIR(0)="SA"_U_"E:Element;"
|
||||
S DIR(0)=DIR(0)_"G:Group;"
|
||||
S DIR("A")="Dialog Element Type: "
|
||||
S DIR("B")="E"
|
||||
S DIR("?")="Select from the codes displayed. For detailed help type ??"
|
||||
S DIR("??")=U_"D HELP^PXRMDEDT(3)"
|
||||
D ^DIR K DIR
|
||||
I $D(DIROUT) S DTOUT=1
|
||||
I $D(DTOUT)!($D(DUOUT)) Q
|
||||
S TYP=Y
|
||||
Q
|
||||
;
|
||||
;Clear pointers from the reminder file and process ID file
|
||||
;---------------------------------------------------------
|
||||
PURGE(DIEN) ;
|
||||
;Purge pointers to this dialog from reminder file
|
||||
N RIEN
|
||||
S RIEN=0
|
||||
F S RIEN=$O(^PXD(811.9,"AG",DIEN,RIEN)) Q:'RIEN D
|
||||
.K ^PXD(811.9,RIEN,51),^PXD(811.9,"AG",DIEN,RIEN)
|
||||
;
|
||||
Q
|
||||
;
|
||||
VGROUP(DA,IEN) ;Check dialog index to see if group will point to itself
|
||||
N FOUND
|
||||
S FOUND=0
|
||||
;
|
||||
;Only do check if dialog is a group
|
||||
I $P($G(^PXRMD(801.41,DA,0)),U,4)'="G" Q FOUND
|
||||
;
|
||||
;Group cannot be added to itself
|
||||
I DA=IEN D Q FOUND
|
||||
.S FOUND=1
|
||||
.W !,"A group cannot be added to itself" H 2
|
||||
;
|
||||
;IEN is the dialog group being added to
|
||||
D VGROUP1(DA,IEN)
|
||||
Q FOUND
|
||||
;
|
||||
VGROUP1(DA,DIEN) ;Examine all parent dialogs
|
||||
;
|
||||
;End search if already found
|
||||
Q:FOUND
|
||||
;
|
||||
;Check if dialog being added is a parent at this level
|
||||
I $D(^PXRMD(801.41,"AD",DIEN,DA)) D Q
|
||||
.S FOUND=1
|
||||
.W !,"A group cannot be added as it's own descendant" H 2
|
||||
;
|
||||
;If not look at other parents
|
||||
N SUB
|
||||
S SUB=0
|
||||
F S SUB=$O(^PXRMD(801.41,"AD",DIEN,SUB)) Q:'SUB D Q:FOUND
|
||||
.;Ignore reminder dialogs
|
||||
.I $P($G(^PXRMD(801.41,SUB,0)),U,4)'="G" Q
|
||||
.;Repeat check on other parents
|
||||
.D VGROUP1(DA,SUB)
|
||||
Q
|
||||
;
|
||||
HELP(CALL) ;General help text routine
|
||||
N HTEXT
|
||||
N DIWF,DIWL,DIWR,IC
|
||||
S DIWF="C70",DIWL=0,DIWR=70
|
||||
;
|
||||
I CALL=1 D
|
||||
.S HTEXT(1)="Select E to edit dialog element. If you wish to create"
|
||||
.S HTEXT(2)="a new dialog element just for this reminder dialog select"
|
||||
.S HTEXT(3)="C to copy and replace the current element. Select D to"
|
||||
.S HTEXT(4)="delete the sequence number/element from the dialog."
|
||||
I CALL=2 D
|
||||
.S HTEXT(1)="Enter Y to copy the current dialog element to a new name"
|
||||
.S HTEXT(2)="and then use this new element in the reminder dialog."
|
||||
I CALL=3 D
|
||||
.S HTEXT(1)="Enter G to change the current dialog element into a dialog"
|
||||
.S HTEXT(2)="group so that additional elements can be added. Enter E to"
|
||||
.S HTEXT(3)="leave the type of the dialog element unchanged."
|
||||
I CALL=4 D
|
||||
.S HTEXT(1)="Enter Y to change the dialog prompt created into a forced"
|
||||
.S HTEXT(2)="value. To edit the new forced value switch to the forced"
|
||||
.S HTEXT(3)="value screen using CV. This option only applies to prompts"
|
||||
.S HTEXT(4)="which update PCE or vitals."
|
||||
.S HTEXT(5)="Enter N to leave the dialog prompt unchanged."
|
||||
K ^UTILITY($J,"W")
|
||||
S IC=""
|
||||
F S IC=$O(HTEXT(IC)) Q:IC="" D
|
||||
. S X=HTEXT(IC)
|
||||
. D ^DIWP
|
||||
W !
|
||||
S IC=0
|
||||
F S IC=$O(^UTILITY($J,"W",0,IC)) Q:IC="" D
|
||||
. W !,^UTILITY($J,"W",0,IC,0)
|
||||
K ^UTILITY($J,"W")
|
||||
W !
|
||||
Q
|
||||
;
|
||||
LOCK(DA) ;Lock the record
|
||||
N OK
|
||||
S OK=1
|
||||
I '$$VEDIT^PXRMUTIL("^PXRMD(801.41,",DA) D
|
||||
.N DTYP
|
||||
.S DTYP=$P($G(^PXRMD(801.41,DA,0)),U,4)
|
||||
.;Allow limit edit of Result Elements that are not lock
|
||||
.I DTYP="T",+$P($G(^PXRMD(801.41,DA,100)),U,4)=0 Q
|
||||
.;Allow edit of findings but not component multiple on groups
|
||||
.I DTYP="G",$G(PXRMDIEN),DA'=PXRMDIEN Q
|
||||
.I DTYP="G",$G(PXRMGTYP)="DLGE" Q
|
||||
.;Allow edit of element findings
|
||||
.I DTYP="E" Q
|
||||
.S OK=0
|
||||
.W !!,?5,"VA- and national class reminder dialogs may not be edited" H 2
|
||||
I 'OK Q 0
|
||||
;
|
||||
L +^PXRMD(801.41,DA):0 I Q 1
|
||||
E W !!,?5,"Another user is editing this file, try later" H 2 Q 0
|
||||
;
|
||||
PROMPT(IEN) ;
|
||||
N DIE,DR
|
||||
S DIE="^PXRMD(801.41,",DA=IEN
|
||||
S DR=".01;3;100;101;102;24;23;21"
|
||||
S IEN=$G(^PXRMD(801.41,IEN,46)) I $G(IEN)="" G EX
|
||||
I $P($G(^PXRMD(801.42,IEN,0)),U)="COM" S DR=DR_";45"
|
||||
EX ;
|
||||
D ^DIE
|
||||
Q
|
||||
;
|
||||
UNLOCK(DA) ;Unlock the record
|
||||
L -^PXRMD(801.41,DA)
|
||||
Q
|
||||
PXRMDEDT ; SLC/PJH - Edit PXRM reminder dialog. ;07/28/2006
|
||||
;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
|
||||
;
|
||||
;Used by protocol PXRM SELECTION ADD/PXRM GENERAL ADD
|
||||
;
|
||||
;Add Dialog
|
||||
;----------
|
||||
ADD N DA,DIC,Y,DTOUT,DUOUT,DTYP,DLAYGO,HED
|
||||
S HED="ADD DIALOG"
|
||||
W IORESET
|
||||
F D Q:$D(DTOUT)
|
||||
.S DIC="^PXRMD(801.41,"
|
||||
.;Set the starting place for additions.
|
||||
.D SETSTART^PXRMCOPY(DIC)
|
||||
.S DIC(0)="AELMQ",DLAYGO=801.41
|
||||
.S DIC("A")="Select DIALOG to add: "
|
||||
.S DIC("DR")="4///"_$G(PXRMDTYP)
|
||||
.D ^DIC
|
||||
.I $D(DUOUT) S DTOUT=1
|
||||
.I ($D(DTOUT))!($D(DUOUT)) Q
|
||||
.I Y=-1 K DIC S DTOUT=1 Q
|
||||
.I $P(Y,U,3)'=1 W !,"This dialog name already exists" Q
|
||||
.S DA=$P(Y,U,1)
|
||||
.;Determine dialog type
|
||||
.S DTYP=$P($G(^PXRMD(801.41,DA,0)),U,4)
|
||||
.;Enter dialog type if a new entry
|
||||
.I DTYP="" D Q:$D(Y)
|
||||
..N DIE,DR
|
||||
..S DIE=801.41,DR=4
|
||||
..D ^DIE
|
||||
.;
|
||||
.;Edit Dialog
|
||||
.D EDIT(DTYP,DA,0)
|
||||
Q
|
||||
;
|
||||
;called by protocol PXRM DIALOG EDIT
|
||||
;-----------------------------------
|
||||
EDIT(TYP,DA,OIEN) ;
|
||||
Q:'$$LOCK(DA)
|
||||
W IORESET
|
||||
N CS1,CS2,D1,DIC,DIDEL,DIE,DR,DTOUT,DUOUT,DINUSE,TYP,ODA,Y
|
||||
;Save checksum
|
||||
S VALMBCK=""
|
||||
S CS1=$$FILE^PXRMEXCS(801.41,DA)
|
||||
;
|
||||
;Check dialog type
|
||||
S TYP=$P($G(^PXRMD(801.41,DA,0)),U,4)
|
||||
S DIE="^PXRMD(801.41,",DIDEL=801.41,DINUSE=0,ODA=DA
|
||||
;Reminder Dialog
|
||||
I TYP="R" S DR="[PXRM EDIT REMINDER DIALOG]"
|
||||
;Dialog Element
|
||||
I TYP="E" S DR="[PXRM EDIT ELEMENT]"
|
||||
;Additional Prompt
|
||||
;I TYP="P" S DR="[PXRM EDIT PROMPT]"
|
||||
;Forced Value
|
||||
I TYP="F" S DR="[PXRM EDIT FORCED VALUE]"
|
||||
;Dialog Group (Finding item dialog)
|
||||
I TYP="G" S DR="[PXRM EDIT GROUP]" ;S VALMBCK="R"
|
||||
;Result Group
|
||||
I TYP="S" S DR="[PXRM RESULT GROUP]"
|
||||
;Result Element
|
||||
I TYP="T" S DR="[PXRM RESULT ELEMENT]"
|
||||
;Allows limited edit of national dialogs
|
||||
I $P($G(^PXRMD(801.41,DA,100)),U)="N" D
|
||||
.I $G(PXRMINST)=1,DUZ(0)="@" Q
|
||||
.S DR="[PXRM EDIT NATIONAL DIALOG]",DINUSE=1
|
||||
;
|
||||
I "GEPF"[TYP D
|
||||
.I '$D(^PXRMD(801.41,"AD",DA)) W !,"Not used by any other dialog",! Q
|
||||
.I PXRMGTYP'="DLG" S DINUSE=1 Q
|
||||
.I PXRMGTYP="DLG" D Q
|
||||
..N SUB
|
||||
..S SUB=0
|
||||
..F S SUB=$O(^PXRMD(801.41,"AD",DA,SUB)) Q:'SUB Q:DINUSE D
|
||||
...I SUB'=PXRMDIEN S DINUSE=1
|
||||
I DINUSE D
|
||||
.W !,"Current dialog element/group name: "_$P($G(^PXRMD(801.41,DA,0)),U)
|
||||
.I TYP="S" Q
|
||||
.I PXRMGTYP="DLGE" D
|
||||
..W !,"Used by:" D USE^PXRMDLST(DA,10,"")
|
||||
..I $D(^PXRMD(801.41,"R",DA))'>0 Q
|
||||
..W !,"Used as a Replacement Element/Group for: " D REPLACE^PXRMDLST(DA,10,"")
|
||||
.I PXRMGTYP'="DLGE" D
|
||||
..W !,"Used by:" D USE^PXRMDLST(DA,10,PXRMDIEN)
|
||||
..I $D(^PXRMD(801.41,"R",DA))'>0 Q
|
||||
..W !,"Used as a Replacement Element/Group for: " D REPLACE^PXRMDLST(DA,10,PXRMDIEN)
|
||||
;
|
||||
;Save list of components
|
||||
N COMP D COMP^PXRMDEDX(DA,.COMP)
|
||||
;Edit dialog then unlock
|
||||
I TYP'="P" D ^DIE D UNLOCK(ODA) I $G(DA)="",$G(OIEN)>0 D
|
||||
.S DA=OIEN,DR="118////@" D ^DIE K DA
|
||||
I TYP="P" D PROMPT(DA) D UNLOCK(ODA)
|
||||
I '$D(DUOUT)&($G(D1)'="") D Q
|
||||
. I $P($G(^PXRMD(801.41,DA,10,D1,0)),U,2)="" D Q
|
||||
. . S DA(1)=DA,DA=D1 Q:'DA
|
||||
. . S DIK="^PXRMD(801.41,"_DA(1)_",10,"
|
||||
. . D ^DIK
|
||||
. . S VALMBG=1
|
||||
I '$D(DA) D Q
|
||||
.;Clear any pointers from #811.9
|
||||
.I $D(PXRMDIEN) D PURGE(PXRMDIEN)
|
||||
.;Option to delete components
|
||||
.I $D(COMP) D DELETE^PXRMDEDX(.COMP)
|
||||
.S VALMBCK="R"
|
||||
;
|
||||
;Update edit history
|
||||
I (TYP'="R") D
|
||||
.S CS2=$$FILE^PXRMEXCS(801.41,DA) Q:CS2=CS1 Q:+CS2=0
|
||||
.S DIC="^PXRMD(801.41,"
|
||||
.D SEHIST^PXRMUTIL(801.41,DIC,DA)
|
||||
;
|
||||
;Redisplay changes (reminder dialog option only)
|
||||
I PXRMGTYP="DLG",TYP="R" D
|
||||
.;Get name of reminder dialog again
|
||||
.S Y=$P($G(^PXRMD(801.41,DA,0)),U)
|
||||
.;Format headings to include dialog name
|
||||
.S PXRMHD="REMINDER DIALOG NAME: "_$P(Y,U)
|
||||
.;Check if the set is disable and add to header if disabled
|
||||
.I $P(^PXRMD(801.41,DA,0),U,3)]"" S PXRMHD=PXRMHD_" (DISABLED)"
|
||||
.;Reset header in case name has changed
|
||||
.S VALMHDR(1)=PXRMHD
|
||||
Q
|
||||
;
|
||||
;Add SINGLE dialog element (protocol PXRM DIALOG SELECTION ITEM)
|
||||
;-------------------------
|
||||
ESEL(PXRMDIEN,SEL) ;
|
||||
N DA,DIC,DLAYGO,DNEW,DTOUT,DUOUT,DTYP,Y
|
||||
;
|
||||
S DIC="^PXRMD(801.41,"
|
||||
S DLAYGO="801.41"
|
||||
;Set the starting place for additions.
|
||||
D SETSTART^PXRMCOPY(DIC)
|
||||
S DIC(0)="AEMQL"
|
||||
S DIC("A")="Select new DIALOG ELEMENT: "
|
||||
S DIC("S")="I ""EG""[$P(^PXRMD(801.41,Y,0),U,4)"
|
||||
S DIC("DR")="4///E"
|
||||
W !
|
||||
D ^DIC
|
||||
I $D(DUOUT) S DTOUT=1
|
||||
I ($D(DTOUT))!($D(DUOUT)) Q
|
||||
I Y=-1 K DIC S DTOUT=1 Q
|
||||
S DA=$P(Y,U,1) Q:'DA
|
||||
S DNEW=$P(Y,U,3)
|
||||
;Group points to itself
|
||||
I 'DNEW,$$VGROUP(DA,PXRMDIEN) Q
|
||||
;Add to dialog
|
||||
D EADD(SEL,DA,PXRMDIEN)
|
||||
;Determine dialog type
|
||||
S DTYP=$P($G(^PXRMD(801.41,DA,0)),U,4)
|
||||
;
|
||||
;Edit Dialog
|
||||
I DNEW D EDIT(DTYP,DA)
|
||||
Q
|
||||
;
|
||||
;Update dialog component multiple
|
||||
;--------------------------------
|
||||
EADD(SEL,NSUB,PXRMDIEN) ;
|
||||
N DA,DATA,NEXT
|
||||
S DATA=$G(^PXRMD(801.41,PXRMDIEN,10,0)),NEXT=$P(DATA,U,3)+1
|
||||
I DATA="" S DATA="^801.412IA"
|
||||
S DA=NSUB,DA(1)=PXRMDIEN
|
||||
S ^PXRMD(801.41,PXRMDIEN,10,NEXT,0)=SEL_U_DA_"^^^^^^^"
|
||||
;Update next slot
|
||||
S $P(DATA,U,4)=$P(DATA,U,4)+1,$P(DATA,U,3)=NEXT
|
||||
S ^PXRMD(801.41,PXRMDIEN,10,0)=DATA
|
||||
;Re-index
|
||||
N DIK,DA S DIK="^PXRMD(801.41,",DA=PXRMDIEN
|
||||
D IX^DIK
|
||||
Q
|
||||
;
|
||||
;Change Dialog Element Type
|
||||
;--------------------------
|
||||
NTYP(TYP) ;
|
||||
N X,Y,DIR K DIROUT,DIRUT,DTOUT,DUOUT
|
||||
S DIR(0)="SA"_U_"E:Element;"
|
||||
S DIR(0)=DIR(0)_"G:Group;"
|
||||
S DIR("A")="Dialog Element Type: "
|
||||
S DIR("B")="E"
|
||||
S DIR("?")="Select from the codes displayed. For detailed help type ??"
|
||||
S DIR("??")=U_"D HELP^PXRMDEDT(3)"
|
||||
D ^DIR K DIR
|
||||
I $D(DIROUT) S DTOUT=1
|
||||
I $D(DTOUT)!($D(DUOUT)) Q
|
||||
S TYP=Y
|
||||
Q
|
||||
;
|
||||
;Clear pointers from the reminder file and process ID file
|
||||
;---------------------------------------------------------
|
||||
PURGE(DIEN) ;
|
||||
;Purge pointers to this dialog from reminder file
|
||||
N RIEN
|
||||
S RIEN=0
|
||||
F S RIEN=$O(^PXD(811.9,"AG",DIEN,RIEN)) Q:'RIEN D
|
||||
.K ^PXD(811.9,RIEN,51),^PXD(811.9,"AG",DIEN,RIEN)
|
||||
;
|
||||
Q
|
||||
;
|
||||
VGROUP(DA,IEN) ;Check dialog index to see if group will point to itself
|
||||
N FOUND
|
||||
S FOUND=0
|
||||
;
|
||||
;Only do check if dialog is a group
|
||||
I $P($G(^PXRMD(801.41,DA,0)),U,4)'="G" Q FOUND
|
||||
;
|
||||
;Group cannot be added to itself
|
||||
I DA=IEN D Q FOUND
|
||||
.S FOUND=1
|
||||
.W !,"A group cannot be added to itself" H 2
|
||||
;
|
||||
;IEN is the dialog group being added to
|
||||
D VGROUP1(DA,IEN)
|
||||
Q FOUND
|
||||
;
|
||||
VGROUP1(DA,DIEN) ;Examine all parent dialogs
|
||||
;
|
||||
;End search if already found
|
||||
Q:FOUND
|
||||
;
|
||||
;Check if dialog being added is a parent at this level
|
||||
I $D(^PXRMD(801.41,"AD",DIEN,DA)) D Q
|
||||
.S FOUND=1
|
||||
.W !,"A group cannot be added as it's own descendant" H 2
|
||||
;
|
||||
;If not look at other parents
|
||||
N SUB
|
||||
S SUB=0
|
||||
F S SUB=$O(^PXRMD(801.41,"AD",DIEN,SUB)) Q:'SUB D Q:FOUND
|
||||
.;Ignore reminder dialogs
|
||||
.I $P($G(^PXRMD(801.41,SUB,0)),U,4)'="G" Q
|
||||
.;Repeat check on other parents
|
||||
.D VGROUP1(DA,SUB)
|
||||
Q
|
||||
;
|
||||
HELP(CALL) ;General help text routine
|
||||
N HTEXT
|
||||
N DIWF,DIWL,DIWR,IC
|
||||
S DIWF="C70",DIWL=0,DIWR=70
|
||||
;
|
||||
I CALL=1 D
|
||||
.S HTEXT(1)="Select E to edit dialog element. If you wish to create"
|
||||
.S HTEXT(2)="a new dialog element just for this reminder dialog select"
|
||||
.S HTEXT(3)="C to copy and replace the current element. Select D to"
|
||||
.S HTEXT(4)="delete the sequence number/element from the dialog."
|
||||
I CALL=2 D
|
||||
.S HTEXT(1)="Enter Y to copy the current dialog element to a new name"
|
||||
.S HTEXT(2)="and then use this new element in the reminder dialog."
|
||||
I CALL=3 D
|
||||
.S HTEXT(1)="Enter G to change the current dialog element into a dialog"
|
||||
.S HTEXT(2)="group so that additional elements can be added. Enter E to"
|
||||
.S HTEXT(3)="leave the type of the dialog element unchanged."
|
||||
I CALL=4 D
|
||||
.S HTEXT(1)="Enter Y to change the dialog prompt created into a forced"
|
||||
.S HTEXT(2)="value. To edit the new forced value switch to the forced"
|
||||
.S HTEXT(3)="value screen using CV. This option only applies to prompts"
|
||||
.S HTEXT(4)="which update PCE or vitals."
|
||||
.S HTEXT(5)="Enter N to leave the dialog prompt unchanged."
|
||||
K ^UTILITY($J,"W")
|
||||
S IC=""
|
||||
F S IC=$O(HTEXT(IC)) Q:IC="" D
|
||||
. S X=HTEXT(IC)
|
||||
. D ^DIWP
|
||||
W !
|
||||
S IC=0
|
||||
F S IC=$O(^UTILITY($J,"W",0,IC)) Q:IC="" D
|
||||
. W !,^UTILITY($J,"W",0,IC,0)
|
||||
K ^UTILITY($J,"W")
|
||||
W !
|
||||
Q
|
||||
;
|
||||
LOCK(DA) ;Lock the record
|
||||
N OK
|
||||
S OK=1
|
||||
I '$$VEDIT^PXRMUTIL("^PXRMD(801.41,",DA) D
|
||||
.N DTYP
|
||||
.S DTYP=$P($G(^PXRMD(801.41,DA,0)),U,4)
|
||||
.;Allow edit of findings but not component multiple on groups
|
||||
.I DTYP="G",$G(PXRMDIEN),DA'=PXRMDIEN Q
|
||||
.I DTYP="G",$G(PXRMGTYP)="DLGE" Q
|
||||
.;Allow edit of element findings
|
||||
.I DTYP="E" Q
|
||||
.S OK=0
|
||||
.W !!,?5,"VA- and national class reminder dialogs may not be edited" H 2
|
||||
I 'OK Q 0
|
||||
;
|
||||
L +^PXRMD(801.41,DA):0 I Q 1
|
||||
E W !!,?5,"Another user is editing this file, try later" H 2 Q 0
|
||||
;
|
||||
PROMPT(IEN) ;
|
||||
N DIE,DR
|
||||
S DIE="^PXRMD(801.41,",DA=IEN
|
||||
S DR=".01;3;100;101;102;24;23;21"
|
||||
S IEN=$G(^PXRMD(801.41,IEN,46)) I $G(IEN)="" G EX
|
||||
I $P($G(^PXRMD(801.42,IEN,0)),U)="COM" S DR=DR_";45"
|
||||
EX ;
|
||||
D ^DIE
|
||||
Q
|
||||
;
|
||||
UNLOCK(DA) ;Unlock the record
|
||||
L -^PXRMD(801.41,DA)
|
||||
Q
|
||||
|
|
|
|||
|
|
@ -1,148 +1,150 @@
|
|||
PXRMDEV ; SLC/PKR - This is a driver for testing Clinical Reminders.;01/24/2007
|
||||
;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
|
||||
;
|
||||
;==================================================
|
||||
CMOUT ;Do formatted Clinical Maintenance output.
|
||||
N DUE,DUECOL,HIST,LAST,LASTCOL,LNUM,RIEN,RNAME,STATUS,STATCOL,TEMP,TYPE
|
||||
W !!,"Formatted Output:"
|
||||
S RIEN=$O(^TMP("PXRHM",$J,""))
|
||||
S RNAME=$O(^TMP("PXRHM",$J,RIEN,""))
|
||||
S TEMP=$G(^TMP("PXRHM",$J,RIEN,RNAME))
|
||||
S STATUS=$P(TEMP,U,1)
|
||||
S DUE=$$EDATE^PXRMDATE($P(TEMP,U,2))
|
||||
S LAST=$$EDATE^PXRMDATE($P(TEMP,U,3))
|
||||
S STATCOL=41-($L(STATUS)/2)
|
||||
S DUECOL=53-($L(DUE)/2)
|
||||
S LASTCOL=67-($L(LAST)/2)
|
||||
W !!,?36,"--STATUS--",?47,"--DUE DATE--",?61,"--LAST DONE--",!
|
||||
W !,RNAME,?STATCOL,STATUS,?DUECOL,DUE,?LASTCOL,LAST,!
|
||||
S LNUM=0
|
||||
F S LNUM=$O(^TMP("PXRHM",$J,RIEN,RNAME,"TXT",LNUM)) Q:LNUM="" D
|
||||
. W !,^TMP("PXRHM",$J,RIEN,RNAME,"TXT",LNUM)
|
||||
Q
|
||||
;
|
||||
;==================================================
|
||||
DEB ;Prompt for patient and reminder by name input component.
|
||||
N DATE,DFN,DIC,DIR,DIROUT,DTOUT,DUOUT,PXRMITEM,PXRHM,PXRMTDEB,X,Y
|
||||
S DIC=2,DIC("A")="Select Patient: "
|
||||
S DIC(0)="AEQMZ"
|
||||
D ^DIC
|
||||
I $D(DTOUT)!$D(DUOUT) Q
|
||||
S DFN=+$P(Y,U,1)
|
||||
I DFN=-1 W !,"No patient selected!" Q
|
||||
S DIC=811.9,DIC("A")="Select Reminder: "
|
||||
D ^DIC
|
||||
I $D(DIROUT)!$D(DIRUT) Q
|
||||
I $D(DTOUT)!$D(DUOUT) Q
|
||||
S PXRMITEM=+$P(Y,U,1)
|
||||
I PXRMITEM=-1 W !,"No reminder selected!" Q
|
||||
S DIR(0)="LA"_U_"0"
|
||||
S DIR("A")="Enter component number 0, 1, 5, 10, 11, 12: "
|
||||
D ^DIR
|
||||
I $D(DIROUT)!$D(DIRUT) Q
|
||||
I $D(DTOUT)!$D(DUOUT) Q
|
||||
I X="" S X=5
|
||||
S PXRHM=X
|
||||
S DIR(0)="DA^"_0_"::ETX"
|
||||
S DIR("A")="Enter date for reminder evaluation: "
|
||||
S DIR("B")=$$FMTE^XLFDT($$DT^XLFDT,"D")
|
||||
S DIR("PRE")="S X=$$DCHECK^PXRMDATE(X) K:X=-1 X"
|
||||
W !
|
||||
D ^DIR K DIR
|
||||
I $D(DIROUT)!$D(DIRUT) Q
|
||||
I $D(DTOUT)!$D(DUOUT) Q
|
||||
S DATE=Y
|
||||
I $D(^PXD(811.9,PXRMITEM,20,"E","PXRMD(811.5,")) S PXRMTDEB=$$ASKYN^PXRMEUT("N","Display all term findings","","")
|
||||
D DOREM(DFN,PXRMITEM,PXRHM,DATE)
|
||||
Q
|
||||
;
|
||||
;==================================================
|
||||
DEV ;Prompt for patient and reminder by name and evaluation date.
|
||||
N DATE,DFN,DIC,DIROUT,DIRUT,DTOUT,DUOUT,PXRMITEM,PXRHM,PXRMTDEB,REF,X,Y
|
||||
S DIC=2,DIC("A")="Select Patient: "
|
||||
S DIC(0)="AEQMZ"
|
||||
D ^DIC
|
||||
I $D(DIROUT)!$D(DIRUT) Q
|
||||
I $D(DTOUT)!$D(DUOUT) Q
|
||||
S DFN=+$P(Y,U,1)
|
||||
S DIC=811.9,DIC("A")="Select Reminder: "
|
||||
D ^DIC
|
||||
I $D(DIROUT)!$D(DIRUT) Q
|
||||
I $D(DTOUT)!$D(DUOUT) Q
|
||||
S PXRMITEM=+$P(Y,U,1)
|
||||
S PXRHM=5
|
||||
S DIR(0)="DA^"_0_"::ETX"
|
||||
S DIR("A")="Enter date for reminder evaluation: "
|
||||
S DIR("B")=$$FMTE^XLFDT($$DT^XLFDT,"D")
|
||||
S DIR("PRE")="S X=$$DCHECK^PXRMDATE(X) K:X=-1 X"
|
||||
W !
|
||||
D ^DIR K DIR
|
||||
I $D(DIROUT)!$D(DIRUT) Q
|
||||
I $D(DTOUT)!$D(DUOUT) Q
|
||||
S DATE=Y
|
||||
I $D(^PXD(811.9,PXRMITEM,20,"E","PXRMD(811.5,")) S PXRMTDEB=$$ASKYN^PXRMEUT("N","Display all term findings","","")
|
||||
D DOREM(DFN,PXRMITEM,PXRHM,DATE)
|
||||
Q
|
||||
;
|
||||
;==================================================
|
||||
DOREM(DFN,PXRMITEM,PXRMHM,DATE) ;Do the reminder
|
||||
N DEFARR,FIEVAL,FINDING,PXRMDEBG,PXRMID,REF,TFIEVAL
|
||||
;This is a debugging run so set PXRMDEBG.
|
||||
S PXRMDEBG=1
|
||||
D DEF^PXRMLDR(PXRMITEM,.DEFARR)
|
||||
I +$G(DATE)=0 D EVAL^PXRM(DFN,.DEFARR,PXRHM,1,.FIEVAL)
|
||||
I +$G(DATE)>0 D EVAL^PXRM(DFN,.DEFARR,PXRHM,1,.FIEVAL,DATE)
|
||||
;
|
||||
W !!,"The elements of the FIEVAL array are:"
|
||||
S REF="FIEVAL"
|
||||
D AWRITE^PXRMUTIL(REF)
|
||||
;
|
||||
I $G(PXRMTDEB) D
|
||||
. W !!,"Term findings:"
|
||||
. S REF="TFIEVAL"
|
||||
. S FINDING=0
|
||||
. F S FINDING=$O(^TMP("PXRMTDEB",$J,FINDING)) Q:FINDING="" D
|
||||
.. K TFIEVAL M TFIEVAL(FINDING)=^TMP("PXRMTDEB",$J,FINDING)
|
||||
.. W !,"Finding ",FINDING,":"
|
||||
.. D AWRITE^PXRMUTIL(REF)
|
||||
. K ^TMP("PXRMTDEB",$J)
|
||||
;
|
||||
W !!,"The elements of the ^TMP(PXRMID,$J) array are:"
|
||||
I $D(PXRMID) S REF="^TMP(PXRMID,$J)" D AWRITE^PXRMUTIL(REF) K ^TMP(PXRMID,$J)
|
||||
;
|
||||
W !!,"The elements of the ^TMP(""PXRHM"",$J) array are:"
|
||||
S REF="^TMP(""PXRHM"",$J)"
|
||||
D AWRITE^PXRMUTIL(REF)
|
||||
;
|
||||
I $D(^TMP("PXRHM",$J)) D CMOUT
|
||||
I PXRHM=12 D MHVCOUT
|
||||
K ^TMP("PXRM",$J),^TMP("PXRHM",$J),^TMP("PXRMMHVC",$J)
|
||||
Q
|
||||
;==================================================
|
||||
MHVCOUT ;Do formatted MHV combined output.
|
||||
N DUE,DUECOL,HIST,LAST,LASTCOL,LNUM,RIEN,RNAME,STATUS,STATCOL,TEMP,TYPE
|
||||
W !!,"Formatted Output:"
|
||||
S RIEN=$O(^TMP("PXRMMHVC",$J,""))
|
||||
S TEMP=^TMP("PXRMMHVC",$J,RIEN,"STATUS")
|
||||
S STATUS=$P(TEMP,U,1)
|
||||
S DUE=$$EDATE^PXRMDATE($P(TEMP,U,2))
|
||||
S LAST=$$EDATE^PXRMDATE($P(TEMP,U,3))
|
||||
S DUE=$$EDATE^PXRMDATE($P(TEMP,U,2))
|
||||
S LAST=$$EDATE^PXRMDATE($P(TEMP,U,3))
|
||||
S STATCOL=41-($L(STATUS)/2)
|
||||
S DUECOL=53-($L(DUE)/2)
|
||||
S LASTCOL=67-($L(LAST)/2)
|
||||
S RNAME=$P(^PXD(811.9,RIEN,0),U,3)
|
||||
I RNAME="" S RNAME=$P(^PXD(811.9,RIEN,0),U,1)
|
||||
W !!,?36,"--STATUS--",?47,"--DUE DATE--",?61,"--LAST DONE--",!
|
||||
W !,RNAME,?STATCOL,STATUS,?DUECOL,DUE,?LASTCOL,LAST,!
|
||||
W !!,"---------- Detailed Output ----------"
|
||||
S LNUM=0
|
||||
F S LNUM=$O(^TMP("PXRMMHVC",$J,RIEN,"DETAIL",LNUM)) Q:LNUM="" D
|
||||
. W !,^TMP("PXRMMHVC",$J,RIEN,"DETAIL",LNUM)
|
||||
W !!,"---------- Summary Output ----------"
|
||||
S LNUM=0
|
||||
F S LNUM=$O(^TMP("PXRMMHVC",$J,RIEN,"SUMMARY",LNUM)) Q:LNUM="" D
|
||||
. W !,^TMP("PXRMMHVC",$J,RIEN,"SUMMARY",LNUM)
|
||||
Q
|
||||
;
|
||||
PXRMDEV ; SLC/PKR - This is a driver for testing Clinical Reminders.;05/04/2006
|
||||
;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
|
||||
;
|
||||
;==================================================
|
||||
CMOUT ;Do formatted Clinical Maintenance output.
|
||||
N DUE,DUECOL,HIST,LAST,LASTCOL,LNUM,RIEN,RNAME,STATUS,STATCOL,TEMP,TYPE
|
||||
W !!,"Formatted Output:"
|
||||
S RIEN=$O(^TMP("PXRHM",$J,""))
|
||||
S RNAME=$O(^TMP("PXRHM",$J,RIEN,""))
|
||||
S TEMP=$G(^TMP("PXRHM",$J,RIEN,RNAME))
|
||||
S STATUS=$P(TEMP,U,1)
|
||||
S DUE=$$EDATE^PXRMDATE($P(TEMP,U,2))
|
||||
S LAST=$$EDATE^PXRMDATE($P(TEMP,U,3))
|
||||
S STATCOL=41-($L(STATUS)/2)
|
||||
S DUECOL=53-($L(DUE)/2)
|
||||
S LASTCOL=67-($L(LAST)/2)
|
||||
W !!,?36,"--STATUS--",?47,"--DUE DATE--",?61,"--LAST DONE--",!
|
||||
W !,RNAME,?STATCOL,STATUS,?DUECOL,DUE,?LASTCOL,LAST,!
|
||||
S LNUM=0
|
||||
F S LNUM=$O(^TMP("PXRHM",$J,RIEN,RNAME,"TXT",LNUM)) Q:LNUM="" D
|
||||
. W !,^TMP("PXRHM",$J,RIEN,RNAME,"TXT",LNUM)
|
||||
Q
|
||||
;
|
||||
;==================================================
|
||||
DEB ;Prompt for patient and reminder by name input component.
|
||||
N DATE,DFN,DIC,DIR,DIROUT,DTOUT,DUOUT,PXRMITEM,PXRHM,PXRMTDEB,X,Y
|
||||
S DIC=2,DIC("A")="Select Patient: "
|
||||
S DIC(0)="AEQMZ"
|
||||
D ^DIC
|
||||
I $D(DTOUT)!$D(DUOUT) Q
|
||||
S DFN=+$P(Y,U,1)
|
||||
I DFN=-1 W !,"No patient selected!" Q
|
||||
S DIC=811.9,DIC("A")="Select Reminder: "
|
||||
S DIC("S")="I $P(^PXD(811.9,Y,100),U,4)'[""L"""
|
||||
D ^DIC
|
||||
I $D(DIROUT)!$D(DIRUT) Q
|
||||
I $D(DTOUT)!$D(DUOUT) Q
|
||||
S PXRMITEM=+$P(Y,U,1)
|
||||
I PXRMITEM=-1 W !,"No reminder selected!" Q
|
||||
S DIR(0)="LA"_U_"0"
|
||||
S DIR("A")="Enter component number 0, 1, 5, 10, 11, 12: "
|
||||
D ^DIR
|
||||
I $D(DIROUT)!$D(DIRUT) Q
|
||||
I $D(DTOUT)!$D(DUOUT) Q
|
||||
I X="" S X=5
|
||||
S PXRHM=X
|
||||
S DIR(0)="DA^"_0_"::ETX"
|
||||
S DIR("A")="Enter date for reminder evaluation: "
|
||||
S DIR("B")=$$FMTE^XLFDT($$DT^XLFDT,"D")
|
||||
S DIR("PRE")="S X=$$DCHECK^PXRMDATE(X) K:X=-1 X"
|
||||
W !
|
||||
D ^DIR K DIR
|
||||
I $D(DIROUT)!$D(DIRUT) Q
|
||||
I $D(DTOUT)!$D(DUOUT) Q
|
||||
S DATE=Y
|
||||
I $D(^PXD(811.9,PXRMITEM,20,"E","PXRMD(811.5,")) S PXRMTDEB=$$ASKYN^PXRMEUT("N","Display all term findings","","")
|
||||
D DOREM(DFN,PXRMITEM,PXRHM,DATE)
|
||||
Q
|
||||
;
|
||||
;==================================================
|
||||
DEV ;Prompt for patient and reminder by name and evaluation date.
|
||||
N DATE,DFN,DIC,DIROUT,DIRUT,DTOUT,DUOUT,PXRMITEM,PXRHM,PXRMTDEB,REF,X,Y
|
||||
S DIC=2,DIC("A")="Select Patient: "
|
||||
S DIC(0)="AEQMZ"
|
||||
D ^DIC
|
||||
I $D(DIROUT)!$D(DIRUT) Q
|
||||
I $D(DTOUT)!$D(DUOUT) Q
|
||||
S DFN=+$P(Y,U,1)
|
||||
S DIC=811.9,DIC("A")="Select Reminder: "
|
||||
S DIC("S")="I $P(^PXD(811.9,Y,100),U,4)'[""L"""
|
||||
D ^DIC
|
||||
I $D(DIROUT)!$D(DIRUT) Q
|
||||
I $D(DTOUT)!$D(DUOUT) Q
|
||||
S PXRMITEM=+$P(Y,U,1)
|
||||
S PXRHM=5
|
||||
S DIR(0)="DA^"_0_"::ETX"
|
||||
S DIR("A")="Enter date for reminder evaluation: "
|
||||
S DIR("B")=$$FMTE^XLFDT($$DT^XLFDT,"D")
|
||||
S DIR("PRE")="S X=$$DCHECK^PXRMDATE(X) K:X=-1 X"
|
||||
W !
|
||||
D ^DIR K DIR
|
||||
I $D(DIROUT)!$D(DIRUT) Q
|
||||
I $D(DTOUT)!$D(DUOUT) Q
|
||||
S DATE=Y
|
||||
I $D(^PXD(811.9,PXRMITEM,20,"E","PXRMD(811.5,")) S PXRMTDEB=$$ASKYN^PXRMEUT("N","Display all term findings","","")
|
||||
D DOREM(DFN,PXRMITEM,PXRHM,DATE)
|
||||
Q
|
||||
;
|
||||
;==================================================
|
||||
DOREM(DFN,PXRMITEM,PXRMHM,DATE) ;Do the reminder
|
||||
N DEFARR,FIEVAL,FINDING,PXRMDEBG,PXRMID,REF,TFIEVAL
|
||||
;This is a debugging run so set PXRMDEBG.
|
||||
S PXRMDEBG=1
|
||||
D DEF^PXRMLDR(PXRMITEM,.DEFARR)
|
||||
I +$G(DATE)=0 D EVAL^PXRM(DFN,.DEFARR,PXRHM,1,.FIEVAL)
|
||||
I +$G(DATE)>0 D EVAL^PXRM(DFN,.DEFARR,PXRHM,1,.FIEVAL,DATE)
|
||||
;
|
||||
W !!,"The elements of the FIEVAL array are:"
|
||||
S REF="FIEVAL"
|
||||
D AWRITE^PXRMUTIL(REF)
|
||||
;
|
||||
I $G(PXRMTDEB) D
|
||||
. W !!,"Term findings:"
|
||||
. S REF="TFIEVAL"
|
||||
. S FINDING=0
|
||||
. F S FINDING=$O(^TMP("PXRMTDEB",$J,FINDING)) Q:FINDING="" D
|
||||
.. K TFIEVAL M TFIEVAL(FINDING)=^TMP("PXRMTDEB",$J,FINDING)
|
||||
.. W !,"Finding ",FINDING,":"
|
||||
.. D AWRITE^PXRMUTIL(REF)
|
||||
. K ^TMP("PXRMTDEB",$J)
|
||||
;
|
||||
W !!,"The elements of the ^TMP(PXRMID,$J) array are:"
|
||||
I $D(PXRMID) S REF="^TMP(PXRMID,$J)" D AWRITE^PXRMUTIL(REF) K ^TMP(PXRMID,$J)
|
||||
;
|
||||
W !!,"The elements of the ^TMP(""PXRHM"",$J) array are:"
|
||||
S REF="^TMP(""PXRHM"",$J)"
|
||||
D AWRITE^PXRMUTIL(REF)
|
||||
;
|
||||
I $D(^TMP("PXRHM",$J)) D CMOUT
|
||||
I PXRHM=12 D MHVCOUT
|
||||
K ^TMP("PXRM",$J),^TMP("PXRHM",$J),^TMP("PXRMMHVC",$J)
|
||||
Q
|
||||
;==================================================
|
||||
MHVCOUT ;Do formatted MHV combined output.
|
||||
N DUE,DUECOL,HIST,LAST,LASTCOL,LNUM,RIEN,RNAME,STATUS,STATCOL,TEMP,TYPE
|
||||
W !!,"Formatted Output:"
|
||||
S RIEN=$O(^TMP("PXRMMHVC",$J,""))
|
||||
S TEMP=^TMP("PXRMMHVC",$J,RIEN,"STATUS")
|
||||
S STATUS=$P(TEMP,U,1)
|
||||
S DUE=$$EDATE^PXRMDATE($P(TEMP,U,2))
|
||||
S LAST=$$EDATE^PXRMDATE($P(TEMP,U,3))
|
||||
S DUE=$$EDATE^PXRMDATE($P(TEMP,U,2))
|
||||
S LAST=$$EDATE^PXRMDATE($P(TEMP,U,3))
|
||||
S STATCOL=41-($L(STATUS)/2)
|
||||
S DUECOL=53-($L(DUE)/2)
|
||||
S LASTCOL=67-($L(LAST)/2)
|
||||
S RNAME=$P(^PXD(811.9,RIEN,0),U,3)
|
||||
I RNAME="" S RNAME=$P(^PXD(811.9,RIEN,0),U,1)
|
||||
W !!,?36,"--STATUS--",?47,"--DUE DATE--",?61,"--LAST DONE--",!
|
||||
W !,RNAME,?STATCOL,STATUS,?DUECOL,DUE,?LASTCOL,LAST,!
|
||||
W !!,"---------- Detailed Output ----------"
|
||||
S LNUM=0
|
||||
F S LNUM=$O(^TMP("PXRMMHVC",$J,RIEN,"DETAIL",LNUM)) Q:LNUM="" D
|
||||
. W !,^TMP("PXRMMHVC",$J,RIEN,"DETAIL",LNUM)
|
||||
W !!,"---------- Summary Output ----------"
|
||||
S LNUM=0
|
||||
F S LNUM=$O(^TMP("PXRMMHVC",$J,RIEN,"SUMMARY",LNUM)) Q:LNUM="" D
|
||||
. W !,^TMP("PXRMMHVC",$J,RIEN,"SUMMARY",LNUM)
|
||||
Q
|
||||
;
|
||||
|
|
|
|||
|
|
@ -1,284 +1,284 @@
|
|||
PXRMDLG4 ; SLC/PJH - Reminder Dialog Edit/Inquiry ;06/05/2007
|
||||
;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
|
||||
;
|
||||
WP(SUB,SUB1,WIDTH,SEQ,VALMCNT) ;Format WP text
|
||||
N DIWF,DIWL,DIWR,IC,TEXT,X,TXTCNT,DTXT,CNT,SUB2
|
||||
S (CNT,SUB2,TXTCNT)=0
|
||||
F S SUB2=$O(^PXRMD(801.41,SUB,SUB1,SUB2)) Q:'SUB2 D
|
||||
.S TXTCNT=TXTCNT+1,DTXT(TXTCNT)=$G(^PXRMD(801.41,SUB,SUB1,SUB2,0))
|
||||
.S DTXT(TXTCNT)=$$STRREP^PXRMUTIL($G(DTXT(TXTCNT)),"<br>","\\")
|
||||
I TXTCNT>0 D
|
||||
.N OUTPUT,NLINES
|
||||
.S NLINES=0 D FORMAT^PXRMTEXT(1,WIDTH,TXTCNT,.DTXT,.NLINES,.OUTPUT)
|
||||
.I NLINES>0 K DTXT M DTXT=OUTPUT
|
||||
S CNT=0
|
||||
F S CNT=$O(DTXT(CNT)) Q:CNT="" D
|
||||
.S TEXT=$G(DTXT(CNT)),VALMCNT=VALMCNT+1
|
||||
.S ^TMP(NODE,$J,VALMCNT,0)=SEQ_TEXT,SEQ=$J("",$L(SEQ))
|
||||
Q
|
||||
;
|
||||
ADD ;PXRM DIALOG ADD ELEMENT validation
|
||||
N ANS,DTOUT,DUOUT,LIT,LOCK,Y,PIEN,ERR,IEN,NATIONAL,SEQ
|
||||
W IORESET
|
||||
S VALMBCK="R",NATIONAL=0
|
||||
I $P($G(^PXRMD(801.41,PXRMDIEN,100)),U)="N" S NATIONAL=1
|
||||
S LOCK=$P($G(^PXRMD(801.41,PXRMDIEN,100)),U,4)
|
||||
I NATIONAL,'($G(PXRMINST)=1)&(DUZ(0)="@"),$G(LOCK)'=1 D Q
|
||||
.W !,"Elements may not be added to national reminder dialogs" H 2
|
||||
;
|
||||
F D SEQ(.SEQ,.PIEN) Q:$D(DUOUT)!$D(DTOUT) Q:SEQ
|
||||
Q:$D(DUOUT)!$D(DTOUT)
|
||||
;
|
||||
;Check if sequence number is OK
|
||||
I $G(PIEN)="" Q
|
||||
S ANS="N" D ASK^PXRMDLG5(.ANS,PIEN) Q:$D(DUOUT)!$D(DTOUT)!($G(ANS)="N")
|
||||
;
|
||||
;Select a dialog element to add to parent dialog (PIEN)
|
||||
;PIEN may be dialog or a group within the dialog
|
||||
D ESEL^PXRMDEDT(PIEN,SEQ)
|
||||
;Rebuild workfile
|
||||
D BUILD^PXRMDLG(VIEW)
|
||||
Q
|
||||
;
|
||||
FADD(DIEN,FTAB) ;Additional Findings
|
||||
N FIND,FSUB,FTYP,FNAME,FNUM
|
||||
S FSUB=0
|
||||
F S FSUB=$O(^PXRMD(801.41,DIEN,3,FSUB)) Q:'FSUB D
|
||||
.S FIND=$P($G(^PXRMD(801.41,DIEN,3,FSUB,0)),U) Q:FIND=""
|
||||
.S FNAME="" D FDESC(FIND) Q:FNAME=""
|
||||
.;Save additional finding name
|
||||
.S FOUND=1 D FSAVE(2,FNAME,FTYP,FTAB,FIND)
|
||||
Q
|
||||
;
|
||||
DETAIL(DIEN,LEV,VIEW,NODE) ;;Build listman global for all components
|
||||
N DDATA,DDLG,DEND,DCIEN,DNAM,DSEQ,DSTRT,IND,JND,DSUB
|
||||
S DSEQ=0
|
||||
;
|
||||
;Get each sequence number
|
||||
F S DSEQ=$O(^PXRMD(801.41,DIEN,10,"B",DSEQ)) Q:'DSEQ D
|
||||
.;Determine subscript
|
||||
.S DSUB=$O(^PXRMD(801.41,DIEN,10,"B",DSEQ,"")) Q:'DSUB
|
||||
.;Get ien of prompt/component
|
||||
.S DCIEN=$P($G(^PXRMD(801.41,DIEN,10,DSUB,0)),U,2) Q:'DCIEN
|
||||
.I "PF"[$P($G(^PXRMD(801.41,DCIEN,0)),U,4) Q
|
||||
.;Save line in workfile
|
||||
.D DLINE(DCIEN,LEV,DSEQ,NODE)
|
||||
.;Build pointers back to parent
|
||||
.I VIEW'=4 D
|
||||
..S ^TMP("PXRMDLG4",$J,"IEN",NSEL)=DIEN_U_DSEQ
|
||||
..S ^TMP("PXRMDLG4",$J,"SEQ",LEV_DSEQ)=DCIEN
|
||||
.;Process any sub-components
|
||||
.I VIEW<5 D DETAIL(DCIEN,LEV_DSEQ_".",VIEW,NODE)
|
||||
Q
|
||||
;
|
||||
DLINE(DIEN,LEV,DSEQ,NODE) ;Save individual component details
|
||||
N CNT,DBOX,DCAP,DDIS,DMULT,DSUPP,DSHOW,DTYP,DTXT
|
||||
N IC,RESNM,RESULT,RIEN,RNAME,RCNT
|
||||
;Dialog name
|
||||
S DDATA=$G(^PXRMD(801.41,DIEN,0)),DNAM=$P(DDATA,U) Q:DNAM=""
|
||||
;Check if standard PXRM prompt
|
||||
I $$PXRM^PXRMEXID(DNAM) Q
|
||||
;Dialog Type and Disabled
|
||||
S DDIS=$P(DDATA,U,3),DTYP=$P(DDATA,U,4)
|
||||
S DTYP=$S(DTYP="G":"Group",1:"Element"),DNAM=DTYP_": "_DNAM
|
||||
I VIEW=5 S DNAM=DNAM
|
||||
;Resolution type and name
|
||||
S RNAME="",RIEN=$P($G(^PXRMD(801.41,DIEN,1)),U,3)
|
||||
I RIEN S RNAME=$P($G(^PXRMD(801.9,RIEN,0)),U)
|
||||
;
|
||||
;Group fields
|
||||
I DTYP="Group" D
|
||||
.S DGRP=1,DTXT=$P(DDATA,U,5),DCAP=" [group caption]"
|
||||
.I DTXT="" S DCAP=""
|
||||
.I DTXT]"" S DCAP=DTXT_" "_DCAP
|
||||
.S DBOX=$S($P(DDATA,U,6)="Y":"BOX",1:"NO BOX")
|
||||
.S DSUPP=$S($P(DDATA,U,11):"SUPPRESS",1:"NO SUPPRESS")
|
||||
.S DSHOW=$S($P(DDATA,U,10):"HIDE",1:"SHOW")
|
||||
.S DMULT=$P(DDATA,U,9)
|
||||
.S DMULT=$S(DMULT=1:"ONE ONLY",DMULT=2:"ONE OR MORE",DMULT=3:"NONE OR ONE",1:"NO SELECTION")
|
||||
;
|
||||
N DPTX,DTXT,EXIST,ITEM,TEMP,SEP,SEQ,TAB,ALTLEN
|
||||
S NSEL=NSEL+1,NLINE=NLINE+1,ITEM=NSEL,SEP=$E(LEV,$L(LEV)),SEQ=LEV_DSEQ
|
||||
;Suppress Item numbers for INQ options
|
||||
I VIEW=4 S ITEM=""
|
||||
;Otherwise display Item, Sequence and Dialog Name
|
||||
S TEMP=$J(ITEM,4)_$J("",3)_SEQ,TAB=$L(TEMP)+2
|
||||
S CNT=0 F IC=1:1 Q:'$P(SEQ,".",IC) S:$P(SEQ,".",IC)<10 CNT=CNT+1
|
||||
S TAB=TAB+CNT
|
||||
;
|
||||
S ALTLEN=$L(TEMP)
|
||||
;Display dialog name
|
||||
S TEMP=TEMP_$J("",2+CNT)_DNAM
|
||||
;Add disabled if present
|
||||
I DDIS]"" S TEMP=TEMP_" (Disabled)"
|
||||
;
|
||||
S ^TMP(NODE,$J,NLINE,0)=TEMP
|
||||
;check for alternate dialog element/group
|
||||
I VIEW<2!(VIEW>4) D
|
||||
.I $D(^PXRMD(801.41,DIEN,49))>0 D ALT^PXRMDLG5(DIEN,LEV,DSEQ,NODE,VIEW,.NLINE,CNT,ALTLEN)
|
||||
;
|
||||
;Dialog Text or P/N Text
|
||||
I (VIEW=2)!(VIEW=3)!(VIEW=4) D
|
||||
.N DGBEG,DGSUB,TSUB
|
||||
.S DGSUB=0,TSUB=$$TSUB^PXRMDLG1(DIEN,VIEW)
|
||||
.I VIEW=4 S DGBEG=$J("",TAB)_"Text: "
|
||||
.I VIEW'=4 S DGBEG=$J("",5+$L(SEQ)+CNT+$L(DTYP))_"Text: "
|
||||
.D WP(DIEN,TSUB,65,.DGBEG,.NLINE)
|
||||
.I DTYP="Group" D
|
||||
..S TEMP=DGBEG_"["_DBOX_", "_DSUPP_", "_DSHOW_", "_DMULT_"]"
|
||||
..S NLINE=NLINE+1,^TMP(NODE,$J,NLINE,0)=TEMP
|
||||
;
|
||||
;Set up selection index
|
||||
S ^TMP(NODE,$J,"IDX",NSEL,DIEN)=""
|
||||
;Insert finding items
|
||||
I (VIEW=1)!(VIEW=4),("Element;Group"[DTYP) D
|
||||
.N DSUB,FDATA,FILENUM,FLIT,FLONG,FNAME,FOUND,FREP,FTYP,TEMP
|
||||
.;Findings
|
||||
.S FNAME="",FOUND=0
|
||||
.D FDESC($P($G(^PXRMD(801.41,DIEN,1)),U,5))
|
||||
.I FNAME'="" S FOUND=1 D FSAVE(1,FNAME,FTYP,TAB)
|
||||
.;Resolution
|
||||
.I RNAME]"" D
|
||||
..S TEMP=$J("",TAB)_"Resolution: "_RNAME
|
||||
..S NLINE=NLINE+1,^TMP(NODE,$J,NLINE,0)=TEMP
|
||||
.;Result Group
|
||||
.I VIEW=4 D
|
||||
..S RCNT=0 F S RCNT=$O(^PXRMD(801.41,DIEN,51,RCNT)) Q:RCNT'>0 D
|
||||
...S RESULT=$P($G(^PXRMD(801.41,DIEN,51,RCNT,0)),U)
|
||||
...S RESNM=$P($G(^PXRMD(801.41,RESULT,0)),U) Q:RESNM=""
|
||||
...S TEMP=$J("",TAB)_"Result Group: "_RESNM
|
||||
...S NLINE=NLINE+1,^TMP(NODE,$J,NLINE,0)=TEMP
|
||||
.;Additional findings
|
||||
.D FADD(DIEN,TAB)
|
||||
;Get additional prompts
|
||||
I VIEW=2 D
|
||||
.S FIEN=$P($G(^PXRMD(801.41,DIEN,1)),U,5)
|
||||
.I $G(FIEN)["PXD(811.2," D TAX^PXRMDLG1(FIEN,DSEQ,DIEN,.NLINE,NODE)
|
||||
.I $G(FIEN)["ICPT"!($G(FIEN)["ICD9") D FIND^PXRMDLG1(FIEN,DSEQ,DIEN,.NLINE,NODE)
|
||||
.D FADD(DIEN,TAB)
|
||||
I VIEW,VIEW<5,"Element;Group"[DTYP D PROMPT(DIEN,TAB,"Prompts: ",VIEW)
|
||||
;
|
||||
I VIEW=4,$D(^PXRMD(801.41,DIEN,49))>0 D ALT^PXRMDLG5(DIEN,LEV,DSEQ,NODE,VIEW,.NLINE,CNT,ALTLEN)
|
||||
S NLINE=NLINE+1
|
||||
S ^TMP(NODE,$J,NLINE,0)=$J("",79)
|
||||
Q
|
||||
;
|
||||
FDESC(FIEN) ;Finding description
|
||||
N FGLOB,FITEM,FNUM
|
||||
S FGLOB=$P(FIEN,";",2) Q:FGLOB=""
|
||||
S FITEM=$P(FIEN,";") Q:FITEM=""
|
||||
S FNUM=" ["_FITEM_"]"
|
||||
I FGLOB["ICD9" D Q
|
||||
.S FTYP="DIAGNOSIS",FGLOB=U_FGLOB_FITEM_",0)"
|
||||
.S FNAME=$P($G(@FGLOB),U,3)_FNUM
|
||||
I FGLOB["WV" D Q
|
||||
.S FTYP="WH NOTIFICATION PURPOSE",FGLOB=U_FGLOB_FITEM_",0)"
|
||||
.S FNAME=$P($G(@FGLOB),U)_FNUM
|
||||
I FGLOB["ICPT" D Q
|
||||
.S FTYP="PROCEDURE",FGLOB=U_FGLOB_FITEM_",0)"
|
||||
.S FNAME=$P($G(@FGLOB),U,2)_FNUM
|
||||
I FGLOB["ORD(101.41" D Q
|
||||
.S FTYP="QUICK ORDER",FGLOB=U_FGLOB_FITEM_",0)"
|
||||
.S FNAME=$P($G(@FGLOB),U,2)_FNUM
|
||||
;Short name for finding type
|
||||
S FTYP=$G(DEF1(FGLOB)) Q:FTYP=""
|
||||
;Long name
|
||||
S FTYP=$G(DEF2(FTYP))
|
||||
S FGLOB=U_FGLOB_FITEM_",0)"
|
||||
S FNAME=$P($G(@FGLOB),U,1)_FNUM
|
||||
I FNAME="" S FNAME=$P($G(@FGLOB),U)_FNUM
|
||||
I FNAME="" S FNAME=FITEM
|
||||
Q
|
||||
;
|
||||
FSAVE(DSUB,FNAME,FTYP,FTAB,FIEN) ;Save finding details
|
||||
N TEMP
|
||||
I DSUB=1 S FLIT="Finding: "
|
||||
I DSUB>1 S FLIT="Add. Finding: "
|
||||
S FLONG=0
|
||||
;change code to use IOM instead of default length of 60
|
||||
I $L(FLIT_FNAME_" ("_FTYP_")")>(IOM-20) S FLONG=1
|
||||
I 'FLONG S FNAME=FLIT_FNAME_" ("_FTYP_")"
|
||||
I FLONG S FNAME=FLIT_FNAME
|
||||
S TEMP=$J("",FTAB)_$E(FNAME,1,(IOM-20))_$J("",60-$L(FNAME))
|
||||
S NLINE=NLINE+1
|
||||
S ^TMP(NODE,$J,NLINE,0)=TEMP
|
||||
I FLONG S NLINE=NLINE+1,^TMP(NODE,$J,NLINE,0)=$J("",FTAB)_"("_FTYP_")"
|
||||
I VIEW=2 D
|
||||
.I $G(FIEN)["ICPT"!($G(FIEN)["ICD9") D FIND^PXRMDLG1(FIEN,DSEQ,DIEN,.NLINE,NODE)
|
||||
Q
|
||||
;
|
||||
PROMPT(IEN,TAB,TEXT,VIEW) ;additional prompts in the dialog file
|
||||
N DATA,DDIS,DGSEQ,DSUB,DTITLE,DTXT,DTYP,SEQ,SUB
|
||||
S SEQ=0
|
||||
F S SEQ=$O(^PXRMD(801.41,IEN,10,"B",SEQ)) Q:'SEQ D
|
||||
.S SUB=$O(^PXRMD(801.41,IEN,10,"B",SEQ,"")) Q:'SUB
|
||||
.S DSUB=$P($G(^PXRMD(801.41,IEN,10,SUB,0)),U,2) Q:'DSUB
|
||||
.S DATA=$G(^PXRMD(801.41,DSUB,0)) Q:DATA=""
|
||||
.S DNAME=$P(DATA,U),DDIS=$P(DATA,U,3),DTYP=$P(DATA,U,4)
|
||||
.I "PF"'[DTYP Q
|
||||
.I DTYP="F" S DNAME=DNAME_" (forced value)"
|
||||
.I DTYP="P",(VIEW=2)!(VIEW=3) D
|
||||
..;Override prompt caption
|
||||
..S DTITLE=$P($G(^PXRMD(801.41,IEN,10,SUB,0)),U,6)
|
||||
..I DTITLE="" S DTITLE=$P($G(^PXRMD(801.41,DSUB,2)),U,4)
|
||||
..S DNAME=DTITLE
|
||||
.S DNAME=$J("",TAB)_TEXT_DNAME
|
||||
.S:DDIS]"" DNAME=DNAME_" (Disabled)"
|
||||
.S NLINE=NLINE+1
|
||||
.S ^TMP(NODE,$J,NLINE,0)=DNAME
|
||||
.S TEXT=$J("",$L(TEXT))
|
||||
Q
|
||||
;
|
||||
SEQ(SEQ,PIEN) ;Select sequence number to add
|
||||
N X,Y,TEXT,DIR
|
||||
K DIROUT,DIRUT,DTOUT,DUOUT
|
||||
S SEQ=0
|
||||
S DIR(0)="FA0;1;30"
|
||||
S DIR("A")="Enter a new SEQUENCE NUMBER: "
|
||||
S DIR("?")="Enter new sequence number. For detailed help type ??"
|
||||
S DIR("??")=U_"D HELP^PXRMDLG4(1)"
|
||||
D ^DIR K DIR
|
||||
I $D(DIROUT) S DTOUT=1
|
||||
I $D(DTOUT)!($D(DUOUT)) Q
|
||||
;
|
||||
;Check that sequence number is new
|
||||
I $D(^TMP("PXRMDLG4",$J,"SEQ",X)) D Q
|
||||
.W !,"Sequence number "_X_" already in use."
|
||||
;
|
||||
;Then check that the parent is a group or reminder dialog
|
||||
I X["." D Q:X=""
|
||||
.N CLASS,SUB
|
||||
.;Sequence number of parent
|
||||
.S SUB=$P(X,".",1,$L(X,".")-1)
|
||||
.I $G(SUB)=""!($G(SUB)=0) W !,"Invalid sequence number. A sequence number cannot be less then 1" H 2 Q
|
||||
.;Get IEN of parent dialog or group
|
||||
.S PIEN=$G(^TMP("PXRMDLG4",$J,"SEQ",SUB))
|
||||
.;Validate sequence number
|
||||
.I 'PIEN W !,"Sequence number is not part of an existing group." S X="" Q
|
||||
.;Validate that the parent is a group or reminder dialog
|
||||
.I "RG"'[$P($G(^PXRMD(801.41,PIEN,0)),U,4) D S X="" Q
|
||||
..W !,"New sequences can only be added to groups or reminder dialogs"
|
||||
.;Disallow adding elements to national dialogs or groups
|
||||
.I $P($G(^PXMRD(801.41,PIEN,100)),U)="N" D Q:X=""
|
||||
..Q:(DUZ(0)="@")&($G(PXRMINST)=1)
|
||||
..W !,"Elements cannot be added to a national group" S X=""
|
||||
;
|
||||
;If adding to top level parent ien is reminder dialog
|
||||
I X?.N S PIEN=PXRMDIEN
|
||||
;
|
||||
S SEQ=$P(X,".",$L(X,"."))
|
||||
Q
|
||||
;
|
||||
;
|
||||
HELP(CALL) ;General help text routine.
|
||||
N HTEXT
|
||||
N DIWF,DIWL,DIWR,IC
|
||||
S DIWF="C75",DIWL=0,DIWR=75
|
||||
;
|
||||
I CALL=1 D
|
||||
.S HTEXT(1)="Sequence numbers can be added at any level. Specify the full"
|
||||
.S HTEXT(2)="number for the level required (e.g. 15.10.20)."
|
||||
;
|
||||
D HELP^PXRMEUT(.HTEXT)
|
||||
Q
|
||||
;
|
||||
PXRMDLG4 ; SLC/PJH - Reminder Dialog Edit/Inquiry ;10/31/2005
|
||||
;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
|
||||
;
|
||||
WP(SUB,SUB1,WIDTH,SEQ,VALMCNT) ;Format WP text
|
||||
N DIWF,DIWL,DIWR,IC,TEXT,X,TXTCNT,DTXT,CNT,SUB2
|
||||
S (CNT,SUB2,TXTCNT)=0
|
||||
F S SUB2=$O(^PXRMD(801.41,SUB,SUB1,SUB2)) Q:'SUB2 D
|
||||
.S TXTCNT=TXTCNT+1,DTXT(TXTCNT)=$G(^PXRMD(801.41,SUB,SUB1,SUB2,0))
|
||||
.S DTXT(TXTCNT)=$$STRREP^PXRMUTIL($G(DTXT(TXTCNT)),"<br>","\\")
|
||||
I TXTCNT>0 D
|
||||
.N OUTPUT,NLINES
|
||||
.S NLINES=0 D FORMAT^PXRMTEXT(1,WIDTH,TXTCNT,.DTXT,.NLINES,.OUTPUT)
|
||||
.I NLINES>0 K DTXT M DTXT=OUTPUT
|
||||
S CNT=0
|
||||
F S CNT=$O(DTXT(CNT)) Q:CNT="" D
|
||||
.S TEXT=$G(DTXT(CNT)),VALMCNT=VALMCNT+1
|
||||
.S ^TMP(NODE,$J,VALMCNT,0)=SEQ_TEXT,SEQ=$J("",$L(SEQ))
|
||||
Q
|
||||
;
|
||||
ADD ;PXRM DIALOG ADD ELEMENT validation
|
||||
N ANS,DTOUT,DUOUT,LIT,LOCK,Y,PIEN,ERR,IEN,NATIONAL,SEQ
|
||||
W IORESET
|
||||
S VALMBCK="R",NATIONAL=0
|
||||
;Check if national reminder dialog
|
||||
I $P($G(^PXRMD(801.41,PXRMDIEN,100)),U)="N" S NATIONAL=1
|
||||
S LOCK=$P($G(^PXRMD(801.41,PXRMDIEN,100)),U,4)
|
||||
;Dissallow editing of national dialogs
|
||||
I NATIONAL,'($G(PXRMINST)=1)&(DUZ(0)="@"),$G(LOCK)'=1 D Q
|
||||
.W !,"Elements may not be added to national reminder dialogs" H 2
|
||||
;
|
||||
F D SEQ(.SEQ,.PIEN) Q:$D(DUOUT)!$D(DTOUT) Q:SEQ
|
||||
Q:$D(DUOUT)!$D(DTOUT)
|
||||
;
|
||||
;Check if sequence number is OK
|
||||
I $G(PIEN)="" Q
|
||||
S ANS="N" D ASK^PXRMDLG5(.ANS,PIEN) Q:$D(DUOUT)!$D(DTOUT)!($G(ANS)="N")
|
||||
;
|
||||
;Select a dialog element to add to parent dialog (PIEN)
|
||||
;PIEN may be dialog or a group within the dialog
|
||||
D ESEL^PXRMDEDT(PIEN,SEQ)
|
||||
;Rebuild workfile
|
||||
D BUILD^PXRMDLG(VIEW)
|
||||
Q
|
||||
;
|
||||
FADD(DIEN,FTAB) ;Additional Findings
|
||||
N FIND,FSUB,FTYP,FNAME,FNUM
|
||||
S FSUB=0
|
||||
F S FSUB=$O(^PXRMD(801.41,DIEN,3,FSUB)) Q:'FSUB D
|
||||
.S FIND=$P($G(^PXRMD(801.41,DIEN,3,FSUB,0)),U) Q:FIND=""
|
||||
.S FNAME="" D FDESC(FIND) Q:FNAME=""
|
||||
.;Save additional finding name
|
||||
.S FOUND=1 D FSAVE(2,FNAME,FTYP,FTAB,FIND)
|
||||
Q
|
||||
;
|
||||
DETAIL(DIEN,LEV,VIEW,NODE) ;;Build listman global for all components
|
||||
N DDATA,DDLG,DEND,DCIEN,DNAM,DSEQ,DSTRT,IND,JND,DSUB
|
||||
S DSEQ=0
|
||||
;
|
||||
;Get each sequence number
|
||||
F S DSEQ=$O(^PXRMD(801.41,DIEN,10,"B",DSEQ)) Q:'DSEQ D
|
||||
.;Determine subscript
|
||||
.S DSUB=$O(^PXRMD(801.41,DIEN,10,"B",DSEQ,"")) Q:'DSUB
|
||||
.;Get ien of prompt/component
|
||||
.S DCIEN=$P($G(^PXRMD(801.41,DIEN,10,DSUB,0)),U,2) Q:'DCIEN
|
||||
.;Ignore prompts and forced values
|
||||
.I "PF"[$P($G(^PXRMD(801.41,DCIEN,0)),U,4) Q
|
||||
.;Save line in workfile
|
||||
.D DLINE(DCIEN,LEV,DSEQ,NODE)
|
||||
.;Build pointers back to parent
|
||||
.I VIEW'=4 D
|
||||
..S ^TMP("PXRMDLG4",$J,"IEN",NSEL)=DIEN_U_DSEQ
|
||||
..S ^TMP("PXRMDLG4",$J,"SEQ",LEV_DSEQ)=DCIEN
|
||||
.;Process any sub-components
|
||||
.I VIEW<5 D DETAIL(DCIEN,LEV_DSEQ_".",VIEW,NODE)
|
||||
Q
|
||||
;
|
||||
DLINE(DIEN,LEV,DSEQ,NODE) ;Save individual component details
|
||||
N CNT,DBOX,DCAP,DDIS,DMULT,DSUPP,DSHOW,DTYP,DTXT
|
||||
N IC,RESNM,RESULT,RIEN,RNAME
|
||||
;Dialog name
|
||||
S DDATA=$G(^PXRMD(801.41,DIEN,0)),DNAM=$P(DDATA,U) Q:DNAM=""
|
||||
;Check if standard PXRM prompt
|
||||
I $$PXRM^PXRMEXID(DNAM) Q
|
||||
;Dialog Type and Disabled
|
||||
S DDIS=$P(DDATA,U,3),DTYP=$P(DDATA,U,4)
|
||||
S DTYP=$S(DTYP="G":"Group",1:"Element"),DNAM=DTYP_": "_DNAM
|
||||
I VIEW=5 S DNAM=DNAM
|
||||
;Resolution type and name
|
||||
S RNAME="",RIEN=$P($G(^PXRMD(801.41,DIEN,1)),U,3)
|
||||
I RIEN S RNAME=$P($G(^PXRMD(801.9,RIEN,0)),U)
|
||||
;Result Group
|
||||
S RESULT=$P(DDATA,U,15)
|
||||
I RESULT S RESNM=$P($G(^PXRMD(801.41,RESULT,0)),U)
|
||||
;
|
||||
;Group fields
|
||||
I DTYP="Group" D
|
||||
.S DGRP=1,DTXT=$P(DDATA,U,5),DCAP=" [group caption]"
|
||||
.I DTXT="" S DCAP=""
|
||||
.I DTXT]"" S DCAP=DTXT_" "_DCAP
|
||||
.S DBOX=$S($P(DDATA,U,6)="Y":"BOX",1:"NO BOX")
|
||||
.S DSUPP=$S($P(DDATA,U,11):"SUPPRESS",1:"NO SUPPRESS")
|
||||
.S DSHOW=$S($P(DDATA,U,10):"HIDE",1:"SHOW")
|
||||
.S DMULT=$P(DDATA,U,9)
|
||||
.S DMULT=$S(DMULT=1:"ONE ONLY",DMULT=2:"ONE OR MORE",DMULT=3:"NONE OR ONE",1:"NO SELECTION")
|
||||
;
|
||||
N DPTX,DTXT,EXIST,ITEM,TEMP,SEP,SEQ,TAB,ALTLEN
|
||||
S NSEL=NSEL+1,NLINE=NLINE+1,ITEM=NSEL,SEP=$E(LEV,$L(LEV)),SEQ=LEV_DSEQ
|
||||
;Suppress Item numbers for INQ options
|
||||
I VIEW=4 S ITEM=""
|
||||
;Otherwise display Item, Sequence and Dialog Name
|
||||
S TEMP=$J(ITEM,4)_$J("",3)_SEQ,TAB=$L(TEMP)+2
|
||||
S CNT=0 F IC=1:1 Q:'$P(SEQ,".",IC) S:$P(SEQ,".",IC)<10 CNT=CNT+1
|
||||
S TAB=TAB+CNT
|
||||
;
|
||||
S ALTLEN=$L(TEMP)
|
||||
;Display dialog name
|
||||
S TEMP=TEMP_$J("",2+CNT)_DNAM
|
||||
;Add disabled if present
|
||||
I DDIS]"" S TEMP=TEMP_" (Disabled)"
|
||||
;
|
||||
S ^TMP(NODE,$J,NLINE,0)=TEMP
|
||||
;check for alternate dialog element/group
|
||||
I VIEW<2!(VIEW>4) D
|
||||
.I $D(^PXRMD(801.41,DIEN,49))>0 D ALT^PXRMDLG5(DIEN,LEV,DSEQ,NODE,VIEW,.NLINE,CNT,ALTLEN)
|
||||
;
|
||||
;Dialog Text or P/N Text
|
||||
I (VIEW=2)!(VIEW=3)!(VIEW=4) D
|
||||
.N DGBEG,DGSUB,TSUB
|
||||
.S DGSUB=0,TSUB=$$TSUB^PXRMDLG1(DIEN,VIEW)
|
||||
.I VIEW=4 S DGBEG=$J("",TAB)_"Text: "
|
||||
.I VIEW'=4 S DGBEG=$J("",5+$L(SEQ)+CNT+$L(DTYP))_"Text: "
|
||||
.D WP(DIEN,TSUB,65,.DGBEG,.NLINE)
|
||||
.I DTYP="Group" D
|
||||
..S TEMP=DGBEG_"["_DBOX_", "_DSUPP_", "_DSHOW_", "_DMULT_"]"
|
||||
..S NLINE=NLINE+1,^TMP(NODE,$J,NLINE,0)=TEMP
|
||||
;
|
||||
;Set up selection index
|
||||
S ^TMP(NODE,$J,"IDX",NSEL,DIEN)=""
|
||||
;Insert finding items
|
||||
I (VIEW=1)!(VIEW=4),("Element;Group"[DTYP) D
|
||||
.N DSUB,FDATA,FILENUM,FLIT,FLONG,FNAME,FOUND,FREP,FTYP,TEMP
|
||||
.;Findings
|
||||
.S FNAME="",FOUND=0
|
||||
.D FDESC($P($G(^PXRMD(801.41,DIEN,1)),U,5))
|
||||
.I FNAME'="" S FOUND=1 D FSAVE(1,FNAME,FTYP,TAB)
|
||||
.;Resolution
|
||||
.I RNAME]"" D
|
||||
..S TEMP=$J("",TAB)_"Resolution: "_RNAME
|
||||
..S NLINE=NLINE+1,^TMP(NODE,$J,NLINE,0)=TEMP
|
||||
.;Additional findings
|
||||
.D FADD(DIEN,TAB)
|
||||
;Get additional prompts
|
||||
I VIEW=2 D
|
||||
.S FIEN=$P($G(^PXRMD(801.41,DIEN,1)),U,5)
|
||||
.I $G(FIEN)["PXD(811.2," D TAX^PXRMDLG1(FIEN,DSEQ,DIEN,.NLINE,NODE)
|
||||
.I $G(FIEN)["ICPT"!($G(FIEN)["ICD9") D FIND^PXRMDLG1(FIEN,DSEQ,DIEN,.NLINE,NODE)
|
||||
.D FADD(DIEN,TAB)
|
||||
I VIEW,VIEW<5,"Element;Group"[DTYP D PROMPT(DIEN,TAB,"Prompts: ",VIEW)
|
||||
;
|
||||
I VIEW=4,$D(^PXRMD(801.41,DIEN,49))>0 D ALT^PXRMDLG5(DIEN,LEV,DSEQ,NODE,VIEW,.NLINE,CNT,ALTLEN)
|
||||
S NLINE=NLINE+1
|
||||
S ^TMP(NODE,$J,NLINE,0)=$J("",79)
|
||||
Q
|
||||
;
|
||||
FDESC(FIEN) ;Finding description
|
||||
N FGLOB,FITEM,FNUM
|
||||
;Determine finding type
|
||||
S FGLOB=$P(FIEN,";",2) Q:FGLOB=""
|
||||
S FITEM=$P(FIEN,";") Q:FITEM=""
|
||||
S FNUM=" ["_FITEM_"]"
|
||||
I FGLOB["ICD9" D Q
|
||||
.S FTYP="DIAGNOSIS",FGLOB=U_FGLOB_FITEM_",0)"
|
||||
.S FNAME=$P($G(@FGLOB),U,3)_FNUM
|
||||
I FGLOB["WV" D Q
|
||||
.S FTYP="WH NOTIFICATION PURPOSE",FGLOB=U_FGLOB_FITEM_",0)"
|
||||
.S FNAME=$P($G(@FGLOB),U)_FNUM
|
||||
I FGLOB["ICPT" D Q
|
||||
.S FTYP="PROCEDURE",FGLOB=U_FGLOB_FITEM_",0)"
|
||||
.S FNAME=$P($G(@FGLOB),U,2)_FNUM
|
||||
I FGLOB["ORD(101.41" D Q
|
||||
.S FTYP="QUICK ORDER",FGLOB=U_FGLOB_FITEM_",0)"
|
||||
.S FNAME=$P($G(@FGLOB),U,2)_FNUM
|
||||
;Short name for finding type
|
||||
S FTYP=$G(DEF1(FGLOB)) Q:FTYP=""
|
||||
;Long name
|
||||
S FTYP=$G(DEF2(FTYP))
|
||||
S FGLOB=U_FGLOB_FITEM_",0)"
|
||||
S FNAME=$P($G(@FGLOB),U,1)_FNUM
|
||||
I FNAME="" S FNAME=$P($G(@FGLOB),U)_FNUM
|
||||
I FNAME="" S FNAME=FITEM
|
||||
Q
|
||||
;
|
||||
FSAVE(DSUB,FNAME,FTYP,FTAB,FIEN) ;Save finding details
|
||||
N TEMP
|
||||
I DSUB=1 S FLIT="Finding: "
|
||||
I DSUB>1 S FLIT="Add. Finding: "
|
||||
S FLONG=0
|
||||
;change code to use IOM instead of default length of 60
|
||||
I $L(FLIT_FNAME_" ("_FTYP_")")>(IOM-20) S FLONG=1
|
||||
I 'FLONG S FNAME=FLIT_FNAME_" ("_FTYP_")"
|
||||
I FLONG S FNAME=FLIT_FNAME
|
||||
S TEMP=$J("",FTAB)_$E(FNAME,1,(IOM-20))_$J("",60-$L(FNAME))
|
||||
S NLINE=NLINE+1
|
||||
S ^TMP(NODE,$J,NLINE,0)=TEMP
|
||||
I FLONG S NLINE=NLINE+1,^TMP(NODE,$J,NLINE,0)=$J("",FTAB)_"("_FTYP_")"
|
||||
I VIEW=2 D
|
||||
.I $G(FIEN)["ICPT"!($G(FIEN)["ICD9") D FIND^PXRMDLG1(FIEN,DSEQ,DIEN,.NLINE,NODE)
|
||||
Q
|
||||
;
|
||||
PROMPT(IEN,TAB,TEXT,VIEW) ;additional prompts in the dialog file
|
||||
N DATA,DDIS,DGSEQ,DSUB,DTITLE,DTXT,DTYP,SEQ,SUB
|
||||
S SEQ=0
|
||||
F S SEQ=$O(^PXRMD(801.41,IEN,10,"B",SEQ)) Q:'SEQ D
|
||||
.S SUB=$O(^PXRMD(801.41,IEN,10,"B",SEQ,"")) Q:'SUB
|
||||
.S DSUB=$P($G(^PXRMD(801.41,IEN,10,SUB,0)),U,2) Q:'DSUB
|
||||
.S DATA=$G(^PXRMD(801.41,DSUB,0)) Q:DATA=""
|
||||
.S DNAME=$P(DATA,U),DDIS=$P(DATA,U,3),DTYP=$P(DATA,U,4)
|
||||
.I "PF"'[DTYP Q
|
||||
.I DTYP="F" S DNAME=DNAME_" (forced value)"
|
||||
.I DTYP="P",(VIEW=2)!(VIEW=3) D
|
||||
..;Override prompt caption
|
||||
..S DTITLE=$P($G(^PXRMD(801.41,IEN,10,SUB,0)),U,6)
|
||||
..I DTITLE="" S DTITLE=$P($G(^PXRMD(801.41,DSUB,2)),U,4)
|
||||
..S DNAME=DTITLE
|
||||
.S DNAME=$J("",TAB)_TEXT_DNAME
|
||||
.S:DDIS]"" DNAME=DNAME_" (Disabled)"
|
||||
.S NLINE=NLINE+1
|
||||
.S ^TMP(NODE,$J,NLINE,0)=DNAME
|
||||
.S TEXT=$J("",$L(TEXT))
|
||||
Q
|
||||
;
|
||||
SEQ(SEQ,PIEN) ;Select sequence number to add
|
||||
N X,Y,TEXT,DIR
|
||||
K DIROUT,DIRUT,DTOUT,DUOUT
|
||||
S SEQ=0
|
||||
S DIR(0)="FA0;1;30"
|
||||
S DIR("A")="Enter a new SEQUENCE NUMBER: "
|
||||
S DIR("?")="Enter new sequence number. For detailed help type ??"
|
||||
S DIR("??")=U_"D HELP^PXRMDLG4(1)"
|
||||
D ^DIR K DIR
|
||||
I $D(DIROUT) S DTOUT=1
|
||||
I $D(DTOUT)!($D(DUOUT)) Q
|
||||
;
|
||||
;Check that sequence number is new
|
||||
I $D(^TMP("PXRMDLG4",$J,"SEQ",X)) D Q
|
||||
.W !,"Sequence number "_X_" already in use."
|
||||
;
|
||||
;Then check that the parent is a group or reminder dialog
|
||||
I X["." D Q:X=""
|
||||
.N CLASS,SUB
|
||||
.;Sequence number of parent
|
||||
.S SUB=$P(X,".",1,$L(X,".")-1)
|
||||
.I $G(SUB)=""!($G(SUB)=0) W !,"Invalid sequence number. A sequence number cannot be less then 1" H 2 Q
|
||||
.;Get IEN of parent dialog or group
|
||||
.S PIEN=$G(^TMP("PXRMDLG4",$J,"SEQ",SUB))
|
||||
.;Validate sequence number
|
||||
.I 'PIEN W !,"Sequence number is not part of an existing group." S X="" Q
|
||||
.;Validate that the parent is a group or reminder dialog
|
||||
.I "RG"'[$P($G(^PXRMD(801.41,PIEN,0)),U,4) D S X="" Q
|
||||
..W !,"New sequences can only be added to groups or reminder dialogs"
|
||||
.;Disallow adding elements to national dialogs or groups
|
||||
.I $P($G(^PXMRD(801.41,PIEN,100)),U)="N" D Q:X=""
|
||||
..Q:(DUZ(0)="@")&($G(PXRMINST)=1)
|
||||
..W !,"Elements cannot be added to a national group" S X=""
|
||||
;
|
||||
;If adding to top level parent ien is reminder dialog
|
||||
I X?.N S PIEN=PXRMDIEN
|
||||
;
|
||||
S SEQ=$P(X,".",$L(X,"."))
|
||||
Q
|
||||
;
|
||||
;
|
||||
HELP(CALL) ;General help text routine.
|
||||
N HTEXT
|
||||
N DIWF,DIWL,DIWR,IC
|
||||
S DIWF="C75",DIWL=0,DIWR=75
|
||||
;
|
||||
I CALL=1 D
|
||||
.S HTEXT(1)="Sequence numbers can be added at any level. Specify the full"
|
||||
.S HTEXT(2)="number for the level required (e.g. 15.10.20)."
|
||||
;
|
||||
D HELP^PXRMEUT(.HTEXT)
|
||||
Q
|
||||
;
|
||||
|
|
|
|||
|
|
@ -1,222 +1,120 @@
|
|||
PXRMDLG5 ; SLC/PJH - Reminder Dialog Edit/Inquiry ;11/08/2007
|
||||
;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
|
||||
;
|
||||
ALT(DIEN,LEV,DSEQ,NODE,VIEW,NLINE,CNT,ALTLEN) ;
|
||||
;Display branching logic text in dialog summary view
|
||||
N DATA,DNAM,DTYP,IEN,TERM,TNAME,TSTAT,TEMP
|
||||
S DATA=$G(^PXRMD(801.41,DIEN,49))
|
||||
I '+$P(DATA,U)!($P($G(DATA),U,2)="") Q
|
||||
S TNAME=$P($G(^PXRMD(811.5,$P(DATA,U),0)),U)
|
||||
S TSTAT=$S($P(DATA,U,2)="1":"TRUE",1:"FALSE")
|
||||
I +$P(DATA,U,3)>0 D
|
||||
.S IEN=$P(DATA,U,3),DNAM=$P($G(^PXRMD(801.41,IEN,0)),U)
|
||||
.S DTYP=$S($P($G(^PXRMD(801.41,IEN,0)),U,4)="E":"Element",$P($G(^PXRMD(801.41,IEN,0)),U,4)="G":"Group")
|
||||
I $G(DNAM)="" S TEMP="Suppressed if Reminder Term "_TNAME_" evaluates as "_TSTAT
|
||||
I $G(DNAM)'="" S TEMP="Replaced by "_DNAM_" if Reminder Term "_TNAME_" evaluates as "_TSTAT
|
||||
D TEXT(.NLINES,CNT,ALTLEN,TEMP,NODE)
|
||||
Q
|
||||
;
|
||||
ASK(YESNO,PIEN) ;Confirm
|
||||
K DIR,DIROUT,DIRUT,DNAME,DTOUT,DTYP,DUOUT,TEXT,X,Y
|
||||
N DDATA,DNAME,DTYP
|
||||
S DDATA=$G(^PXRMD(801.41,PIEN,0))
|
||||
;Parent name and type
|
||||
S DNAME=$P(DDATA,U),DTYP=$P(DDATA,U,4)
|
||||
;
|
||||
S DIR(0)="YA0"
|
||||
S DIR("A")="Add sequence "_SEQ_" to "
|
||||
I DTYP="G" S DIR("A")=DIR("A")_"group "_DNAME_": "
|
||||
E S DIR("A")=DIR("A")_"reminder dialog ?: "
|
||||
S DIR("B")="N",DIR("?")="Enter Y or N. For detailed help type ??"
|
||||
S DIR("??")=U_"D XHLP^PXRMDLG(1)"
|
||||
D ^DIR K DIR
|
||||
I $D(DIROUT) S DTOUT=1
|
||||
I $D(DTOUT)!($D(DUOUT)) Q
|
||||
S YESNO=$E(Y(0)) I YESNO'="Y" S DUOUT=1
|
||||
S VALMBCK="R"
|
||||
Q
|
||||
;
|
||||
BHELP(VALUE) ;
|
||||
N HTEXT
|
||||
D FULL^VALM1
|
||||
;Help text for Reminder Dialog Branching logic
|
||||
I VALUE=1 D
|
||||
.;Reminder Term field
|
||||
.S HTEXT(1)="Enter a reminder term that will be used to determine if the reminder"
|
||||
.S HTEXT(2)="element/group should be replaced or suppressed if the reminder term evaluation"
|
||||
.S HTEXT(3)="matches the value in the Reminder Term Status field."
|
||||
I VALUE=2 D
|
||||
.;Reminder Term Status field
|
||||
.S HTEXT(1)="Enter either 1 for true or 0 for false. This value will be used with the"
|
||||
.S HTEXT(2)="reminder term field to determine if this item should be replaced with a"
|
||||
.S HTEXT(3)="different element/group defined in the Replacement Element/Group field, or if"
|
||||
.S HTEXT(4)="this item should be suppressed."
|
||||
I VALUE=3 D
|
||||
.;Replacement Element/Group field
|
||||
.S HTEXT(1)="Enter an element/group that will be used as a replacement to thisitem, or"
|
||||
.S HTEXT(2)="leave this field blank to suppress this item if the term evaluation"
|
||||
.S HTEXT(3)="matches the value defined in the term status field. "
|
||||
I VALUE=4 D
|
||||
.;Patient Specific field
|
||||
.S HTEXT(1)="Enter either 1 for true or 0 for false. This value must be set to true"
|
||||
.S HTEXT(2)="if item in this dialog will be using reminder term to either replace an item"
|
||||
.S HTEXT(3)="or to suppress an item."
|
||||
D HELP^PXRMEUT(.HTEXT)
|
||||
Q
|
||||
;
|
||||
INQ(DIEN) ;INQ Inquiry/Print option
|
||||
; Used by 801.41 print templates
|
||||
; [PXRM REMINDER DIALOG]
|
||||
; [PXRM DIALOG GROUP]
|
||||
;
|
||||
N DEF,DEF1,DEF2 D DEF^PXRMRUTL("811.902",.DEF,.DEF1,.DEF2)
|
||||
N NLINE,NODE,NSEL,SUB
|
||||
S NLINE=0,NODE="PXRMDLG4",NSEL=0
|
||||
K ^TMP(NODE,$J)
|
||||
;
|
||||
;Components
|
||||
W !!," Seq. Dialog",!
|
||||
D DETAIL^PXRMDLG4(DIEN,"",4,NODE)
|
||||
;
|
||||
;Print lines from workfile
|
||||
S SUB=""
|
||||
F S SUB=$O(^TMP(NODE,$J,SUB)) Q:'SUB W !,^TMP(NODE,$J,SUB,0)
|
||||
K ^TMP(NODE,$J)
|
||||
Q
|
||||
;
|
||||
MH(IEN) ;Allow IEN=109 (HX2) as a place holder for 601 entries that do not
|
||||
;have a corresponding 601.71 entry.
|
||||
I IEN=109 Q 1
|
||||
I $G(PXRMINST)=1 Q 1
|
||||
N MAXNUM
|
||||
S MAXNUM=+$P($G(^PXRM(800,1,"MH")),U)
|
||||
I MAXNUM=0 S MAXNUM=25
|
||||
Q $$ONECR^YTQPXRM5(IEN,MAXNUM)
|
||||
;
|
||||
MHLICR(IEN) ;Called by input template PXRM EDIT ELEMENT. Preserve Y so template
|
||||
;branching works.
|
||||
N Y
|
||||
;DBIA #5042
|
||||
I $$RL^YTQPXRM3(IEN)="Y" D
|
||||
.W !,"This MH test requires a license."
|
||||
.W !,"The question text will not appear in the progress note.",!
|
||||
.H 1
|
||||
Q
|
||||
;
|
||||
MSEL(NUM) ;
|
||||
I NUM=4,'$$PATCH^XPDUTL("OR*3.0*243") D EN^DDIOL("THIS SELECTION IS NOT VALID, UNTIL CPRS 27 IS INSTALLED") Q 0
|
||||
Q 1
|
||||
;
|
||||
MHREQHLP ;
|
||||
N TEXT
|
||||
S TEXT(1)="Select 0, ""Optional open and optional complete (partial complete possible)"","
|
||||
S TEXT(2)="if the user should be able to optionally select/open the MH test in the reminder dialog and optionally complete the MH test before the reminder dialog can be finished."
|
||||
S TEXT(3)=" "
|
||||
S TEXT(4)="Select 1, ""Required open and required complete before finish"","
|
||||
S TEXT(5)="if the user is required to select/open and complete the MH test in the reminder dialog before the reminder dialog can be finished."
|
||||
S TEXT(6)=" "
|
||||
S TEXT(7)="Select 2, ""Optional open and required complete or cancel before finish"","
|
||||
S TEXT(8)="if the user should be able to optionally select/open the MH test in the reminder dialog; however, if the user opens the MH test, then the user is required to complete or cancel the MH test before the reminder dialog can be finished."
|
||||
S TEXT(9)=" "
|
||||
S TEXT(10)="Note: Clicking the cancel button in the MH Test is considered the same as not opening the MH Test."
|
||||
S TEXT(11)="Also, Option 2, ""Optional open and required complete or cancel before finish"", only works with CPRS 27 and"
|
||||
S TEXT(12)="YS_MHA.dll. If Option 2 is selected and the user is using a pre-CPRS 27 version this option will be treated by CPRS as Option 1, ""Required open and required complete before finish""."
|
||||
D HELP^PXRMEUT(.TEXT)
|
||||
Q
|
||||
;
|
||||
NTERM(DA,OTERM,NTERM) ;
|
||||
I +OTERM=0 S OTERM=$P($G(DA),U)
|
||||
I +NTERM=0 K OTERM Q 2
|
||||
I +OTERM=0,+NTERM>0 K OTERM Q 1
|
||||
I +OTERM'=+NTERM K OTERM Q 0
|
||||
K OTERM
|
||||
Q 1
|
||||
;
|
||||
OTERM(DA) ;
|
||||
K OTERM
|
||||
S OTERM=$P($G(^PXRMD(801.41,DA,49)),U)
|
||||
Q
|
||||
;
|
||||
RESCHK(IEN) ;Called by input template PXRM EDIT ELEMENT. Preserve Y so template
|
||||
;branching works.
|
||||
N CNT,FDA,MSG,RG,RGIEN,VALID,Y
|
||||
S CNT=0
|
||||
F S CNT=$O(^PXRMD(801.41,IEN,51,CNT)) Q:CNT'>0 D
|
||||
.S RGIEN=$P($G(^PXRMD(801.41,IEN,51,CNT,0)),U) I +RGIEN'>0 Q
|
||||
.S RG=$P($G(^PXRMD(801.41,RGIEN,0)),U,1)
|
||||
.I RG="" Q
|
||||
.S VALID=$$RGLSCR(IEN,RG,RGIEN)
|
||||
.I VALID Q
|
||||
.W !,"Deleting the result group ",RG," from the element/group."
|
||||
.S FDA(801.41121,CNT_","_IEN_",",.01)="@"
|
||||
.D FILE^DIE("E","FDA","MSG")
|
||||
.S RGKILL=1
|
||||
.I $D(MSG) D AWRITE^PXRMUTIL("MSG")
|
||||
Q
|
||||
;
|
||||
RSELEDIT(DA) ;
|
||||
N NODE,RESULT
|
||||
;RESULT=0 EDIT NOTHING
|
||||
;RESULT=1 EDIT INFORMATIONAL TEXT
|
||||
;RESULT=2 EDIT EVERYTHING
|
||||
S RESULT=2
|
||||
I $G(PXRMINST)=1,DUZ(0)="@" Q RESULT
|
||||
S NODE=$G(^PXRMD(801.41,DA,100))
|
||||
I $P(NODE,U)="N" S RESULT=0
|
||||
I RESULT=0,+$P(NODE,U,4)=0 S RESULT=1
|
||||
Q RESULT
|
||||
;
|
||||
RGLSCR(DA,X,IEN) ;Input transform/screen for RESULT GROUP LIST
|
||||
I $G(PXRMINST)=1 Q 1
|
||||
I $G(PXRMEXCH)=1 Q 1
|
||||
N HELP,MHTEST,TEXT,VALID,Y
|
||||
S NMATCH=0
|
||||
S MHTEST=$O(^PXRMD(801.41,"B",X),-1)
|
||||
F S MHTEST=$O(^PXRMD(801.41,"B",MHTEST)) Q:(NMATCH>1)!(MHTEST'[X) S NMATCH=NMATCH+1
|
||||
;If there is an exact match to the user's input turn help on.
|
||||
S HELP=$S($G(DIQUIET):0,NMATCH=1:1,1:0)
|
||||
S VALID=1
|
||||
;Make sure the TYPE is a result group
|
||||
I '$D(^PXRMD(801.41,"TYPE","S",IEN)) D
|
||||
. I HELP S TEXT(1)="TYPE must be a result group."
|
||||
. S VALID=0
|
||||
;Make sure the finding item for the element matches the
|
||||
;MH Test assigned to the Result Group
|
||||
S MHTEST=+$P($G(^PXRMD(801.41,DA,1)),U,5) I MHTEST="" D
|
||||
. I HELP S TEXT(2)="The MH test is missing."
|
||||
. S VALID=0
|
||||
I +$P($G(^PXRMD(801.41,IEN,50)),U)'=MHTEST D
|
||||
. I HELP S TEXT(3)="The finding item does not match the MH Test assigned to the Result Group"
|
||||
. S VALID=0
|
||||
;Make sure a scale has been defined.
|
||||
I +$P($G(^PXRMD(801.41,IEN,50)),U,2)'>0 D
|
||||
. I HELP S TEXT(4)="An MH Scale must be defined."
|
||||
. S VALID=0
|
||||
;Make sure it is not disabled.
|
||||
I $P($G(^PXRMD(801.41,IEN,0)),U,3)'="" D
|
||||
. S VALID=0
|
||||
. I HELP D
|
||||
.. N EM,TYPE
|
||||
.. S TYPE=$P(^PXRMD(801.41,IEN,0),U,4)
|
||||
.. S TYPE=$$EXTERNAL^DILFD(801.41,4,"",TYPE,.EM)
|
||||
.. S TEXT(5)="The "_TYPE_" is disabled."
|
||||
I HELP,'VALID D EN^DDIOL(.TEXT)
|
||||
Q VALID
|
||||
;
|
||||
TERMS(DA,X) ;
|
||||
N TERM
|
||||
S TERM=$P($G(^PXRMD(801.41,DA,49)),U)
|
||||
I +TERM=0 D Q 0
|
||||
.W !,"Cannot set Reminder Term Status if the Reminder Term field is blank"
|
||||
.H 2
|
||||
I +TERM>0,$G(X)="" Q 2
|
||||
Q 1
|
||||
;
|
||||
TEXT(NLINES,CNT,ATLEN,TEMP,NODE) ;
|
||||
N CNT1,NOUT,OUTPUT,WIDHT
|
||||
S WIDTH=IOM-(2+(CNT+ATLEN))
|
||||
S CNT1=1 D FORMATS^PXRMTEXT(1,WIDTH,TEMP,.NOUT,.OUTPUT)
|
||||
I NOUT>0 F CNT1=1:1:NOUT D
|
||||
.S NLINE=NLINE+1,^TMP(NODE,$J,NLINE,0)=$J("",2+(CNT+ATLEN))_OUTPUT(CNT1)
|
||||
Q
|
||||
;
|
||||
PXRMDLG5 ; SLC/PJH - Reminder Dialog Edit/Inquiry ;05/17/2006
|
||||
;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
|
||||
;
|
||||
;
|
||||
ASK(YESNO,PIEN) ;Confirm
|
||||
K DIR,DIROUT,DIRUT,DNAME,DTOUT,DTYP,DUOUT,TEXT,X,Y
|
||||
N DDATA,DNAME,DTYP
|
||||
S DDATA=$G(^PXRMD(801.41,PIEN,0))
|
||||
;Parent name and type
|
||||
S DNAME=$P(DDATA,U),DTYP=$P(DDATA,U,4)
|
||||
;
|
||||
S DIR(0)="YA0"
|
||||
S DIR("A")="Add sequence "_SEQ_" to "
|
||||
I DTYP="G" S DIR("A")=DIR("A")_"group "_DNAME_": "
|
||||
E S DIR("A")=DIR("A")_"reminder dialog ?: "
|
||||
S DIR("B")="N",DIR("?")="Enter Y or N. For detailed help type ??"
|
||||
S DIR("??")=U_"D XHLP^PXRMDLG(1)"
|
||||
D ^DIR K DIR
|
||||
I $D(DIROUT) S DTOUT=1
|
||||
I $D(DTOUT)!($D(DUOUT)) Q
|
||||
S YESNO=$E(Y(0)) I YESNO'="Y" S DUOUT=1
|
||||
S VALMBCK="R"
|
||||
Q
|
||||
;
|
||||
MSEL(NUM) ;
|
||||
I NUM=4,'$$PATCH^XPDUTL("OR*3.0*243") D EN^DDIOL("THIS SELECTION IS NOT VALID, UNTIL CPRS 27 IS INSTALLED") Q 0
|
||||
Q 1
|
||||
;
|
||||
ALT(DIEN,LEV,DSEQ,NODE,VIEW,NLINE,CNT,ALTLEN) ;
|
||||
;Display branching logic text in dialog summary view
|
||||
N DATA,DNAM,DTYP,IEN,TERM,TNAME,TSTAT,TEMP
|
||||
S DATA=$G(^PXRMD(801.41,DIEN,49))
|
||||
I '+$P(DATA,U)!($P($G(DATA),U,2)="") Q
|
||||
S TNAME=$P($G(^PXRMD(811.5,$P(DATA,U),0)),U)
|
||||
S TSTAT=$S($P(DATA,U,2)="1":"TRUE",1:"FALSE")
|
||||
I +$P(DATA,U,3)>0 D
|
||||
.S IEN=$P(DATA,U,3),DNAM=$P($G(^PXRMD(801.41,IEN,0)),U)
|
||||
.S DTYP=$S($P($G(^PXRMD(801.41,IEN,0)),U,4)="E":"Element",$P($G(^PXRMD(801.41,IEN,0)),U,4)="G":"Group")
|
||||
I $G(DNAM)="" S TEMP="Suppressed if Reminder Term "_TNAME_" evaluates as "_TSTAT
|
||||
I $G(DNAM)'="" S TEMP="Replaced by "_DNAM_" if Reminder Term "_TNAME_" evaluates as "_TSTAT
|
||||
D TEXT(.NLINES,CNT,ALTLEN,TEMP,NODE)
|
||||
Q
|
||||
;
|
||||
OTERM(DA) ;
|
||||
K OTERM
|
||||
S OTERM=$P($G(^PXRMD(801.41,DA,49)),U) Q
|
||||
;
|
||||
NTERM(DA,OTERM,NTERM) ;
|
||||
I +OTERM=0 S OTERM=$P($G(DA),U)
|
||||
I +NTERM=0 K OTERM Q 2
|
||||
I +OTERM=0,+NTERM>0 K OTERM Q 1
|
||||
I +OTERM'=+NTERM K OTERM Q 0
|
||||
K OTERM
|
||||
Q 1
|
||||
;
|
||||
TERMS(DA,X) ;
|
||||
N TERM
|
||||
S TERM=$P($G(^PXRMD(801.41,DA,49)),U)
|
||||
I +TERM=0 D Q 0
|
||||
.W !,"Cannot set Reminder Term Status if the Reminder Term field is blank"
|
||||
.H 2
|
||||
I +TERM>0,$G(X)="" Q 2
|
||||
Q 1
|
||||
;
|
||||
BHELP(VALUE) ;
|
||||
N HTEXT
|
||||
D FULL^VALM1
|
||||
;Help text for Reminder Dialog Branching logic
|
||||
I VALUE=1 D
|
||||
.;Reminder Term field
|
||||
.S HTEXT(1)="Enter a reminder term that will be used to determine if the reminder"
|
||||
.S HTEXT(2)="element/group should be replaced or suppressed if the reminder term evaluation"
|
||||
.S HTEXT(3)="matches the value in the Reminder Term Status field."
|
||||
I VALUE=2 D
|
||||
.;Reminder Term Status field
|
||||
.S HTEXT(1)="Enter either 1 for true or 0 for false. This value will be used with the"
|
||||
.S HTEXT(2)="reminder term field to determine if this item should be replaced with a"
|
||||
.S HTEXT(3)="different element/group defined in the Replacement Element/Group field, or if"
|
||||
.S HTEXT(4)="this item should be suppressed."
|
||||
I VALUE=3 D
|
||||
.;Replacement Element/Group field
|
||||
.S HTEXT(1)="Enter an element/group that will be used as a replacement to thisitem, or"
|
||||
.S HTEXT(2)="leave this field blank to suppress this item if the term evaluation"
|
||||
.S HTEXT(3)="matches the value defined in the term status field. "
|
||||
I VALUE=4 D
|
||||
.;Patient Specific field
|
||||
.S HTEXT(1)="Enter either 1 for true or 0 for false. This value must be set totrue"
|
||||
.S HTEXT(2)="if item in this dialog will be using reminder term to either replace an item"
|
||||
.S HTEXT(3)="or to suppress an item."
|
||||
D HELP^PXRMEUT(.HTEXT)
|
||||
Q
|
||||
;
|
||||
TEXT(NLINES,CNT,ATLEN,TEMP,NODE) ;
|
||||
N CNT1,NOUT,OUTPUT,WIDHT
|
||||
S WIDTH=IOM-(2+(CNT+ATLEN))
|
||||
S CNT1=1 D FORMATS^PXRMTEXT(1,WIDTH,TEMP,.NOUT,.OUTPUT)
|
||||
I NOUT>0 F CNT1=1:1:NOUT D
|
||||
.S NLINE=NLINE+1,^TMP(NODE,$J,NLINE,0)=$J("",2+(CNT+ATLEN))_OUTPUT(CNT1)
|
||||
Q
|
||||
;
|
||||
INQ(DIEN) ;INQ Inquiry/Print option
|
||||
;
|
||||
; Used by 801.41 print templates
|
||||
; [PXRM REMINDER DIALOG]
|
||||
; [PXRM DIALOG GROUP]
|
||||
;
|
||||
N DEF,DEF1,DEF2 D DEF^PXRMRUTL("811.902",.DEF,.DEF1,.DEF2)
|
||||
N NLINE,NODE,NSEL,SUB
|
||||
S NLINE=0,NODE="PXRMDLG4",NSEL=0
|
||||
K ^TMP(NODE,$J)
|
||||
;
|
||||
;Components
|
||||
W !!," Seq. Dialog",!
|
||||
D DETAIL^PXRMDLG4(DIEN,"",4,NODE)
|
||||
;
|
||||
;Print lines from workfile
|
||||
S SUB=""
|
||||
F S SUB=$O(^TMP(NODE,$J,SUB)) Q:'SUB W !,^TMP(NODE,$J,SUB,0)
|
||||
K ^TMP(NODE,$J)
|
||||
Q
|
||||
|
|
|
|||
|
|
@ -1,234 +1,238 @@
|
|||
PXRMDLGZ ; SLC/PJH - Link reminder to dialog. ;01/11/2007
|
||||
;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
|
||||
;
|
||||
;Called by option PXRM DIALOG/COMPONENT EDIT
|
||||
;
|
||||
START N BY,DATA,DDES,DHD,DIC,DNAM,DTYP,FLDS,FR,L,LOGIC,NOW,PNAM,TO,Y
|
||||
N PXRMBG,PXRMHD,PXRMDIEN,PXRMGTYP,PXRMDTYP,PXRMITEM,PXRMMODE,PXRMNAME
|
||||
N PXRMTEMP,PXRMTITL,PXRMVIEW
|
||||
;Refresh on return
|
||||
S VALMBCK="R"
|
||||
S VALMSG="+ Next Screen - Prev Screen ?? More Actions"
|
||||
;Default is display dialog elements
|
||||
S PXRMDTYP="R",PXRMGTYP="DLGR",PXRMVIEW="AN"
|
||||
;Select dialog for display
|
||||
F D Q:'PXRMTEMP
|
||||
.S PXRMTEMP=""
|
||||
.D START^PXRMSEL(.PXRMHD,.PXRMGTYP,"PXRMTEMP") Q:'PXRMTEMP
|
||||
.N X S X="IORESET"
|
||||
.D ENDR^%ZISS,@(PXRMGTYP_"("_PXRMTEMP_")")
|
||||
END Q
|
||||
;
|
||||
;Reminder View
|
||||
;-------------
|
||||
DLGR(PXRMITEM) ;
|
||||
N PXRMDIEN,PXRMCS1,PXRMCS2
|
||||
;Format headings to include reminder and name
|
||||
S DATA=$G(^PXD(811.9,PXRMITEM,0)),RNAM=$P(DATA,U),PNAM=$P(DATA,U,3)
|
||||
S PXRMHD="REMINDER NAME: "_RNAM
|
||||
;
|
||||
;Dialog History
|
||||
F D Q:'PXRMDIEN
|
||||
.D START^PXRMDLGH(PXRMITEM,.PXRMDIEN,"PXRMDIEN") Q:'PXRMDIEN
|
||||
.N PXRMHD,VALMBCK,VALMBG,VALMSG,VIEW,X,XMZ
|
||||
.S DNAM=$P($G(^PXRMD(801.41,PXRMDIEN,0)),U)
|
||||
.I $P($G(^PXRMD(801.41,PXRMDIEN,0)),U,3)]"" S DNAM=DNAM_" (DISABLED)"
|
||||
.S PXRMHD="REMINDER DIALOG NAME: "_DNAM
|
||||
.S PXRMCS1=$$FILE^PXRMEXCS(801.41,PXRMDIEN)
|
||||
.S X="IORESET"
|
||||
.D ENDR^%ZISS,EN^VALM("PXRM DIALOG LIST")
|
||||
.I PXRMDIEN,$D(^PXRMD(801.41,PXRMDIEN,0)) D
|
||||
..S PXRMCS2=$$FILE^PXRMEXCS(801.41,PXRMDIEN) Q:+PXRMCS2=0
|
||||
..Q:PXRMCS1=PXRMCS2
|
||||
..D SEHIST^PXRMUTIL(801.41,"^PXRMD(801,41,",PXRMDIEN)
|
||||
.W IORESET
|
||||
.D KILL^%ZISS
|
||||
Q
|
||||
;
|
||||
;Edit element/prompt/group
|
||||
;-------------------------
|
||||
DLGE(PXRMDIEN) ;
|
||||
N LOCK,LFIND
|
||||
;Check for Uneditable flag
|
||||
S LOCK=$P($G(^PXRMD(801.41,PXRMTEMP,100)),U,4)
|
||||
S LFIND=$P($G(^PXRMD(801.41,PXRMTEMP,1)),U,5)
|
||||
I LOCK=1,$G(LFIND)'="",$G(LFIND)'["ORD",'$G(PXRMINST) D Q
|
||||
.W !,"This item can not be edited" H 2
|
||||
;
|
||||
S PXRMHD="Dialog Name: ",PXRMDIEN=PXRMTEMP
|
||||
;Format headings to include dialog name
|
||||
S DATA=$G(^PXRMD(801.41,PXRMDIEN,0)),DDES=$P(DATA,U),DTYP=$P(DATA,U,4)
|
||||
;Test
|
||||
I DTYP="G" D DLG(PXRMDIEN) Q
|
||||
;
|
||||
S PXRMHD=PXRMHD_" "_DDES W PXRMHD,!
|
||||
;Edit selected dialog
|
||||
D EDIT^PXRMDEDT(DTYP,PXRMDIEN,0)
|
||||
Q
|
||||
;
|
||||
;Reminder dialog view
|
||||
;--------------------
|
||||
DLG(PXRMDIEN) ;
|
||||
S PXRMDIEN=PXRMTEMP
|
||||
S PXRMNAME=$P($G(^PXRMD(801.41,PXRMDIEN,0)),U)
|
||||
S PXRMITEM=$P($G(^PXRMD(801.41,PXRMDIEN,0)),U,2)
|
||||
;Format headings to include dialog name
|
||||
S PXRMHD=PXRMHD_PXRMNAME
|
||||
;Check if the set is disable and add to header if disabled
|
||||
I $P(^PXRMD(801.41,PXRMDIEN,0),U,3)]"" S PXRMHD=PXRMHD_" (DISABLED)"
|
||||
;Listman option
|
||||
D EN^VALM("PXRM DIALOG LIST")
|
||||
W IORESET
|
||||
D KILL^%ZISS
|
||||
Q
|
||||
;
|
||||
;Other subroutines
|
||||
;
|
||||
;Ask update or no
|
||||
;----------------
|
||||
ASK(YESNO) ;
|
||||
N X,Y,TEXT,DIR
|
||||
K DIROUT,DIRUT,DTOUT,DUOUT
|
||||
S DIR(0)="YA0"
|
||||
S DIR("A")="LINK THIS REMINDER TO DIALOG - "_$P(PXRMHD,": ",2)_": "
|
||||
S DIR("B")="Y"
|
||||
S DIR("?")="Enter Y or N. For detailed help type ??"
|
||||
S DIR("??")=U_"D HLP^PXRMDLGY(1)"
|
||||
D ^DIR K DIR
|
||||
I $D(DIROUT) S DTOUT=1
|
||||
I $D(DTOUT)!($D(DUOUT)) Q
|
||||
S YESNO=$E(Y(0))
|
||||
Q
|
||||
;
|
||||
;Display dialogs autogenerated from this reminder
|
||||
;------------------------------------------------
|
||||
DISP(RIEN) ;
|
||||
N ARRAY,DSUB,FIRST
|
||||
;Get OTHER dialogs
|
||||
S FIRST=1,DSUB=""
|
||||
F S DSUB=$O(^PXRMD(801.41,"AG",RIEN,DSUB)) Q:'DSUB D
|
||||
.W !
|
||||
.D:FIRST
|
||||
..W "DIALOGS ALREADY GENERATED FROM THIS REMINDER:",!! S FIRST=0
|
||||
.W ?20,$P($G(^PXRMD(801.41,DSUB,0)),U)
|
||||
;
|
||||
I 'FIRST W !
|
||||
;
|
||||
Q
|
||||
;
|
||||
;Display linked reminders
|
||||
;------------------------
|
||||
DISPL(DIEN) ;
|
||||
N ARRAY,DLG,RSUB,FIRST,RNAM
|
||||
S RSUB=$P($G(^PXRMD(801.41,DIEN,0)),U,2)
|
||||
I RSUB W !!,"SOURCE REMINDER: "_$P($G(^PXD(811.9,RSUB,0)),U)
|
||||
;Linked reminders
|
||||
S FIRST=1,RNAM=""
|
||||
F S RNAM=$O(^PXD(811.9,"B",RNAM)) Q:RNAM="" D
|
||||
.S RSUB=$O(^PXD(811.9,"B",RNAM,"")) Q:'RSUB
|
||||
.S DLG=$P($G(^PXD(811.9,RSUB,51)),U) Q:DLG'=DIEN
|
||||
.W ! I FIRST W !,"REMINDERS ALREADY LINKED TO THIS DIALOG:",!! S FIRST=0
|
||||
.W ?18,$P($G(^PXD(811.9,RSUB,0)),U)
|
||||
Q
|
||||
;
|
||||
;Link a dialog (called by protocol PXRM DIALOG/REMINDER LINK)
|
||||
;-------------
|
||||
LINK(DIEN) ;
|
||||
F D Q:$D(DTOUT)!$D(DUOUT)
|
||||
.W IORESET
|
||||
.S VALMBCK="R"
|
||||
.;Display linked reminders
|
||||
.D DISPL(DIEN)
|
||||
.;
|
||||
.N ANS,DIC,DIR,DLG,LIT1,PNAME,PXRMREM,REM
|
||||
.S DIC("A")="SELECT A REMINDER TO LINK OR CHANGE: "
|
||||
.S LIT1="You must select a reminder!"
|
||||
.D SEL(811.9,"AEQMZ",.PXRMREM)
|
||||
.Q:$D(DTOUT)!$D(DUOUT)
|
||||
.S REM=$P(PXRMREM(1),U),PNAME=$P(PXRMREM(1),U,3)
|
||||
.I PNAME]"" W !!,"REMINDER PRINT NAME: "_PNAME,!
|
||||
.;Display related dialogs
|
||||
.D DISP(REM)
|
||||
.;Check if already linked
|
||||
.S DLG=$P($G(^PXD(811.9,REM,51)),U)
|
||||
.;Reconfirm to link reminder
|
||||
.I 'DLG S ANS="" D ASK(.ANS) Q:ANS'="Y"
|
||||
.;
|
||||
.N DA,DR,DIE
|
||||
.;Edit selected reminder
|
||||
.S DA=REM
|
||||
.;Settup local variables
|
||||
.S DIE="^PXD(811.9,",DR=51
|
||||
.;If no link force entry
|
||||
.I 'DLG S DR=DR_"///"_PXRMNAME
|
||||
.D ^DIE
|
||||
Q
|
||||
;
|
||||
;Link a Reminder (called by protocol PXRM DIALOG LINK)
|
||||
;---------------
|
||||
RLINK(REM) ;
|
||||
N DLG
|
||||
;Re-display reminder name
|
||||
W IORESET
|
||||
W !,PXRMHD
|
||||
;
|
||||
N DA,DR,DIE
|
||||
;Edit selected reminder
|
||||
S DA=REM
|
||||
;Settup local variables
|
||||
S DIE="^PXD(811.9,",DR=51
|
||||
;If no link force entry
|
||||
D ^DIE
|
||||
Q
|
||||
;
|
||||
;General help text routine.
|
||||
;--------------------------
|
||||
HLP(CALL) ;
|
||||
N HTEXT
|
||||
N DIWF,DIWL,DIWR,IC
|
||||
S DIWF="C75",DIWL=0,DIWR=75
|
||||
;
|
||||
I CALL=1 D
|
||||
.S HTEXT(1)="Enter Yes to link reminder to this dialog."
|
||||
I CALL=2 D
|
||||
.S HTEXT(1)="Enter Yes to link reminder to this dialog."
|
||||
K ^UTILITY($J,"W")
|
||||
S IC=""
|
||||
F S IC=$O(HTEXT(IC)) Q:IC="" D
|
||||
. S X=HTEXT(IC)
|
||||
. D ^DIWP
|
||||
W !
|
||||
S IC=0
|
||||
F S IC=$O(^UTILITY($J,"W",0,IC)) Q:IC="" D
|
||||
. W !,^UTILITY($J,"W",0,IC,0)
|
||||
K ^UTILITY($J,"W")
|
||||
W !
|
||||
Q
|
||||
;
|
||||
;Reminder selection
|
||||
;------------------
|
||||
SEL(FILE,MODE,ARRAY) ;
|
||||
N X,Y,CNT
|
||||
K DIROUT,DIRUT,DTOUT,DUOUT
|
||||
S CNT=0
|
||||
W !
|
||||
F D Q:$D(DTOUT) Q:$D(DUOUT) Q:CNT>0 Q:(Y=-1)&(CNT>0)
|
||||
.S DIC=FILE,DIC(0)=MODE
|
||||
.D ^DIC
|
||||
.I X=(U_U) S DTOUT=1
|
||||
.I '$D(DTOUT),('$D(DUOUT)) D
|
||||
..I +Y'=-1 D Q
|
||||
...S CNT=CNT+1,ARRAY(CNT)=Y_U_Y(0,0)_U_$P(Y(0),U,3)
|
||||
..W:CNT=0 !,LIT1
|
||||
.K DIC
|
||||
Q
|
||||
;
|
||||
;Input transform for FINDING ITEM in 801.41
|
||||
XINP(X) ;Taxonomy findings are not allowed for dialog groups
|
||||
I $P(X,";",2)="PXD(811.2,",$P($G(^PXRMD(801.41,DA,0)),U,4)="G" D Q 0
|
||||
.W $C(7),!,"A taxonomy cannot be entered as the finding item for a group"
|
||||
;Only applies to MH
|
||||
I $P(X,";",2)'="^YTT(601.71," Q 1
|
||||
I $$OK^PXRMDLL($P(X,";")) Q 1
|
||||
W *7,!,"This test is not appropriate for the GUI",!
|
||||
Q 0
|
||||
PXRMDLGZ ; SLC/PJH - Link reminder to dialog. ;05/31/2006
|
||||
;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
|
||||
;
|
||||
;Called by option PXRM DIALOG/COMPONENT EDIT
|
||||
;
|
||||
START N BY,DATA,DDES,DHD,DIC,DNAM,DTYP,FLDS,FR,L,LOGIC,NOW,PNAM,TO,Y
|
||||
N PXRMBG,PXRMHD,PXRMDIEN,PXRMGTYP,PXRMDTYP,PXRMITEM,PXRMMODE,PXRMNAME
|
||||
N PXRMTEMP,PXRMTITL,PXRMVIEW
|
||||
;Refresh on return
|
||||
S VALMBCK="R"
|
||||
S VALMSG="+ Next Screen - Prev Screen ?? More Actions"
|
||||
;Default is display dialog elements
|
||||
S PXRMDTYP="R",PXRMGTYP="DLGR",PXRMVIEW="AN"
|
||||
;Select dialog for display
|
||||
F D Q:'PXRMTEMP
|
||||
.S PXRMTEMP=""
|
||||
.D START^PXRMSEL(.PXRMHD,.PXRMGTYP,"PXRMTEMP") Q:'PXRMTEMP
|
||||
.N X S X="IORESET"
|
||||
.D ENDR^%ZISS,@(PXRMGTYP_"("_PXRMTEMP_")")
|
||||
END Q
|
||||
;
|
||||
;Reminder View
|
||||
;-------------
|
||||
DLGR(PXRMITEM) ;
|
||||
N PXRMDIEN,PXRMCS1,PXRMCS2
|
||||
;Format headings to include reminder and name
|
||||
S DATA=$G(^PXD(811.9,PXRMITEM,0)),RNAM=$P(DATA,U),PNAM=$P(DATA,U,3)
|
||||
S PXRMHD="REMINDER NAME: "_RNAM
|
||||
;
|
||||
;Dialog History
|
||||
F D Q:'PXRMDIEN
|
||||
.D START^PXRMDLGH(PXRMITEM,.PXRMDIEN,"PXRMDIEN") Q:'PXRMDIEN
|
||||
.N PXRMHD,VALMBCK,VALMBG,VALMSG,VIEW,X,XMZ
|
||||
.S DNAM=$P($G(^PXRMD(801.41,PXRMDIEN,0)),U)
|
||||
.I $P($G(^PXRMD(801.41,PXRMDIEN,0)),U,3)]"" S DNAM=DNAM_" (DISABLED)"
|
||||
.S PXRMHD="REMINDER DIALOG NAME: "_DNAM
|
||||
.S PXRMCS1=$$FILE^PXRMEXCS(801.41,PXRMDIEN)
|
||||
.S X="IORESET"
|
||||
.D ENDR^%ZISS,EN^VALM("PXRM DIALOG LIST")
|
||||
.I PXRMDIEN,$D(^PXRMD(801.41,PXRMDIEN,0)) D
|
||||
..S PXRMCS2=$$FILE^PXRMEXCS(801.41,PXRMDIEN) Q:+PXRMCS2=0
|
||||
..Q:PXRMCS1=PXRMCS2
|
||||
..D SEHIST^PXRMUTIL(801.41,"^PXRMD(801,41,",PXRMDIEN)
|
||||
.W IORESET
|
||||
.D KILL^%ZISS
|
||||
Q
|
||||
;
|
||||
;Edit element/prompt/group
|
||||
;-------------------------
|
||||
DLGE(PXRMDIEN) ;
|
||||
N LOCK,LFIND
|
||||
;Check for Uneditable flag
|
||||
S LOCK=$P($G(^PXRMD(801.41,PXRMTEMP,100)),U,4)
|
||||
S LFIND=$P($G(^PXRMD(801.41,PXRMTEMP,1)),U,5)
|
||||
I LOCK=1,$G(LFIND)'="",$G(LFIND)'["ORD",'$G(PXRMINST) D Q
|
||||
.W !,"This item can not be edited" H 2
|
||||
;
|
||||
S PXRMHD="Dialog Name: ",PXRMDIEN=PXRMTEMP
|
||||
;Format headings to include dialog name
|
||||
S DATA=$G(^PXRMD(801.41,PXRMDIEN,0)),DDES=$P(DATA,U),DTYP=$P(DATA,U,4)
|
||||
;Test
|
||||
I DTYP="G" D DLG(PXRMDIEN) Q
|
||||
;
|
||||
S PXRMHD=PXRMHD_" "_DDES W PXRMHD,!
|
||||
;Edit selected dialog
|
||||
D EDIT^PXRMDEDT(DTYP,PXRMDIEN,0)
|
||||
Q
|
||||
;
|
||||
;Reminder dialog view
|
||||
;--------------------
|
||||
DLG(PXRMDIEN) ;
|
||||
S PXRMDIEN=PXRMTEMP
|
||||
S PXRMNAME=$P($G(^PXRMD(801.41,PXRMDIEN,0)),U)
|
||||
S PXRMITEM=$P($G(^PXRMD(801.41,PXRMDIEN,0)),U,2)
|
||||
;Format headings to include dialog name
|
||||
S PXRMHD=PXRMHD_PXRMNAME
|
||||
;Check if the set is disable and add to header if disabled
|
||||
I $P(^PXRMD(801.41,PXRMDIEN,0),U,3)]"" S PXRMHD=PXRMHD_" (DISABLED)"
|
||||
;Listman option
|
||||
D EN^VALM("PXRM DIALOG LIST")
|
||||
W IORESET
|
||||
D KILL^%ZISS
|
||||
Q
|
||||
;
|
||||
;Other subroutines
|
||||
;
|
||||
;Ask update or no
|
||||
;----------------
|
||||
ASK(YESNO) ;
|
||||
N X,Y,TEXT,DIR
|
||||
K DIROUT,DIRUT,DTOUT,DUOUT
|
||||
S DIR(0)="YA0"
|
||||
S DIR("A")="LINK THIS REMINDER TO DIALOG - "_$P(PXRMHD,": ",2)_": "
|
||||
S DIR("B")="Y"
|
||||
S DIR("?")="Enter Y or N. For detailed help type ??"
|
||||
S DIR("??")=U_"D HLP^PXRMDLGY(1)"
|
||||
D ^DIR K DIR
|
||||
I $D(DIROUT) S DTOUT=1
|
||||
I $D(DTOUT)!($D(DUOUT)) Q
|
||||
S YESNO=$E(Y(0))
|
||||
Q
|
||||
;
|
||||
;Display dialogs autogenerated from this reminder
|
||||
;------------------------------------------------
|
||||
DISP(RIEN) ;
|
||||
N ARRAY,DSUB,FIRST
|
||||
;Get OTHER dialogs
|
||||
S FIRST=1,DSUB=""
|
||||
F S DSUB=$O(^PXRMD(801.41,"AG",RIEN,DSUB)) Q:'DSUB D
|
||||
.W !
|
||||
.D:FIRST
|
||||
..W "DIALOGS ALREADY GENERATED FROM THIS REMINDER:",!! S FIRST=0
|
||||
.W ?20,$P($G(^PXRMD(801.41,DSUB,0)),U)
|
||||
;
|
||||
I 'FIRST W !
|
||||
;
|
||||
Q
|
||||
;
|
||||
;Display linked reminders
|
||||
;------------------------
|
||||
DISPL(DIEN) ;
|
||||
N ARRAY,DLG,RSUB,FIRST,RNAM
|
||||
S RSUB=$P($G(^PXRMD(801.41,DIEN,0)),U,2)
|
||||
I RSUB W !!,"SOURCE REMINDER: "_$P($G(^PXD(811.9,RSUB,0)),U)
|
||||
;Linked reminders
|
||||
S FIRST=1,RNAM=""
|
||||
F S RNAM=$O(^PXD(811.9,"B",RNAM)) Q:RNAM="" D
|
||||
.S RSUB=$O(^PXD(811.9,"B",RNAM,"")) Q:'RSUB
|
||||
.S DLG=$P($G(^PXD(811.9,RSUB,51)),U) Q:DLG'=DIEN
|
||||
.W ! I FIRST W !,"REMINDERS ALREADY LINKED TO THIS DIALOG:",!! S FIRST=0
|
||||
.W ?18,$P($G(^PXD(811.9,RSUB,0)),U)
|
||||
Q
|
||||
;
|
||||
;Link a dialog (called by protocol PXRM DIALOG/REMINDER LINK)
|
||||
;-------------
|
||||
LINK(DIEN) ;
|
||||
F D Q:$D(DTOUT)!$D(DUOUT)
|
||||
.W IORESET
|
||||
.S VALMBCK="R"
|
||||
.;Display linked reminders
|
||||
.D DISPL(DIEN)
|
||||
.;
|
||||
.N ANS,DIC,DIR,DLG,LIT1,PNAME,PXRMREM,REM
|
||||
.S DIC("A")="SELECT A REMINDER TO LINK OR CHANGE: "
|
||||
.S LIT1="You must select a reminder!"
|
||||
.D SEL(811.9,"AEQMZ",.PXRMREM)
|
||||
.Q:$D(DTOUT)!$D(DUOUT)
|
||||
.S REM=$P(PXRMREM(1),U),PNAME=$P(PXRMREM(1),U,3)
|
||||
.I PNAME]"" W !!,"REMINDER PRINT NAME: "_PNAME,!
|
||||
.;Display related dialogs
|
||||
.D DISP(REM)
|
||||
.;Check if already linked
|
||||
.S DLG=$P($G(^PXD(811.9,REM,51)),U)
|
||||
.;Reconfirm to link reminder
|
||||
.I 'DLG S ANS="" D ASK(.ANS) Q:ANS'="Y"
|
||||
.;
|
||||
.N DA,DR,DIE
|
||||
.;Edit selected reminder
|
||||
.S DA=REM
|
||||
.;Settup local variables
|
||||
.S DIE="^PXD(811.9,",DR=51
|
||||
.;If no link force entry
|
||||
.I 'DLG S DR=DR_"///"_PXRMNAME
|
||||
.D ^DIE
|
||||
Q
|
||||
;
|
||||
;Link a Reminder (called by protocol PXRM DIALOG LINK)
|
||||
;---------------
|
||||
RLINK(REM) ;
|
||||
N DLG
|
||||
;Re-display reminder name
|
||||
W IORESET
|
||||
W !,PXRMHD
|
||||
;
|
||||
N DA,DR,DIE
|
||||
;Edit selected reminder
|
||||
S DA=REM
|
||||
;Settup local variables
|
||||
S DIE="^PXD(811.9,",DR=51
|
||||
;If no link force entry
|
||||
D ^DIE
|
||||
Q
|
||||
;
|
||||
;General help text routine.
|
||||
;--------------------------
|
||||
HLP(CALL) ;
|
||||
N HTEXT
|
||||
N DIWF,DIWL,DIWR,IC
|
||||
S DIWF="C75",DIWL=0,DIWR=75
|
||||
;
|
||||
I CALL=1 D
|
||||
.S HTEXT(1)="Enter Yes to link reminder to this dialog."
|
||||
I CALL=2 D
|
||||
.S HTEXT(1)="Enter Yes to link reminder to this dialog."
|
||||
K ^UTILITY($J,"W")
|
||||
S IC=""
|
||||
F S IC=$O(HTEXT(IC)) Q:IC="" D
|
||||
. S X=HTEXT(IC)
|
||||
. D ^DIWP
|
||||
W !
|
||||
S IC=0
|
||||
F S IC=$O(^UTILITY($J,"W",0,IC)) Q:IC="" D
|
||||
. W !,^UTILITY($J,"W",0,IC,0)
|
||||
K ^UTILITY($J,"W")
|
||||
W !
|
||||
Q
|
||||
;
|
||||
;Reminder selection
|
||||
;------------------
|
||||
SEL(FILE,MODE,ARRAY) ;
|
||||
N X,Y,CNT
|
||||
K DIROUT,DIRUT,DTOUT,DUOUT
|
||||
S CNT=0
|
||||
W !
|
||||
F D Q:$D(DTOUT) Q:$D(DUOUT) Q:CNT>0 Q:(Y=-1)&(CNT>0)
|
||||
.S DIC=FILE,DIC(0)=MODE
|
||||
.D ^DIC
|
||||
.I X=(U_U) S DTOUT=1
|
||||
.I '$D(DTOUT),('$D(DUOUT)) D
|
||||
..I +Y'=-1 D Q
|
||||
...S CNT=CNT+1,ARRAY(CNT)=Y_U_Y(0,0)_U_$P(Y(0),U,3)
|
||||
..W:CNT=0 !,LIT1
|
||||
.K DIC
|
||||
Q
|
||||
;
|
||||
;Input transform for FINDING ITEM in 801.41
|
||||
XINP(X) ;Taxonomy findings are not allowed for dialog groups
|
||||
I $P(X,";",2)="PXD(811.2,",$P($G(^PXRMD(801.41,DA,0)),U,4)="G" D Q 0
|
||||
.W $C(7),!,"A taxonomy cannot be entered as the finding item for a group"
|
||||
;Only applies to MH
|
||||
I $P(X,";",2)'="YTT(601," Q 1
|
||||
;GAF
|
||||
I $P($G(^YTT(601,$P(X,";"),0)),U)="GAF" Q 1
|
||||
;Check if a VALID GUI test
|
||||
I $P($G(^YTT(601.6,$P(X,";"),0)),U,4)="Y" Q 1
|
||||
;else
|
||||
W *7,!,"This test is not appropriate for the GUI",!
|
||||
Q 0
|
||||
|
|
|
|||
|
|
@ -1,272 +1,270 @@
|
|||
PXRMDLL ;SLC/PJH - REMINDER DIALOG LOADER ;09/26/2007
|
||||
;;2.0;CLINICAL REMINDERS;**10,6**;Feb 04, 2005;Build 123
|
||||
;
|
||||
OK(DIEN) ;Check if mental health test is for GUI
|
||||
I 'DIEN Q 0
|
||||
Q $$MH^PXRMDLG5(DIEN)
|
||||
;
|
||||
TXT ;Format text
|
||||
N NULL
|
||||
S TEXT=DTXT(SUB),NULL=0
|
||||
I ($E(TEXT)=" ")!(TEXT="") S NULL=1
|
||||
I LAST,'NULL S TEXT="<br>"_TEXT
|
||||
S TEXT=$$STRREP^PXRMUTIL(TEXT,"\\","<br>")
|
||||
S LAST=0 I NULL S TEXT="<br>"_TEXT,LAST=1
|
||||
Q
|
||||
;
|
||||
EXP(TIEN,DITEM,DSUB) ;Expand taxonomy codes
|
||||
N ACNT,AHIS,ATYP,ARRAY,CODES,CNT,DPCE,DTAX
|
||||
;Get taxonomy file details
|
||||
D TAX(TIEN,.ARRAY)
|
||||
;
|
||||
;Build dialog from the returned array
|
||||
;
|
||||
;Main Taxonomy prompt
|
||||
S DTXT=ARRAY
|
||||
S OCNT=OCNT+1
|
||||
S ORY(OCNT)=1_U_DITEM_U_DSUB_U_"S"_U_DEXC
|
||||
;Default group indents and selection entry
|
||||
S $P(ORY(OCNT),U,16)=2,$P(ORY(OCNT),U,18)=2
|
||||
S OCNT=OCNT+1
|
||||
S ORY(OCNT)=2_U_DITEM_U_DSUB_U_DTXT
|
||||
;
|
||||
;Taxonomy CPT/POV resolution prompts
|
||||
S ACNT=""
|
||||
F S ACNT=$O(ARRAY(ACNT)) Q:ACNT="" D
|
||||
.;Prompt text
|
||||
.S DTXT=$P(ARRAY(ACNT),U),DPCE=$P(ARRAY(ACNT),U,4)
|
||||
.;Historical/Current flag
|
||||
.S AHIS=0 I $P(ARRAY(ACNT),U,3)=2 S AHIS=1
|
||||
.;CPT/POV
|
||||
.S ATYP="POV" I $P(ARRAY(ACNT),U,2)=81 S ATYP="CPT"
|
||||
.;Initial display
|
||||
.S DHIDE=0,DCHECK=0,DDIS=0
|
||||
.;Construct ien for this level
|
||||
.S DTAX=DSUB_"."_ACNT
|
||||
.S OCNT=OCNT+1
|
||||
.S ORY(OCNT)=1_U_DITEM_U_DTAX_U_"T"_U_DEXC_U_U_ATYP_U_AHIS
|
||||
.S OCNT=OCNT+1
|
||||
.S ORY(OCNT)=2_U_DITEM_U_DTAX_U_DTXT
|
||||
Q
|
||||
;
|
||||
GROUP(DIEN,DSUB) ;Dialog group
|
||||
N DATA,DBOX,DCAP,DCHK,DENTRY,DEXC,DGIEN,DGRP,DGSEQ,DGSUB,DHIDE,DIND
|
||||
N DINDPN,DMHEX,DRESL,DSHARE,SUB,DCOUNT
|
||||
;Group caption text
|
||||
S DATA=$G(^PXRMD(801.41,DIEN,0))
|
||||
S DCAP=$P(DATA,U,5),DBOX=$P(DATA,U,6),DIND=$P(DATA,U,7)
|
||||
S DSHARE=$P(DATA,U,8),DENTRY=$P(DATA,U,9),DHIDE=$P(DATA,U,10)
|
||||
S DINDPN=$P(DATA,U,12) S:DINDPN="" DINDPN=0
|
||||
S DBOX=$S(DBOX="Y":1,1:"")
|
||||
;group header is display only if SUPPRESS CHECKBOX
|
||||
S DCHK="S" I ('DHIDE)&(DSUPP) S DCHK="D",DHIDE=0
|
||||
;Default group setting to hide
|
||||
I DHIDE="" S DHIDE=1
|
||||
;
|
||||
S DEXC=$P($G(^PXRMD(801.41,DIEN,2)),U,3)
|
||||
;
|
||||
S OCNT=OCNT+1,ORY(OCNT)=1_U_DIEN_U_DSUB_U_DCHK_U_DEXC
|
||||
S $P(ORY(OCNT),U,8)=$$AHIS(DIEN)
|
||||
S $P(ORY(OCNT),U,15)=DHIDE,$P(ORY(OCNT),U,16)=DIND
|
||||
S $P(ORY(OCNT),U,17)=DSHARE,$P(ORY(OCNT),U,18)=DENTRY
|
||||
S $P(ORY(OCNT),U,19)=DBOX,$P(ORY(OCNT),U,20)=DCAP
|
||||
S $P(ORY(OCNT),U,21)=DINDPN
|
||||
;Create type 2 records if if here is additional group text
|
||||
N LAST,TEXT
|
||||
S SUB=0,LAST=0 F S SUB=$O(DTXT(SUB)) Q:'SUB D
|
||||
.D TXT
|
||||
.S OCNT=OCNT+1,ORY(OCNT)=2_U_DIEN_U_DSUB_U_TEXT
|
||||
;Get dialog group sub-elements
|
||||
N DTYP,DSUPP,DDIS,IDENT S DGSEQ=0
|
||||
F S DGSEQ=$O(^PXRMD(801.41,DIEN,10,"B",DGSEQ)) Q:'DGSEQ D
|
||||
.S DGSUB=$O(^PXRMD(801.41,DIEN,10,"B",DGSEQ,"")) Q:'DGSUB
|
||||
.S DATA=$G(^PXRMD(801.41,DIEN,10,DGSUB,0))
|
||||
.S DGIEN=$P(DATA,U,2) Q:'DGIEN
|
||||
.;Branching logic call to determine if element should be suppress,
|
||||
.;replace or left as is
|
||||
.N TERMNODE,TERMSTAT
|
||||
.S TERMNODE=$G(^PXRMD(801.41,DGIEN,49))
|
||||
.I $G(TERMNODE)'="" D Q:TERMSTAT=0
|
||||
..S TERMSTAT=1
|
||||
..D REPLACE^PXRMDLLB(DFN,TERMNODE,.DGIEN,.DATA,.TERMSTAT)
|
||||
.;Exclude from P/N
|
||||
.S DEXC=$P(DATA,U,8)
|
||||
.I $P($G(^PXRMD(801.41,DGIEN,0)),U,16)'["WHR" D
|
||||
..K DTXT S SUB=0 F S SUB=$O(^PXRMD(801.41,DGIEN,25,SUB)) Q:'SUB D
|
||||
...S DTXT(SUB)=$G(^PXRMD(801.41,DGIEN,25,SUB,0))
|
||||
.;Check if element is disabled/invalid
|
||||
.S DATA=$G(^PXRMD(801.41,DGIEN,0)) Q:DATA="" Q:$P(DATA,U,3)]""
|
||||
.;If the actual element is exclude from P/N override
|
||||
.I $P($G(^PXRMD(801.41,DGIEN,2)),U,3) S DEXC=1
|
||||
.S DTYP=$P(DATA,U,4),DSUPP=$P(DATA,U,11) Q:"EG"'[DTYP
|
||||
.S DMHEX=$P(DATA,U,14)
|
||||
.S DRESL=$$RESGROUP^PXRMDLLB(DGIEN)
|
||||
.;S DRESL=$P(DATA,U,15)
|
||||
.S DRES=$P($G(^PXRMD(801.41,DGIEN,1)),U,3)
|
||||
.;Done Elsewhere (historical)
|
||||
.S DHIS=$$AHIS(DGIEN)
|
||||
.S DFIND=$P($G(^PXRMD(801.41,DGIEN,1)),U,5)
|
||||
.S DFIEN=$P(DFIND,";"),DFTYP=$P(DFIND,";",2)
|
||||
.S DPCE="" I DFTYP'="" S DPCE=$G(DARRAY(DFTYP))
|
||||
.;If mental Health ignore if not GUI
|
||||
.I DPCE="MH" Q:'$$OK(DFIEN)
|
||||
.S DGRP=DSUB_"."_DGSUB
|
||||
.;Taxonomy codes need expanding
|
||||
.I DPCE="T" D EXP(DFIEN,DGIEN,DGRP) Q
|
||||
.;Translate vitals ien to PCE code - This will need a DBIA
|
||||
.I DPCE="VIT" S DFIEN=$$GET1^DIQ(120.51,DFIEN,7,"E")
|
||||
.;Embedded Dialog Group
|
||||
.I DTYP="G" D GROUP(DGIEN,DGRP) Q
|
||||
.S DDIS="S" I DSUPP=1 S DDIS="D"
|
||||
.S DGRP=DSUB_"."_DGSUB,OCNT=OCNT+1
|
||||
.S ORY(OCNT)=1_U_DGIEN_U_DGRP_U_DDIS_U_DEXC_U_U_U_DHIS_U_DMHEX_U_DRESL_U_$G(DCOUNT)
|
||||
.;
|
||||
.N LAST,TEXT
|
||||
.S SUB=0,LAST=0 F S SUB=$O(DTXT(SUB)) Q:'SUB D
|
||||
..D TXT
|
||||
..S OCNT=OCNT+1,ORY(OCNT)=2_U_DGIEN_U_DGRP_U_TEXT
|
||||
Q
|
||||
;
|
||||
LOAD(DIEN,DFN) ;Load dialog questions into array
|
||||
N DARRAY,DATA,DITEM,DFIND,DFIEN,DFTYP,DPCE,DRES,DSEQ,DSUB,DTXT,DTYP,OCNT
|
||||
N DDIS,DEXC,DHIDE,DCHECK,DDIS,DHIS,DMHEX,DRESL,DSUPP,SUB,IDENT,TXTCNT
|
||||
;Check Status of dialog
|
||||
S DATA=$G(^PXRMD(801.41,DIEN,0)) Q:DATA=""
|
||||
;If disabled ignore
|
||||
I $P(DATA,U,3)]"" Q
|
||||
;Ignore if not a reminder dialog
|
||||
I $P(DATA,U,4)'="R" Q
|
||||
;
|
||||
;List of PCE codes
|
||||
S DARRAY("AUTTEDT(")="PED"
|
||||
S DARRAY("AUTTEXAM(")="XAM"
|
||||
S DARRAY("AUTTHF(")="HF"
|
||||
S DARRAY("AUTTIMM(")="IMM"
|
||||
S DARRAY("AUTTSK(")="SK"
|
||||
S DARRAY("GMRD(120.51,")="VIT"
|
||||
S DARRAY("ORD(101.41,")="Q"
|
||||
S DARRAY("YTT(601.71,")="MH"
|
||||
S DARRAY("ICD9(")="POV"
|
||||
S DARRAY("ICPT(")="CPT"
|
||||
S DARRAY("PXD(811.2,")="T"
|
||||
S DARRAY("WV(790.1,")="WHR"
|
||||
;
|
||||
;Get elements for the dialog
|
||||
S DSEQ=0,OCNT=0
|
||||
F S DSEQ=$O(^PXRMD(801.41,DIEN,10,"B",DSEQ)) Q:'DSEQ D
|
||||
.S DSUB=$O(^PXRMD(801.41,DIEN,10,"B",DSEQ,"")) Q:'DSUB
|
||||
.S DATA=$G(^PXRMD(801.41,DIEN,10,DSUB,0))
|
||||
.S DITEM=$P(DATA,U,2) Q:DITEM=""
|
||||
.;Ignore disabled elements
|
||||
.S DATA=$G(^PXRMD(801.41,DITEM,0)) Q:DATA="" Q:$P(DATA,U,3)]""
|
||||
.;Branching logic call to determine if element should be suppress,
|
||||
.;replace or left as is
|
||||
.S TERMNODE=$G(^PXRMD(801.41,DITEM,49))
|
||||
.N TERMSTAT
|
||||
.I $G(TERMNODE)'="" D Q:TERMSTAT=0
|
||||
..S TERMSTAT=1
|
||||
..D REPLACE^PXRMDLLB(DFN,TERMNODE,.DITEM,.DATA,.TERMSTAT)
|
||||
.S DTYP=$P(DATA,U,4),DSUPP=$P(DATA,U,11)
|
||||
.S DMHEX=$P(DATA,U,14)
|
||||
.S DRESL=$$RESGROUP^PXRMDLLB(DITEM)
|
||||
.;S DRESL=$P(DATA,U,15)
|
||||
.K DTXT S SUB=0
|
||||
.F S SUB=$O(^PXRMD(801.41,DITEM,25,SUB)) Q:'SUB D
|
||||
..S DTXT(SUB)=$G(^PXRMD(801.41,DITEM,25,SUB,0))
|
||||
.S DRES=$P($G(^PXRMD(801.41,DITEM,1)),U,3)
|
||||
.S DFIND=$P($G(^PXRMD(801.41,DITEM,1)),U,5)
|
||||
.S DFIEN=$P(DFIND,";"),DFTYP=$P(DFIND,";",2)
|
||||
.S DPCE="" I DFTYP'="" S DPCE=$G(DARRAY(DFTYP))
|
||||
.;If mental Health ignore if not GUI
|
||||
.I DPCE="MH" Q:'$$OK(DFIEN)
|
||||
.;Exclude from PN
|
||||
.S DEXC=$P($G(^PXRMD(801.41,DITEM,2)),U,3)
|
||||
.;Taxonomy codes need expanding
|
||||
.I DPCE="T" D EXP(DFIEN,DITEM,DSUB) Q
|
||||
.;Translate vitals ien to PCE code - This will need a DBIA
|
||||
.I DPCE="VIT" S DFIEN=$P($G(^GMRD(120.51,DFIEN,0)),U,7)
|
||||
.;Done Elsewhere (historical)
|
||||
.S DHIS=$$AHIS(DITEM)
|
||||
.;Dialog Group
|
||||
.I DTYP="G" D GROUP(DITEM,DSUB) Q
|
||||
.;Dialog type/text and resolution
|
||||
.S OCNT=OCNT+1,DDIS="S"
|
||||
.I DSUPP=1 S DDIS="D"
|
||||
.S ORY(OCNT)=1_U_DITEM_U_DSUB_U_DDIS_U_DEXC_U_U_U_DHIS_U_DMHEX_U_DRESL
|
||||
.N LAST,TEXT
|
||||
.S SUB=0,LAST=0 F S SUB=$O(DTXT(SUB)) Q:'SUB D
|
||||
..D TXT
|
||||
..S OCNT=OCNT+1,ORY(OCNT)=2_U_DITEM_U_DSUB_U_TEXT
|
||||
Q
|
||||
;
|
||||
TAX(TXIEN,ARRAY) ;Return list of resolutions/codes for taxonomy
|
||||
N CNT,DTXT,FNODE,RSUB,TDX,TNAME,TPAR,TPR,TYP
|
||||
N TCUR,TDTXT,TDHTXT,THIS,TPTXT,TPHTXT
|
||||
;
|
||||
;Get taxonomy name
|
||||
S TNAME=$P($G(^PXD(811.2,TXIEN,0)),U,1)
|
||||
;
|
||||
;Check what type of taxonomy codes exist
|
||||
S TDX=$$TOK^PXRMDLLA(TXIEN,"SDX")
|
||||
S TPR=$$TOK^PXRMDLLA(TXIEN,"SPR")
|
||||
;
|
||||
;Taxonomy dialog text
|
||||
S DTXT=$P($G(^PXD(811.2,TXIEN,0)),U,3)
|
||||
;default to taxonomy description if null
|
||||
I DTXT="" S DTXT=$P($G(^PXD(811.2,TXIEN,0)),U,2)
|
||||
;default to taxonomy name if null
|
||||
I DTXT="" S DTXT=$P($G(^PXD(811.2,TXIEN,0)),U,1)
|
||||
;
|
||||
S CNT=0,ARRAY=DTXT
|
||||
;
|
||||
;Diagnoses
|
||||
I TDX D
|
||||
.;Diagnosis texts
|
||||
.S TPAR=$G(^PXD(811.2,TXIEN,"SDZ"))
|
||||
.;Get parameter file node for this finding type
|
||||
.S FNODE=$O(^PXRMD(801.45,"B","POV","")) Q:FNODE=""
|
||||
.;check if finding parameters are disabled
|
||||
.S TCUR=$P($G(^PXRMD(801.45,FNODE,1,1,0)),U,2)
|
||||
.S THIS=$P($G(^PXRMD(801.45,FNODE,1,2,0)),U,2)
|
||||
.;get category text (diagnoses)
|
||||
.I 'TCUR D ; Current
|
||||
..S TDTXT=$P(TPAR,U,2) S:TDTXT="" TDTXT=TNAME
|
||||
..S CNT=CNT+1,ARRAY(CNT)=TDTXT_U_80_U_1_U_"POV"
|
||||
.I 'THIS D ; Historical
|
||||
..S TDHTXT=$P(TPAR,U,3) S:TDHTXT="" TDHTXT=TNAME_" (HISTORICAL)"
|
||||
..S CNT=CNT+1,ARRAY(CNT)=TDHTXT_U_80_U_2_U_"POV"
|
||||
;Procedures
|
||||
I TPR D
|
||||
.;Procedure texts
|
||||
.S TPAR=$G(^PXD(811.2,TXIEN,"SPZ"))
|
||||
.;Get parameter file node for this finding type
|
||||
.S FNODE=$O(^PXRMD(801.45,"B","CPT","")) Q:FNODE=""
|
||||
.;check if finding parameters are disabled
|
||||
.S TCUR=$P($G(^PXRMD(801.45,FNODE,1,1,0)),U,2)
|
||||
.S THIS=$P($G(^PXRMD(801.45,FNODE,1,2,0)),U,2)
|
||||
.;get category text (procedures)
|
||||
.I 'TCUR D ; Current
|
||||
..S TPTXT=$P(TPAR,U,2) S:TPTXT="" TPTXT=TNAME
|
||||
..S CNT=CNT+1,ARRAY(CNT)=TPTXT_U_81_U_1_U_"CPT"
|
||||
.I 'THIS D ; Historical
|
||||
..S TPHTXT=$P(TPAR,U,3) S:TPHTXT="" TPHTXT=TNAME_" (HISTORICAL)"
|
||||
..S CNT=CNT+1,ARRAY(CNT)=TPHTXT_U_81_U_2_U_"CPT"
|
||||
;
|
||||
Q
|
||||
;
|
||||
AHIS(DITEM) ;
|
||||
N RSIEN,RSNAM
|
||||
S RSIEN=$P($G(^PXRMD(801.41,DITEM,1)),U,3)
|
||||
I RSIEN="" Q 0
|
||||
S RSNAM=$P($G(^PXRMD(801.9,RSIEN,0)),U)
|
||||
I RSNAM["DONE ELSEWHERE" Q 1
|
||||
N GUI,PIEN,PFOUND
|
||||
S PIEN=0,PFOUND=0
|
||||
F S PIEN=$O(^PXRMD(801.41,DITEM,10,"D",PIEN)) Q:'PIEN D Q:PFOUND
|
||||
.;Ignore elements and groups
|
||||
.I "EG"[$P($G(^PXRMD(801.41,PIEN,0)),U,4) Q
|
||||
.;GUI Process
|
||||
.S GUI=$P($G(^PXRMD(801.41,PIEN,46)),U) Q:'GUI
|
||||
.;Check if this is PXRM VISIT DATE (or a copy of it)
|
||||
.I $P($G(^PXRMD(801.42,GUI,0)),U)="VST_DATE" S PFOUND=1
|
||||
Q PFOUND
|
||||
PXRMDLL ;SLC/PJH - REMINDER DIALOG LOADER ;09/26/2007
|
||||
;;2.0;CLINICAL REMINDERS;**10**;Feb 04, 2005;Build 25
|
||||
;
|
||||
OK(DIEN) ;Check if mental health test is for GUI
|
||||
I 'DFIEN Q 0
|
||||
I $P($G(^YTT(601.6,DFIEN,0)),U,4)="Y" Q 1
|
||||
I $P($G(^YTT(601,DFIEN,0)),U)="GAF" Q 1
|
||||
Q 0
|
||||
;
|
||||
TXT ;Format text
|
||||
N NULL
|
||||
S TEXT=DTXT(SUB),NULL=0
|
||||
I ($E(TEXT)=" ")!(TEXT="") S NULL=1
|
||||
I LAST,'NULL S TEXT="<br>"_TEXT
|
||||
S TEXT=$$STRREP^PXRMUTIL(TEXT,"\\","<br>")
|
||||
S LAST=0 I NULL S TEXT="<br>"_TEXT,LAST=1
|
||||
Q
|
||||
;
|
||||
EXP(TIEN,DITEM,DSUB) ;Expand taxonomy codes
|
||||
N ACNT,AHIS,ATYP,ARRAY,CODES,CNT,DPCE,DTAX
|
||||
;Get taxonomy file details
|
||||
D TAX(TIEN,.ARRAY)
|
||||
;
|
||||
;Build dialog from the returned array
|
||||
;
|
||||
;Main Taxonomy prompt
|
||||
S DTXT=ARRAY
|
||||
S OCNT=OCNT+1
|
||||
S ORY(OCNT)=1_U_DITEM_U_DSUB_U_"S"_U_DEXC
|
||||
;Default group indents and selection entry
|
||||
S $P(ORY(OCNT),U,16)=2,$P(ORY(OCNT),U,18)=2
|
||||
S OCNT=OCNT+1
|
||||
S ORY(OCNT)=2_U_DITEM_U_DSUB_U_DTXT
|
||||
;
|
||||
;Taxonomy CPT/POV resolution prompts
|
||||
S ACNT=""
|
||||
F S ACNT=$O(ARRAY(ACNT)) Q:ACNT="" D
|
||||
.;Prompt text
|
||||
.S DTXT=$P(ARRAY(ACNT),U),DPCE=$P(ARRAY(ACNT),U,4)
|
||||
.;Historical/Current flag
|
||||
.S AHIS=0 I $P(ARRAY(ACNT),U,3)=2 S AHIS=1
|
||||
.;CPT/POV
|
||||
.S ATYP="POV" I $P(ARRAY(ACNT),U,2)=81 S ATYP="CPT"
|
||||
.;Initial display
|
||||
.S DHIDE=0,DCHECK=0,DDIS=0
|
||||
.;Construct ien for this level
|
||||
.S DTAX=DSUB_"."_ACNT
|
||||
.S OCNT=OCNT+1
|
||||
.S ORY(OCNT)=1_U_DITEM_U_DTAX_U_"T"_U_DEXC_U_U_ATYP_U_AHIS
|
||||
.S OCNT=OCNT+1
|
||||
.S ORY(OCNT)=2_U_DITEM_U_DTAX_U_DTXT
|
||||
Q
|
||||
;
|
||||
GROUP(DIEN,DSUB) ;Dialog group
|
||||
N DATA,DBOX,DCAP,DCHK,DENTRY,DEXC,DGIEN,DGRP,DGSEQ,DGSUB,DHIDE,DIND
|
||||
N DINDPN,DMHEX,DRESL,DSHARE,SUB,DCOUNT
|
||||
;Group caption text
|
||||
S DATA=$G(^PXRMD(801.41,DIEN,0))
|
||||
S DCAP=$P(DATA,U,5),DBOX=$P(DATA,U,6),DIND=$P(DATA,U,7)
|
||||
S DSHARE=$P(DATA,U,8),DENTRY=$P(DATA,U,9),DHIDE=$P(DATA,U,10)
|
||||
S DINDPN=$P(DATA,U,12) S:DINDPN="" DINDPN=0
|
||||
S DBOX=$S(DBOX="Y":1,1:"")
|
||||
;group header is display only if SUPPRESS CHECKBOX
|
||||
S DCHK="S" I ('DHIDE)&(DSUPP) S DCHK="D",DHIDE=0
|
||||
;Default group setting to hide
|
||||
I DHIDE="" S DHIDE=1
|
||||
;
|
||||
S DEXC=$P($G(^PXRMD(801.41,DIEN,2)),U,3)
|
||||
;
|
||||
S OCNT=OCNT+1,ORY(OCNT)=1_U_DIEN_U_DSUB_U_DCHK_U_DEXC
|
||||
S $P(ORY(OCNT),U,8)=$$AHIS(DIEN)
|
||||
S $P(ORY(OCNT),U,15)=DHIDE,$P(ORY(OCNT),U,16)=DIND
|
||||
S $P(ORY(OCNT),U,17)=DSHARE,$P(ORY(OCNT),U,18)=DENTRY
|
||||
S $P(ORY(OCNT),U,19)=DBOX,$P(ORY(OCNT),U,20)=DCAP
|
||||
S $P(ORY(OCNT),U,21)=DINDPN
|
||||
;Create type 2 records if if here is additional group text
|
||||
N LAST,TEXT
|
||||
S SUB=0,LAST=0 F S SUB=$O(DTXT(SUB)) Q:'SUB D
|
||||
.D TXT
|
||||
.S OCNT=OCNT+1,ORY(OCNT)=2_U_DIEN_U_DSUB_U_TEXT
|
||||
;Get dialog group sub-elements
|
||||
N DTYP,DSUPP,DDIS,IDENT S DGSEQ=0
|
||||
F S DGSEQ=$O(^PXRMD(801.41,DIEN,10,"B",DGSEQ)) Q:'DGSEQ D
|
||||
.S DGSUB=$O(^PXRMD(801.41,DIEN,10,"B",DGSEQ,"")) Q:'DGSUB
|
||||
.S DATA=$G(^PXRMD(801.41,DIEN,10,DGSUB,0))
|
||||
.S DGIEN=$P(DATA,U,2) Q:'DGIEN
|
||||
.;Branching logic call to determine if element should be suppress,
|
||||
.;replace or left as is
|
||||
.N TERMNODE,TERMSTAT
|
||||
.S TERMNODE=$G(^PXRMD(801.41,DGIEN,49))
|
||||
.I $G(TERMNODE)'="" D Q:TERMSTAT=0
|
||||
..S TERMSTAT=1
|
||||
..D REPLACE^PXRMDLLB(DFN,TERMNODE,.DGIEN,.DATA,.TERMSTAT)
|
||||
.;Exclude from P/N
|
||||
.S DEXC=$P(DATA,U,8)
|
||||
.I $P($G(^PXRMD(801.41,DGIEN,0)),U,16)'["WHR" D
|
||||
..K DTXT S SUB=0 F S SUB=$O(^PXRMD(801.41,DGIEN,25,SUB)) Q:'SUB D
|
||||
...S DTXT(SUB)=$G(^PXRMD(801.41,DGIEN,25,SUB,0))
|
||||
.;Check if element is disabled/invalid
|
||||
.S DATA=$G(^PXRMD(801.41,DGIEN,0)) Q:DATA="" Q:$P(DATA,U,3)]""
|
||||
.;If the actual element is exclude from P/N override
|
||||
.I $P($G(^PXRMD(801.41,DGIEN,2)),U,3) S DEXC=1
|
||||
.S DTYP=$P(DATA,U,4),DSUPP=$P(DATA,U,11) Q:"EG"'[DTYP
|
||||
.S DMHEX=$P(DATA,U,14),DRESL=$P(DATA,U,15)
|
||||
.S DRES=$P($G(^PXRMD(801.41,DGIEN,1)),U,3)
|
||||
.;Done Elsewhere (historical)
|
||||
.S DHIS=$$AHIS(DGIEN)
|
||||
.S DFIND=$P($G(^PXRMD(801.41,DGIEN,1)),U,5)
|
||||
.S DFIEN=$P(DFIND,";"),DFTYP=$P(DFIND,";",2)
|
||||
.S DPCE="" I DFTYP'="" S DPCE=$G(DARRAY(DFTYP))
|
||||
.;If mental Health ignore if not GUI
|
||||
.I DPCE="MH" Q:'$$OK(DFIEN)
|
||||
.S DGRP=DSUB_"."_DGSUB
|
||||
.;Taxonomy codes need expanding
|
||||
.I DPCE="T" D EXP(DFIEN,DGIEN,DGRP) Q
|
||||
.;Translate vitals ien to PCE code - This will need a DBIA
|
||||
.I DPCE="VIT" S DFIEN=$$GET1^DIQ(120.51,DFIEN,7,"E")
|
||||
.;Embedded Dialog Group
|
||||
.I DTYP="G" D GROUP(DGIEN,DGRP) Q
|
||||
.S DDIS="S" I DSUPP=1 S DDIS="D"
|
||||
.S DGRP=DSUB_"."_DGSUB,OCNT=OCNT+1
|
||||
.S ORY(OCNT)=1_U_DGIEN_U_DGRP_U_DDIS_U_DEXC_U_U_U_DHIS_U_DMHEX_U_DRESL_U_$G(DCOUNT)
|
||||
.;
|
||||
.N LAST,TEXT
|
||||
.S SUB=0,LAST=0 F S SUB=$O(DTXT(SUB)) Q:'SUB D
|
||||
..D TXT
|
||||
..S OCNT=OCNT+1,ORY(OCNT)=2_U_DGIEN_U_DGRP_U_TEXT
|
||||
Q
|
||||
;
|
||||
LOAD(DIEN,DFN) ;Load dialog questions into array
|
||||
N DARRAY,DATA,DITEM,DFIND,DFIEN,DFTYP,DPCE,DRES,DSEQ,DSUB,DTXT,DTYP,OCNT
|
||||
N DDIS,DEXC,DHIDE,DCHECK,DDIS,DHIS,DMHEX,DRESL,DSUPP,SUB,IDENT,TXTCNT
|
||||
;Check Status of dialog
|
||||
S DATA=$G(^PXRMD(801.41,DIEN,0)) Q:DATA=""
|
||||
;If disabled ignore
|
||||
I $P(DATA,U,3)]"" Q
|
||||
;Ignore if not a reminder dialog
|
||||
I $P(DATA,U,4)'="R" Q
|
||||
;
|
||||
;List of PCE codes
|
||||
S DARRAY("AUTTEDT(")="PED"
|
||||
S DARRAY("AUTTEXAM(")="XAM"
|
||||
S DARRAY("AUTTHF(")="HF"
|
||||
S DARRAY("AUTTIMM(")="IMM"
|
||||
S DARRAY("AUTTSK(")="SK"
|
||||
S DARRAY("GMRD(120.51,")="VIT"
|
||||
S DARRAY("ORD(101.41,")="Q"
|
||||
S DARRAY("YTT(601,")="MH"
|
||||
S DARRAY("ICD9(")="POV"
|
||||
S DARRAY("ICPT(")="CPT"
|
||||
S DARRAY("PXD(811.2,")="T"
|
||||
S DARRAY("WV(790.1,")="WHR"
|
||||
;
|
||||
;Get elements for the dialog
|
||||
S DSEQ=0,OCNT=0
|
||||
F S DSEQ=$O(^PXRMD(801.41,DIEN,10,"B",DSEQ)) Q:'DSEQ D
|
||||
.S DSUB=$O(^PXRMD(801.41,DIEN,10,"B",DSEQ,"")) Q:'DSUB
|
||||
.S DATA=$G(^PXRMD(801.41,DIEN,10,DSUB,0))
|
||||
.S DITEM=$P(DATA,U,2) Q:DITEM=""
|
||||
.;Ignore disabled elements
|
||||
.S DATA=$G(^PXRMD(801.41,DITEM,0)) Q:DATA="" Q:$P(DATA,U,3)]""
|
||||
.;Branching logic call to determine if element should be suppress,
|
||||
.;replace or left as is
|
||||
.S TERMNODE=$G(^PXRMD(801.41,DITEM,49))
|
||||
.N TERMSTAT
|
||||
.I $G(TERMNODE)'="" D Q:TERMSTAT=0
|
||||
..S TERMSTAT=1
|
||||
..D REPLACE^PXRMDLLB(DFN,TERMNODE,.DITEM,.DATA,.TERMSTAT)
|
||||
.S DTYP=$P(DATA,U,4),DSUPP=$P(DATA,U,11)
|
||||
.S DMHEX=$P(DATA,U,14),DRESL=$P(DATA,U,15)
|
||||
.K DTXT S SUB=0
|
||||
.F S SUB=$O(^PXRMD(801.41,DITEM,25,SUB)) Q:'SUB D
|
||||
..S DTXT(SUB)=$G(^PXRMD(801.41,DITEM,25,SUB,0))
|
||||
.S DRES=$P($G(^PXRMD(801.41,DITEM,1)),U,3)
|
||||
.S DFIND=$P($G(^PXRMD(801.41,DITEM,1)),U,5)
|
||||
.S DFIEN=$P(DFIND,";"),DFTYP=$P(DFIND,";",2)
|
||||
.S DPCE="" I DFTYP'="" S DPCE=$G(DARRAY(DFTYP))
|
||||
.;If mental Health ignore if not GUI
|
||||
.I DPCE="MH" Q:'$$OK(DFIEN)
|
||||
.;Exclude from PN
|
||||
.S DEXC=$P($G(^PXRMD(801.41,DITEM,2)),U,3)
|
||||
.;Taxonomy codes need expanding
|
||||
.I DPCE="T" D EXP(DFIEN,DITEM,DSUB) Q
|
||||
.;Translate vitals ien to PCE code - This will need a DBIA
|
||||
.I DPCE="VIT" S DFIEN=$P($G(^GMRD(120.51,DFIEN,0)),U,7)
|
||||
.;Done Elsewhere (historical)
|
||||
.S DHIS=$$AHIS(DITEM)
|
||||
.;Dialog Group
|
||||
.I DTYP="G" D GROUP(DITEM,DSUB) Q
|
||||
.;Dialog type/text and resolution
|
||||
.S OCNT=OCNT+1,DDIS="S"
|
||||
.I DSUPP=1 S DDIS="D"
|
||||
.S ORY(OCNT)=1_U_DITEM_U_DSUB_U_DDIS_U_DEXC_U_U_U_DHIS_U_DMHEX_U_DRESL
|
||||
.N LAST,TEXT
|
||||
.S SUB=0,LAST=0 F S SUB=$O(DTXT(SUB)) Q:'SUB D
|
||||
..D TXT
|
||||
..S OCNT=OCNT+1,ORY(OCNT)=2_U_DITEM_U_DSUB_U_TEXT
|
||||
Q
|
||||
;
|
||||
TAX(TXIEN,ARRAY) ;Return list of resolutions/codes for taxonomy
|
||||
N CNT,DTXT,FNODE,RSUB,TDX,TNAME,TPAR,TPR,TYP
|
||||
N TCUR,TDTXT,TDHTXT,THIS,TPTXT,TPHTXT
|
||||
;
|
||||
;Get taxonomy name
|
||||
S TNAME=$P($G(^PXD(811.2,TXIEN,0)),U,1)
|
||||
;
|
||||
;Check what type of taxonomy codes exist
|
||||
S TDX=$$TOK^PXRMDLLA(TXIEN,"SDX")
|
||||
S TPR=$$TOK^PXRMDLLA(TXIEN,"SPR")
|
||||
;
|
||||
;Taxonomy dialog text
|
||||
S DTXT=$P($G(^PXD(811.2,TXIEN,0)),U,3)
|
||||
;default to taxonomy description if null
|
||||
I DTXT="" S DTXT=$P($G(^PXD(811.2,TXIEN,0)),U,2)
|
||||
;default to taxonomy name if null
|
||||
I DTXT="" S DTXT=$P($G(^PXD(811.2,TXIEN,0)),U,1)
|
||||
;
|
||||
S CNT=0,ARRAY=DTXT
|
||||
;
|
||||
;Diagnoses
|
||||
I TDX D
|
||||
.;Diagnosis texts
|
||||
.S TPAR=$G(^PXD(811.2,TXIEN,"SDZ"))
|
||||
.;Get parameter file node for this finding type
|
||||
.S FNODE=$O(^PXRMD(801.45,"B","POV","")) Q:FNODE=""
|
||||
.;check if finding parameters are disabled
|
||||
.S TCUR=$P($G(^PXRMD(801.45,FNODE,1,1,0)),U,2)
|
||||
.S THIS=$P($G(^PXRMD(801.45,FNODE,1,2,0)),U,2)
|
||||
.;get category text (diagnoses)
|
||||
.I 'TCUR D ; Current
|
||||
..S TDTXT=$P(TPAR,U,2) S:TDTXT="" TDTXT=TNAME
|
||||
..S CNT=CNT+1,ARRAY(CNT)=TDTXT_U_80_U_1_U_"POV"
|
||||
.I 'THIS D ; Historical
|
||||
..S TDHTXT=$P(TPAR,U,3) S:TDHTXT="" TDHTXT=TNAME_" (HISTORICAL)"
|
||||
..S CNT=CNT+1,ARRAY(CNT)=TDHTXT_U_80_U_2_U_"POV"
|
||||
;Procedures
|
||||
I TPR D
|
||||
.;Procedure texts
|
||||
.S TPAR=$G(^PXD(811.2,TXIEN,"SPZ"))
|
||||
.;Get parameter file node for this finding type
|
||||
.S FNODE=$O(^PXRMD(801.45,"B","CPT","")) Q:FNODE=""
|
||||
.;check if finding parameters are disabled
|
||||
.S TCUR=$P($G(^PXRMD(801.45,FNODE,1,1,0)),U,2)
|
||||
.S THIS=$P($G(^PXRMD(801.45,FNODE,1,2,0)),U,2)
|
||||
.;get category text (procedures)
|
||||
.I 'TCUR D ; Current
|
||||
..S TPTXT=$P(TPAR,U,2) S:TPTXT="" TPTXT=TNAME
|
||||
..S CNT=CNT+1,ARRAY(CNT)=TPTXT_U_81_U_1_U_"CPT"
|
||||
.I 'THIS D ; Historical
|
||||
..S TPHTXT=$P(TPAR,U,3) S:TPHTXT="" TPHTXT=TNAME_" (HISTORICAL)"
|
||||
..S CNT=CNT+1,ARRAY(CNT)=TPHTXT_U_81_U_2_U_"CPT"
|
||||
;
|
||||
Q
|
||||
;
|
||||
AHIS(DITEM) ;
|
||||
N RSIEN,RSNAM
|
||||
S RSIEN=$P($G(^PXRMD(801.41,DITEM,1)),U,3)
|
||||
I RSIEN="" Q 0
|
||||
S RSNAM=$P($G(^PXRMD(801.9,RSIEN,0)),U)
|
||||
I RSNAM["DONE ELSEWHERE" Q 1
|
||||
N GUI,PIEN,PFOUND
|
||||
S PIEN=0,PFOUND=0
|
||||
F S PIEN=$O(^PXRMD(801.41,DITEM,10,"D",PIEN)) Q:'PIEN D Q:PFOUND
|
||||
.;Ignore elements and groups
|
||||
.I "EG"[$P($G(^PXRMD(801.41,PIEN,0)),U,4) Q
|
||||
.;GUI Process
|
||||
.S GUI=$P($G(^PXRMD(801.41,PIEN,46)),U) Q:'GUI
|
||||
.;Check if this is PXRM VISIT DATE (or a copy of it)
|
||||
.I $P($G(^PXRMD(801.42,GUI,0)),U)="VST_DATE" S PFOUND=1
|
||||
Q PFOUND
|
||||
|
|
|
|||
|
|
@ -1,240 +1,238 @@
|
|||
PXRMDLLA ;SLC/PJH - REMINDER DIALOG LOADER ;11/08/2007
|
||||
;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
|
||||
;
|
||||
FREC(DFIEN,DFTYP) ;Build type 3 record
|
||||
N CSARRAY,CSCNT
|
||||
;Dialog type/text and resolution
|
||||
S DNAM=$$NAME(DFIEN,DFTYP)
|
||||
D CODE^PXRMDLLB(DFIEN,DFTYP,.CSARRAY)
|
||||
I $D(CSARRAY)>0 D Q
|
||||
. S CSCNT="" F S CSCNT=$O(CSARRAY(CSCNT)) Q:CSCNT="" D
|
||||
. . S OCNT=OCNT+1
|
||||
. . S ORY(OCNT)=3_U_DITEM_U_U_DPCE_U_DEXC_U_DFIEN_U_$G(CSARRAY(CSCNT))_U_DNAM_U_U_DVIT
|
||||
;Translate vitals ien to PCE code - This will need a DBIA
|
||||
S DCOD=""
|
||||
I DPCE="VIT" D
|
||||
.S DFIEN=$$GET1^DIQ(120.51,DFIEN,7,"E")
|
||||
.;Vitals Caption
|
||||
.S DVIT=$P($G(^PXRMD(801.41,DITEM,2)),U,4)
|
||||
I DFTYP]"" D
|
||||
.S OCNT=OCNT+1
|
||||
.S ORY(OCNT)=3_U_DITEM_U_U_DPCE_U_DEXC_U_DFIEN_U_$G(DCOD)_U_DNAM_U_U_DVIT
|
||||
.;Get order type for orderable items
|
||||
.;DBIA #3110
|
||||
.S:DPCE="Q" $P(ORY(OCNT),U,11)=$P($G(^ORD(101.41,DFIEN,0)),U,4)
|
||||
.;If mental health check if a GAF score and if MH test is required
|
||||
.I DPCE="MH",DFIEN D
|
||||
..;DBIA #5044
|
||||
..I $P($G(^YTT(601.71,DFIEN,0)),U)="GAF" S $P(ORY(OCNT),U,12)=1
|
||||
..;Check to see if the MH test is required
|
||||
..S $P(ORY(OCNT),U,13)=+$P($G(^PXRMD(801.41,DITEM,0)),U,18)
|
||||
..I $P(ORY(OCNT),U,13)=2,$$PATCH^XPDUTL("OR*3.0*243")=0 S $P(ORY(OCNT),U,13)=1
|
||||
Q
|
||||
;
|
||||
GUI(IEN) ;Work out prompt type for PCE
|
||||
Q:IEN="" ""
|
||||
N SUB S SUB=$P($G(^PXRMD(801.41,IEN,46)),U)
|
||||
Q:'SUB ""
|
||||
Q $P($G(^PXRMD(801.42,SUB,0)),U)
|
||||
;
|
||||
LOAD(DITEM,DCUR,DTTYP) ;Load dialog questions into array
|
||||
N DARRAY,DCOD,DEXC,DFIND,DFIEN,DFTYP,DNAM,DPCE,DRES,DSEQ,DSUB,DTYP,OCNT
|
||||
N DVIT,NODE,CNT,IDENT
|
||||
;DBIA #3110 OR(101.41
|
||||
;
|
||||
;Build list of PCE codes
|
||||
S DARRAY("AUTTEDT(")="PED"
|
||||
S DARRAY("AUTTEXAM(")="XAM"
|
||||
S DARRAY("AUTTHF(")="HF"
|
||||
S DARRAY("AUTTIMM(")="IMM"
|
||||
S DARRAY("AUTTSK(")="SK"
|
||||
;
|
||||
S DARRAY("GMRD(120.51,")="VIT"
|
||||
S DARRAY("ORD(101.41,")="Q"
|
||||
S DARRAY("YTT(601.71,")="MH"
|
||||
;
|
||||
S DARRAY("ICD9(")="POV"
|
||||
S DARRAY("ICPT(")="CPT"
|
||||
S DARRAY("WV(790.404,")="WH"
|
||||
S DARRAY("WV(790.1,")="WHR"
|
||||
;
|
||||
S DARRAY("PXD(811.2,")="T"
|
||||
;
|
||||
;Get the dialog element
|
||||
S OCNT=0
|
||||
N TERMNODE,TERMSTAT,TERMOUT
|
||||
S DTYP=$P($G(^PXRMD(801.41,DITEM,0)),U,4)
|
||||
;Finding detail
|
||||
S DRES=$P($G(^PXRMD(801.41,DITEM,1)),U,3)
|
||||
S DFIND=$P($G(^PXRMD(801.41,DITEM,1)),U,5)
|
||||
;check for WH finding
|
||||
I $P($G(^PXRMD(801.41,DITEM,0)),U,16)["WHR" S DFIND=$G(WHFIND)
|
||||
;
|
||||
S DFIEN=$P(DFIND,";"),DFTYP=$P(DFIND,";",2)
|
||||
S DPCE="",DVIT="" I DFTYP'="" S DPCE=$G(DARRAY(DFTYP))
|
||||
;Exclude from P/N
|
||||
S DEXC=$P($G(^PXRMD(801.41,DITEM,2)),U,3)
|
||||
;
|
||||
;Non taxonomy codes (3 - finding record)
|
||||
I DPCE'="T" D FREC(DFIEN,DFTYP)
|
||||
;
|
||||
;Taxonomy codes need expanding (3 - finding record)
|
||||
I DPCE="T" D EXP^PXRMDLLB(DFIEN,DCUR,DTTYP)
|
||||
;
|
||||
;Prompt details (4 - prompt records)
|
||||
N ARRAY,DTITLE,DREQ,DSEQ,DSSEQ,DSUB,DTYP
|
||||
;If not a taxonomy get prompts from dialog file
|
||||
I DPCE'="T" D PROTH(DITEM)
|
||||
;Check for MST findings
|
||||
I (DPCE'="T"),(DFTYP]"") D MST^PXRMDLLB(DFTYP,DFIEN)
|
||||
;If taxonomy use finding parameters (CPT/POV)
|
||||
I DPCE="T" D
|
||||
.;Quit if finding type not passed
|
||||
.Q:DTTYP=""
|
||||
.N RSUB,FNODE
|
||||
.;Get parameter file node for this finding type
|
||||
.S FNODE=$O(^PXRMD(801.45,"B",DTTYP,"")) Q:FNODE=""
|
||||
.;Derive resolution from line ien 1=done 2=done elsewhere
|
||||
.S RSUB=DCUR+1 I (RSUB<1)!(RSUB>2) Q
|
||||
.;Get details from 811.5
|
||||
.D PRTAX(FNODE,RSUB)
|
||||
;Return array of type 4 records
|
||||
S DSEQ=""
|
||||
F S DSEQ=$O(ARRAY(DSEQ)) Q:'DSEQ D
|
||||
.S OCNT=OCNT+1
|
||||
.S ORY(OCNT)=4_U_DITEM_U_DSEQ_U_ARRAY(DSEQ)
|
||||
.S DSSEQ=""
|
||||
.F S DSSEQ=$O(ARRAY(DSEQ,DSSEQ)) Q:'DSSEQ D
|
||||
..S OCNT=OCNT+1
|
||||
..S ORY(OCNT)=4_U_DITEM_U_DSEQ_"."_DSSEQ_U_ARRAY(DSEQ,DSSEQ)
|
||||
;
|
||||
;Get progress note text if defined
|
||||
I DPCE'="T" D:'DEXC PTXT(DITEM)
|
||||
;Additional findings
|
||||
N FASUB
|
||||
S FASUB=0
|
||||
F S FASUB=$O(^PXRMD(801.41,DITEM,3,FASUB)) Q:'FASUB D
|
||||
.S DFIND=$P($G(^PXRMD(801.41,DITEM,3,FASUB,0)),U)
|
||||
.S DFIEN=$P(DFIND,";"),DFTYP=$P(DFIND,";",2) Q:DFTYP="" Q:DFIEN=""
|
||||
.S DVIT="",DPCE=$G(DARRAY(DFTYP))
|
||||
.I DPCE'="" D FREC(DFIEN,DFTYP)
|
||||
Q
|
||||
;
|
||||
;
|
||||
;Returns item name
|
||||
NAME(DFIEN,DFTYP) ;
|
||||
Q:DFTYP="" ""
|
||||
Q:DFIEN="" ""
|
||||
N NAME,FGLOB,POSN
|
||||
;DBIA #4108
|
||||
I DFTYP="WV(790.404," S NAME=$P($G(^WV(790.404,DFIEN,0)),U) Q:NAME]"" NAME
|
||||
I DFTYP="WV(790.1," S NAME=$G(WHNAME) K WHNAME Q:NAME]"" NAME
|
||||
S POSN=2
|
||||
S:DFTYP["AUTT" POSN=1 S:DFTYP["AUTTEDT" POSN=4 S:DFTYP["ICD" POSN=3
|
||||
S FGLOB=U_DFTYP_DFIEN_",0)",NAME=$P($G(@FGLOB),U,POSN)
|
||||
I (POSN>1),NAME="" S NAME=$P($G(@FGLOB),U)
|
||||
I NAME="" S NAME=DFIEN
|
||||
Q NAME
|
||||
;
|
||||
PROTH(IEN) ; Additional prompts defined in 801.41
|
||||
N DDATA,DDEF,DIEN,DEXC,DGUI,DNAME,DOVR,DREQ,DSEQ,DSNL,DSUB,DFTEXT
|
||||
N DTXT,DTYP,PRINT
|
||||
S DSEQ=0
|
||||
F S DSEQ=$O(^PXRMD(801.41,IEN,10,"B",DSEQ)) Q:'DSEQ D
|
||||
.;Get prompts in sequence
|
||||
.S DSUB=$O(^PXRMD(801.41,IEN,10,"B",DSEQ,"")) Q:'DSUB
|
||||
.;Prompt ien
|
||||
.S DIEN=$P($G(^PXRMD(801.41,IEN,10,DSUB,0)),U,2) Q:'DIEN
|
||||
.;Ignore disabled components, and those that are not prompts
|
||||
.Q:($P($G(^PXRMD(801.41,DIEN,0)),U,3)]"")!("PF"'[$P($G(^(0)),U,4))
|
||||
.;Set defaults to null
|
||||
.S DDEF="",DEXC="",DREQ="",DSNL=""
|
||||
.;Prompt name and GUI process (quit if null)
|
||||
.S DNAME=$P($G(^PXRMD(801.41,DIEN,0)),U),DGUI=$$GUI(DIEN)
|
||||
.I $G(DGUI)="WH_NOT_PURP" D
|
||||
..S PRINT=$$GET^XPAR($G(DUZ)_";VA(200,^SRV.`"_+$G(SRV)_"^DIV^SYS","PXRM WH PRINT NOW",1,"I")
|
||||
.;Type Prompt or Forced
|
||||
.S DTYP=$P($G(^PXRMD(801.41,DIEN,0)),U,4)
|
||||
.I "PF"[DTYP D
|
||||
..;Required/Prompt caption
|
||||
..S DDATA=$G(^PXRMD(801.41,DIEN,2)),DTXT=$P(DDATA,U,4)
|
||||
..;Default value or forced value
|
||||
..S:DTYP="P" DDEF=$P(DDATA,U) S:DTYP="F" DDEF=$P(DDATA,U,2)
|
||||
..;Override caption/start new line/exclude PN from dialog file
|
||||
..S DDATA=$G(^PXRMD(801.41,IEN,10,DSUB,0)),DREQ=$P(DDATA,U,9)
|
||||
..S DOVR=$P(DDATA,U,6),DSNL=$P(DDATA,U,7),DEXC=$P(DDATA,U,8)
|
||||
..S DNAME=DTXT I DOVR]"" S DNAME=DOVR
|
||||
..;Convert date to fileman format
|
||||
..I DGUI="VST_DATE",DDEF["T" S DDEF=$$DT^XLFDT()
|
||||
.S ARRAY(DSEQ)=DGUI_U_DEXC_U_DDEF_U_DTYP_U_DNAME_U_DSNL_U_DREQ_U_$G(DFTEXT)_U_$G(PRINT)
|
||||
.;the following section add a comment prompt to the WH review of result
|
||||
.;section of the reminder dialog
|
||||
.I DGUI="WH_PAP_RESULT",DFTYP="WV(790.1,",DTYP="P" D
|
||||
..N WHCNT,WHFLAG,WHNUM,WHLOOP
|
||||
..S WHNUM=DSEQ+1,WHLOOP=0
|
||||
..F WHLOOP=0 D
|
||||
...S (WHCNT,WHFLAG)=0
|
||||
...F S WHCNT=$O(^PXRMD(801.41,IEN,10,"B",WHCNT)) Q:'WHCNT!(WHFLAG=1) D
|
||||
....I WHCNT=WHNUM S WHFLAG=1,WHNUM=WHNUM+1
|
||||
...I WHFLAG=0 S WHLOOP=1
|
||||
..S ARRAY(WHNUM)="COM"_U_U_U_"P"_U_"Comment:"_U_U_U
|
||||
.;Additional checkboxes
|
||||
.I DGUI="COM",DIEN>1 D
|
||||
..N DSSEQ,DSUB,DTEXT
|
||||
..S DSSEQ=0
|
||||
..F S DSSEQ=$O(^PXRMD(801.41,DIEN,45,"B",DSSEQ)) Q:'DSSEQ D
|
||||
...S DSUB=$O(^PXRMD(801.41,DIEN,45,"B",DSSEQ,"")) Q:'DSUB
|
||||
...S DTEXT=$P($G(^PXRMD(801.41,DIEN,45,DSUB,0)),U,2) Q:DTEXT=""
|
||||
...S ARRAY(DSEQ,DSSEQ)=U_DEXC_U_DDEF_U_DTYP_U_DTEXT_U_DSNL_U_DREQ
|
||||
Q
|
||||
;
|
||||
PRTAX(FNODE,RSUB) ;Get all additional fields for this resolution type
|
||||
N ACNT,ASUB
|
||||
N DDATA,DDEF,DEXC,DGUI,DNAME,DREQ,DSEQ,DSUB,DTYP,PRINT
|
||||
S ASUB=0,DSEQ=0
|
||||
F S ASUB=$O(^PXRMD(801.45,FNODE,1,RSUB,5,ASUB)) Q:'ASUB D
|
||||
.S DDATA=$G(^PXRMD(801.45,FNODE,1,RSUB,5,ASUB,0)) Q:DDATA=""
|
||||
.;Ignore if disabled
|
||||
.I $P(DDATA,U,3)=1 Q
|
||||
.S DSUB=$P(DDATA,U) Q:DDATA=""
|
||||
.S DSEQ=DSEQ+1
|
||||
.;Set defaults to null
|
||||
.S DDEF="",DEXC="",DREQ="",DSNL=""
|
||||
.;Prompt name and GUI process (quit if null)
|
||||
.S DNAME=$P($G(^PXRMD(801.41,DSUB,0)),U),DGUI=$$GUI(DSUB)
|
||||
.I $G(DGUI)="WH_NOT_PURP" D
|
||||
..S PRINT=$$GET^XPAR($G(DUZ)_";VA(200,^SRV.`"_+$G(SRV)_"^DIV^SYS","PXRM WH PRINT NOW",1,"I")
|
||||
.;Type Prompt or Forced
|
||||
.S DTYP=$P($G(^PXRMD(801.41,DSUB,0)),U,4)
|
||||
.I DTYP="P" D
|
||||
..S DREQ=$P(DDATA,U,2),DTXT=$P($G(^PXRMD(801.41,DSUB,2)),U,4)
|
||||
..;Override caption/start new line/exclude from PN from finding type
|
||||
..S DOVR=$P(DDATA,U,5),DSNL=$P(DDATA,U,6),DEXC=$P(DDATA,U,7)
|
||||
..S DNAME=DTXT I DOVR]"" S DNAME=DOVR
|
||||
..;Required/Prompt caption
|
||||
..S DDATA=$G(^PXRMD(801.41,DSUB,2))
|
||||
.S ARRAY(DSEQ)=DGUI_U_DEXC_U_DDEF_U_DTYP_U_DNAME_U_DSNL_U_DREQ_U_U_$G(PRINT)
|
||||
Q
|
||||
;
|
||||
PTXT(ITEM) ;Get progress note (WP) text for type 6 records
|
||||
N ARRAY,LAST,NULL,SUB,TEXT,TXTCNT
|
||||
S SUB=0
|
||||
F S SUB=$O(^PXRMD(801.41,ITEM,35,SUB)) Q:'SUB D
|
||||
.S ARRAY(SUB)=$G(^PXRMD(801.41,ITEM,35,SUB,0))
|
||||
S SUB=0,LAST=0 F S SUB=$O(ARRAY(SUB)) Q:'SUB D
|
||||
.S TEXT=$G(ARRAY(SUB))
|
||||
.S NULL=0 I (TEXT="")!($E(TEXT)=" ") S NULL=1
|
||||
.I LAST,'NULL S TEXT="<br>"_TEXT
|
||||
.S TEXT=$$STRREP^PXRMUTIL(TEXT,"\\","<br>")
|
||||
.S LAST=0 I NULL S TEXT="<br>"_TEXT,LAST=1
|
||||
.S OCNT=OCNT+1,ORY(OCNT)=6_U_ITEM_U_U_TEXT
|
||||
Q
|
||||
;
|
||||
TOK(TIEN,TYPE) ;Check if selectable codes exist
|
||||
N DATA,FOUND,SUB
|
||||
S FOUND=0,SUB=0
|
||||
F S SUB=$O(^PXD(811.2,TIEN,TYPE,SUB)) Q:'SUB D Q:FOUND
|
||||
.S DATA=$G(^PXD(811.2,TIEN,TYPE,SUB,0)) Q:DATA=""
|
||||
.;Ignore disabled codes
|
||||
.I '$P(DATA,U,3) S FOUND=1
|
||||
Q FOUND
|
||||
PXRMDLLA ;SLC/PJH - REMINDER DIALOG LOADER ;07/29/2004
|
||||
;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
|
||||
;
|
||||
FREC(DFIEN,DFTYP) ;Build type 3 record
|
||||
N CSARRAY,CSCNT
|
||||
;Dialog type/text and resolution
|
||||
S DNAM=$$NAME(DFIEN,DFTYP)
|
||||
D CODE^PXRMDLLB(DFIEN,DFTYP,.CSARRAY)
|
||||
I $D(CSARRAY)>0 D Q
|
||||
. S CSCNT="" F S CSCNT=$O(CSARRAY(CSCNT)) Q:CSCNT="" D
|
||||
. . S OCNT=OCNT+1
|
||||
. . S ORY(OCNT)=3_U_DITEM_U_U_DPCE_U_DEXC_U_DFIEN_U_$G(CSARRAY(CSCNT))_U_DNAM_U_U_DVIT
|
||||
;Translate vitals ien to PCE code - This will need a DBIA
|
||||
S DCOD=""
|
||||
I DPCE="VIT" D
|
||||
.S DFIEN=$$GET1^DIQ(120.51,DFIEN,7,"E")
|
||||
.;Vitals Caption
|
||||
.S DVIT=$P($G(^PXRMD(801.41,DITEM,2)),U,4)
|
||||
I DFTYP]"" D
|
||||
.S OCNT=OCNT+1
|
||||
.S ORY(OCNT)=3_U_DITEM_U_U_DPCE_U_DEXC_U_DFIEN_U_$G(DCOD)_U_DNAM_U_U_DVIT
|
||||
.;Get order type for orderable items
|
||||
.;DBIA #3110
|
||||
.S:DPCE="Q" $P(ORY(OCNT),U,11)=$P($G(^ORD(101.41,DFIEN,0)),U,4)
|
||||
.;If mental health check if a GAF score and if MH test is required
|
||||
.I DPCE="MH",DFIEN D
|
||||
..I $P($G(^YTT(601,DFIEN,0)),U)="GAF" S $P(ORY(OCNT),U,12)=1
|
||||
..;Check to see if the MH test is required
|
||||
..S $P(ORY(OCNT),U,13)=$S($P($G(^PXRMD(801.41,DITEM,0)),U,18)=1:1,1:0)
|
||||
Q
|
||||
;
|
||||
GUI(IEN) ;Work out prompt type for PCE
|
||||
Q:IEN="" ""
|
||||
N SUB S SUB=$P($G(^PXRMD(801.41,IEN,46)),U)
|
||||
Q:'SUB ""
|
||||
Q $P($G(^PXRMD(801.42,SUB,0)),U)
|
||||
;
|
||||
LOAD(DITEM,DCUR,DTTYP) ;Load dialog questions into array
|
||||
N DARRAY,DCOD,DEXC,DFIND,DFIEN,DFTYP,DNAM,DPCE,DRES,DSEQ,DSUB,DTYP,OCNT
|
||||
N DVIT,NODE,CNT,IDENT
|
||||
;DBIA #3110 OR(101.41
|
||||
;
|
||||
;Build list of PCE codes
|
||||
S DARRAY("AUTTEDT(")="PED"
|
||||
S DARRAY("AUTTEXAM(")="XAM"
|
||||
S DARRAY("AUTTHF(")="HF"
|
||||
S DARRAY("AUTTIMM(")="IMM"
|
||||
S DARRAY("AUTTSK(")="SK"
|
||||
;
|
||||
S DARRAY("GMRD(120.51,")="VIT"
|
||||
S DARRAY("ORD(101.41,")="Q"
|
||||
S DARRAY("YTT(601,")="MH"
|
||||
;
|
||||
S DARRAY("ICD9(")="POV"
|
||||
S DARRAY("ICPT(")="CPT"
|
||||
S DARRAY("WV(790.404,")="WH"
|
||||
S DARRAY("WV(790.1,")="WHR"
|
||||
;
|
||||
S DARRAY("PXD(811.2,")="T"
|
||||
;
|
||||
;Get the dialog element
|
||||
S OCNT=0
|
||||
N TERMNODE,TERMSTAT,TERMOUT
|
||||
S DTYP=$P($G(^PXRMD(801.41,DITEM,0)),U,4)
|
||||
;Finding detail
|
||||
S DRES=$P($G(^PXRMD(801.41,DITEM,1)),U,3)
|
||||
S DFIND=$P($G(^PXRMD(801.41,DITEM,1)),U,5)
|
||||
;check for WH finding
|
||||
I $P($G(^PXRMD(801.41,DITEM,0)),U,16)["WHR" S DFIND=$G(WHFIND)
|
||||
;
|
||||
S DFIEN=$P(DFIND,";"),DFTYP=$P(DFIND,";",2)
|
||||
S DPCE="",DVIT="" I DFTYP'="" S DPCE=$G(DARRAY(DFTYP))
|
||||
;Exclude from P/N
|
||||
S DEXC=$P($G(^PXRMD(801.41,DITEM,2)),U,3)
|
||||
;
|
||||
;Non taxonomy codes (3 - finding record)
|
||||
I DPCE'="T" D FREC(DFIEN,DFTYP)
|
||||
;
|
||||
;Taxonomy codes need expanding (3 - finding record)
|
||||
I DPCE="T" D EXP^PXRMDLLB(DFIEN,DCUR,DTTYP)
|
||||
;
|
||||
;Prompt details (4 - prompt records)
|
||||
N ARRAY,DTITLE,DREQ,DSEQ,DSSEQ,DSUB,DTYP
|
||||
;If not a taxonomy get prompts from dialog file
|
||||
I DPCE'="T" D PROTH(DITEM)
|
||||
;Check for MST findings
|
||||
I (DPCE'="T"),(DFTYP]"") D MST^PXRMDLLB(DFTYP,DFIEN)
|
||||
;If taxonomy use finding parameters (CPT/POV)
|
||||
I DPCE="T" D
|
||||
.;Quit if finding type not passed
|
||||
.Q:DTTYP=""
|
||||
.N RSUB,FNODE
|
||||
.;Get parameter file node for this finding type
|
||||
.S FNODE=$O(^PXRMD(801.45,"B",DTTYP,"")) Q:FNODE=""
|
||||
.;Derive resolution from line ien 1=done 2=done elsewhere
|
||||
.S RSUB=DCUR+1 I (RSUB<1)!(RSUB>2) Q
|
||||
.;Get details from 811.5
|
||||
.D PRTAX(FNODE,RSUB)
|
||||
;Return array of type 4 records
|
||||
S DSEQ=""
|
||||
F S DSEQ=$O(ARRAY(DSEQ)) Q:'DSEQ D
|
||||
.S OCNT=OCNT+1
|
||||
.S ORY(OCNT)=4_U_DITEM_U_DSEQ_U_ARRAY(DSEQ)
|
||||
.S DSSEQ=""
|
||||
.F S DSSEQ=$O(ARRAY(DSEQ,DSSEQ)) Q:'DSSEQ D
|
||||
..S OCNT=OCNT+1
|
||||
..S ORY(OCNT)=4_U_DITEM_U_DSEQ_"."_DSSEQ_U_ARRAY(DSEQ,DSSEQ)
|
||||
;
|
||||
;Get progress note text if defined
|
||||
I DPCE'="T" D:'DEXC PTXT(DITEM)
|
||||
;Additional findings
|
||||
N FASUB
|
||||
S FASUB=0
|
||||
F S FASUB=$O(^PXRMD(801.41,DITEM,3,FASUB)) Q:'FASUB D
|
||||
.S DFIND=$P($G(^PXRMD(801.41,DITEM,3,FASUB,0)),U)
|
||||
.S DFIEN=$P(DFIND,";"),DFTYP=$P(DFIND,";",2) Q:DFTYP="" Q:DFIEN=""
|
||||
.S DVIT="",DPCE=$G(DARRAY(DFTYP))
|
||||
.I DPCE'="" D FREC(DFIEN,DFTYP)
|
||||
Q
|
||||
;
|
||||
;
|
||||
;Returns item name
|
||||
NAME(DFIEN,DFTYP) ;
|
||||
Q:DFTYP="" ""
|
||||
Q:DFIEN="" ""
|
||||
N NAME,FGLOB,POSN
|
||||
;DBIA #4108
|
||||
I DFTYP="WV(790.404," S NAME=$P($G(^WV(790.404,DFIEN,0)),U) Q:NAME]"" NAME
|
||||
I DFTYP="WV(790.1," S NAME=$G(WHNAME) K WHNAME Q:NAME]"" NAME
|
||||
S POSN=2
|
||||
S:DFTYP["AUTT" POSN=1 S:DFTYP["AUTTEDT" POSN=4 S:DFTYP["ICD" POSN=3
|
||||
S FGLOB=U_DFTYP_DFIEN_",0)",NAME=$P($G(@FGLOB),U,POSN)
|
||||
I (POSN>1),NAME="" S NAME=$P($G(@FGLOB),U)
|
||||
I NAME="" S NAME=DFIEN
|
||||
Q NAME
|
||||
;
|
||||
PROTH(IEN) ; Additional prompts defined in 801.41
|
||||
N DDATA,DDEF,DIEN,DEXC,DGUI,DNAME,DOVR,DREQ,DSEQ,DSNL,DSUB,DFTEXT
|
||||
N DTXT,DTYP,PRINT
|
||||
S DSEQ=0
|
||||
F S DSEQ=$O(^PXRMD(801.41,IEN,10,"B",DSEQ)) Q:'DSEQ D
|
||||
.;Get prompts in sequence
|
||||
.S DSUB=$O(^PXRMD(801.41,IEN,10,"B",DSEQ,"")) Q:'DSUB
|
||||
.;Prompt ien
|
||||
.S DIEN=$P($G(^PXRMD(801.41,IEN,10,DSUB,0)),U,2) Q:'DIEN
|
||||
.;Ignore disabled components, and those that are not prompts
|
||||
.Q:($P($G(^PXRMD(801.41,DIEN,0)),U,3)]"")!("PF"'[$P($G(^(0)),U,4))
|
||||
.;Set defaults to null
|
||||
.S DDEF="",DEXC="",DREQ="",DSNL=""
|
||||
.;Prompt name and GUI process (quit if null)
|
||||
.S DNAME=$P($G(^PXRMD(801.41,DIEN,0)),U),DGUI=$$GUI(DIEN)
|
||||
.I $G(DGUI)="WH_NOT_PURP" D
|
||||
..S PRINT=$$GET^XPAR($G(DUZ)_";VA(200,^SRV.`"_+$G(SRV)_"^DIV^SYS","PXRM WH PRINT NOW",1,"I")
|
||||
.;Type Prompt or Forced
|
||||
.S DTYP=$P($G(^PXRMD(801.41,DIEN,0)),U,4)
|
||||
.I "PF"[DTYP D
|
||||
..;Required/Prompt caption
|
||||
..S DDATA=$G(^PXRMD(801.41,DIEN,2)),DTXT=$P(DDATA,U,4)
|
||||
..;Default value or forced value
|
||||
..S:DTYP="P" DDEF=$P(DDATA,U) S:DTYP="F" DDEF=$P(DDATA,U,2)
|
||||
..;Override caption/start new line/exclude PN from dialog file
|
||||
..S DDATA=$G(^PXRMD(801.41,IEN,10,DSUB,0)),DREQ=$P(DDATA,U,9)
|
||||
..S DOVR=$P(DDATA,U,6),DSNL=$P(DDATA,U,7),DEXC=$P(DDATA,U,8)
|
||||
..S DNAME=DTXT I DOVR]"" S DNAME=DOVR
|
||||
..;Convert date to fileman format
|
||||
..I DGUI="VST_DATE",DDEF["T" S DDEF=$$DT^XLFDT()
|
||||
.S ARRAY(DSEQ)=DGUI_U_DEXC_U_DDEF_U_DTYP_U_DNAME_U_DSNL_U_DREQ_U_$G(DFTEXT)_U_$G(PRINT)
|
||||
.;the following section add a comment prompt to the WH review of result
|
||||
.;section of the reminder dialog
|
||||
.I DGUI="WH_PAP_RESULT",DFTYP="WV(790.1,",DTYP="P" D
|
||||
..N WHCNT,WHFLAG,WHNUM,WHLOOP
|
||||
..S WHNUM=DSEQ+1,WHLOOP=0
|
||||
..F WHLOOP=0 D
|
||||
...S (WHCNT,WHFLAG)=0
|
||||
...F S WHCNT=$O(^PXRMD(801.41,IEN,10,"B",WHCNT)) Q:'WHCNT!(WHFLAG=1) D
|
||||
....I WHCNT=WHNUM S WHFLAG=1,WHNUM=WHNUM+1
|
||||
...I WHFLAG=0 S WHLOOP=1
|
||||
..S ARRAY(WHNUM)="COM"_U_U_U_"P"_U_"Comment:"_U_U_U
|
||||
.;Additional checkboxes
|
||||
.I DGUI="COM",DIEN>1 D
|
||||
..N DSSEQ,DSUB,DTEXT
|
||||
..S DSSEQ=0
|
||||
..F S DSSEQ=$O(^PXRMD(801.41,DIEN,45,"B",DSSEQ)) Q:'DSSEQ D
|
||||
...S DSUB=$O(^PXRMD(801.41,DIEN,45,"B",DSSEQ,"")) Q:'DSUB
|
||||
...S DTEXT=$P($G(^PXRMD(801.41,DIEN,45,DSUB,0)),U,2) Q:DTEXT=""
|
||||
...S ARRAY(DSEQ,DSSEQ)=U_DEXC_U_DDEF_U_DTYP_U_DTEXT_U_DSNL_U_DREQ
|
||||
Q
|
||||
;
|
||||
PRTAX(FNODE,RSUB) ;Get all additional fields for this resolution type
|
||||
N ACNT,ASUB
|
||||
N DDATA,DDEF,DEXC,DGUI,DNAME,DREQ,DSEQ,DSUB,DTYP,PRINT
|
||||
S ASUB=0,DSEQ=0
|
||||
F S ASUB=$O(^PXRMD(801.45,FNODE,1,RSUB,5,ASUB)) Q:'ASUB D
|
||||
.S DDATA=$G(^PXRMD(801.45,FNODE,1,RSUB,5,ASUB,0)) Q:DDATA=""
|
||||
.;Ignore if disabled
|
||||
.I $P(DDATA,U,3)=1 Q
|
||||
.S DSUB=$P(DDATA,U) Q:DDATA=""
|
||||
.S DSEQ=DSEQ+1
|
||||
.;Set defaults to null
|
||||
.S DDEF="",DEXC="",DREQ="",DSNL=""
|
||||
.;Prompt name and GUI process (quit if null)
|
||||
.S DNAME=$P($G(^PXRMD(801.41,DSUB,0)),U),DGUI=$$GUI(DSUB)
|
||||
.I $G(DGUI)="WH_NOT_PURP" D
|
||||
..S PRINT=$$GET^XPAR($G(DUZ)_";VA(200,^SRV.`"_+$G(SRV)_"^DIV^SYS","PXRM WH PRINT NOW",1,"I")
|
||||
.;Type Prompt or Forced
|
||||
.S DTYP=$P($G(^PXRMD(801.41,DSUB,0)),U,4)
|
||||
.I DTYP="P" D
|
||||
..S DREQ=$P(DDATA,U,2),DTXT=$P($G(^PXRMD(801.41,DSUB,2)),U,4)
|
||||
..;Override caption/start new line/exclude from PN from finding type
|
||||
..S DOVR=$P(DDATA,U,5),DSNL=$P(DDATA,U,6),DEXC=$P(DDATA,U,7)
|
||||
..S DNAME=DTXT I DOVR]"" S DNAME=DOVR
|
||||
..;Required/Prompt caption
|
||||
..S DDATA=$G(^PXRMD(801.41,DSUB,2))
|
||||
.S ARRAY(DSEQ)=DGUI_U_DEXC_U_DDEF_U_DTYP_U_DNAME_U_DSNL_U_DREQ_U_U_$G(PRINT)
|
||||
Q
|
||||
;
|
||||
PTXT(ITEM) ;Get progress note (WP) text for type 6 records
|
||||
N ARRAY,LAST,NULL,SUB,TEXT,TXTCNT
|
||||
S SUB=0
|
||||
F S SUB=$O(^PXRMD(801.41,ITEM,35,SUB)) Q:'SUB D
|
||||
.S ARRAY(SUB)=$G(^PXRMD(801.41,ITEM,35,SUB,0))
|
||||
S SUB=0,LAST=0 F S SUB=$O(ARRAY(SUB)) Q:'SUB D
|
||||
.S TEXT=$G(ARRAY(SUB))
|
||||
.S NULL=0 I (TEXT="")!($E(TEXT)=" ") S NULL=1
|
||||
.I LAST,'NULL S TEXT="<br>"_TEXT
|
||||
.S TEXT=$$STRREP^PXRMUTIL(TEXT,"\\","<br>")
|
||||
.S LAST=0 I NULL S TEXT="<br>"_TEXT,LAST=1
|
||||
.S OCNT=OCNT+1,ORY(OCNT)=6_U_ITEM_U_U_TEXT
|
||||
Q
|
||||
;
|
||||
TOK(TIEN,TYPE) ;Check if selectable codes exist
|
||||
N DATA,FOUND,SUB
|
||||
S FOUND=0,SUB=0
|
||||
F S SUB=$O(^PXD(811.2,TIEN,TYPE,SUB)) Q:'SUB D Q:FOUND
|
||||
.S DATA=$G(^PXD(811.2,TIEN,TYPE,SUB,0)) Q:DATA=""
|
||||
.;Ignore disabled codes
|
||||
.I '$P(DATA,U,3) S FOUND=1
|
||||
Q FOUND
|
||||
|
|
|
|||
|
|
@ -1,168 +1,156 @@
|
|||
PXRMDLLB ;SLC/PJH - REMINDER DIALOG LOADER ;05/01/2007
|
||||
;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
|
||||
;
|
||||
CODE(DFIEN,DFTYP,ARRAY) ;
|
||||
N ARY,CNT,CNT1
|
||||
I DFTYP["ICD9" S CODE=$P($G(^ICD9(DFIEN,0)),U) D PERIOD^ICDAPIU(CODE,.ARY)
|
||||
I DFTYP["ICPT" S CODE=$P($$CPT^ICPTCOD(DFIEN),U,2) D PERIOD^ICPTAPIU(CODE,.ARY)
|
||||
I $D(ARY)'>0 Q
|
||||
I $P($G(ARY(0)),U,2)'>0 Q
|
||||
S (CNT,CNT1)=0
|
||||
F S CNT=$O(ARY(CNT)) Q:CNT="" D
|
||||
. S ARRAY(CNT1)=CODE_":"_CNT_":"_$P($G(ARY(CNT)),U)
|
||||
. S CNT1=CNT1+1
|
||||
Q
|
||||
;
|
||||
CODES(FILE,TXIEN,ARRAY) ;Return selectable codes from taxonomy file
|
||||
N CNT,CODE,CSCNT,DATA,DATES,DISPLAY,IEN,INSTALL,TEMP,TEXT,NODE,SUB
|
||||
S SUB=0,CNT=0,NODE=$S(FILE=80:"SDX",FILE=81:"SPR")
|
||||
F S SUB=$O(^PXD(811.2,TXIEN,NODE,SUB)) Q:'SUB D
|
||||
.S DATA=$G(^PXD(811.2,TXIEN,NODE,SUB,0)) Q:DATA=""
|
||||
.;Ignore if disabled
|
||||
.S DISPLAY=""
|
||||
.I $P(DATA,U,3)=1 Q
|
||||
.;Get ien of code
|
||||
.S IEN=$P(DATA,U) Q:IEN=""
|
||||
.;get date ranges and text from period api
|
||||
.K ARY
|
||||
.I FILE=80 S CODE=$P($G(^ICD9(IEN,0)),U)
|
||||
.I FILE=81 S CODE=$P($$CPT^ICPTCOD(IEN),U,2)
|
||||
.S DISPLAY=$P($G(DATA),U,2)
|
||||
.S TEMP=$$CODE^PXRMVAL(CODE,FILE) Q:'$P(TEMP,U) Q:$P(TEMP,U,9)=1
|
||||
.;Set display text from taxonomy selectable code text
|
||||
.S TEXT=$P(DATA,U,2)
|
||||
.;otherwise use icd9/cpt description
|
||||
.I TEXT="",FILE=80 S TEXT=$P($$ICDDX^ICDCODE(IEN),U,3)
|
||||
.I TEXT="",FILE=81 S TEXT=$P($$CPT^ICPTCOD(IEN),U,3)
|
||||
.I FILE=80 D PERIOD^ICDAPIU(CODE,.ARY)
|
||||
.I FILE=81 D PERIOD^ICPTAPIU(CODE,.ARY)
|
||||
.I $D(ARY)'>0 Q
|
||||
.I $P($G(ARY(0)),U,2)'>0 Q
|
||||
.S CSCNT=0 F S CSCNT=$O(ARY(CSCNT)) Q:CSCNT="" D
|
||||
..S DATES=":"_CSCNT_":"_$P($G(ARY(CSCNT)),U)
|
||||
..S TEXT=$P($G(ARY(CSCNT)),U,2) I $G(DISPLAY)'="" S TEXT=DISPLAY
|
||||
..S CNT=CNT+1,ARRAY(CNT)=IEN_U_$G(CODE)_$G(DATES)_U_$G(TEXT)
|
||||
Q
|
||||
;
|
||||
EXP(TIEN,DCUR,DTTYP) ;Expand taxonomy codes
|
||||
N CODES,CNT,FILE,LIT,CAT
|
||||
S FILE=$S(DTTYP="POV":80,DTTYP="CPT":81,1:"") Q:'FILE
|
||||
S LIT="Selectable "_$S(FILE=80:"Diagnoses:",1:"Procedures:")
|
||||
S CAT=$P($G(^PXD(811.2,TIEN,0)),U)
|
||||
;
|
||||
S OCNT=OCNT+1
|
||||
S ORY(OCNT)=3_U_DITEM_U_U_DTTYP_U_U_U_U_U_CAT_U_LIT
|
||||
;Get selectable codes
|
||||
D CODES(FILE,TIEN,.CODES)
|
||||
S CNT=0
|
||||
;Save selectable codes as type 5 records
|
||||
F S CNT=$O(CODES(CNT)) Q:'CNT D
|
||||
.S OCNT=OCNT+1,ORY(OCNT)=5_U_DITEM_U_U_DTTYP_U_U_CODES(CNT)
|
||||
Q
|
||||
;
|
||||
;Pass MST code as a forced value
|
||||
MST(DFTYP,DFIEN) ;
|
||||
;Validate finding ien
|
||||
Q:DFIEN=""
|
||||
;For each MST term check if finding is mapped
|
||||
N FOUND,TCOND,TIEN,TNAM,TSUB
|
||||
S FOUND=0
|
||||
F TNAM="POSITIVE","NEGATIVE","DECLINES" D Q:FOUND
|
||||
.;Get term IEN
|
||||
.S TIEN=$O(^PXRMD(811.5,"B","MST "_TNAM_" REPORT","")) Q:'TIEN
|
||||
.;Check if finding is mapped to term
|
||||
.Q:'$D(^PXRMD(811.5,TIEN,20,"E",DFTYP,DFIEN))
|
||||
.;If exam and term condition logic is null ignore
|
||||
.I DFTYP="AUTTEXAM(" D Q:TCOND=""
|
||||
..S TCOND="",TSUB=$O(^PXRMD(811.5,TIEN,20,"E",DFTYP,DFIEN,"")) Q:'TSUB
|
||||
..S TCOND=$P($G(^PXRMD(811.5,TIEN,20,TSUB,3)),U)
|
||||
.;If it is then create additional prompt for MST
|
||||
.N DSEQ,DEXC,DDEF,DGUI,DTYP,DTEXT,DSNL,DREQ
|
||||
.;Add to end of array
|
||||
.S DSEQ=$O(ARRAY(""),-1)+1
|
||||
.;Null fields
|
||||
.S DDEF="",DEXC="",DTEXT="",DSNL="",DREQ=""
|
||||
.;MST status (exept for exams)
|
||||
.I DFTYP'="AUTTEXAM(" S DDEF=$$STCODE^PXRMMST("MST "_TNAM_" REPORT")
|
||||
.;GUI process and forced value
|
||||
.S DGUI="MST",DTYP="F"
|
||||
.;Save in array
|
||||
.S ARRAY(DSEQ)=DGUI_U_DEXC_U_DDEF_U_DTYP_U_DTEXT_U_DSNL_U_DREQ
|
||||
.;Quit after the first term is found
|
||||
.S FOUND=1
|
||||
Q
|
||||
;
|
||||
REPLACE(DFN,TERMNODE,DITEM,DATA,TERMSTAT) ;
|
||||
;this section is use to compare the term evalution result against
|
||||
;the value store in the Reminder Term Status field.
|
||||
;If the value match and the replacement item is active then the orginal
|
||||
;item will be replace with the new item.
|
||||
N TERMOUT
|
||||
S TERMSTAT=1 I +$P(TERMNODE,U),$P($G(TERMNODE),U,2)'="" D Q:+TERMSTAT=0
|
||||
.N DITEMO
|
||||
.S TERMOUT=$$TERM($P(TERMNODE,U),DFN,$G(DITEM))
|
||||
.I TERMOUT'=$P(TERMNODE,U,2) Q
|
||||
.I +$P(TERMNODE,U,3)'>0 S TERMSTAT=0 Q
|
||||
.S DITEMO=DITEM,DITEM=$P(TERMNODE,U,3),DATA=$G(^PXRMD(801.41,DITEM,0))
|
||||
.I $G(DATA)=""!($P(DATA,U,3)]"") S DITEM=DITEMO Q
|
||||
Q
|
||||
;
|
||||
RESGROUP(DIEN) ;
|
||||
N CNT,RESULT,TEMP
|
||||
S RESULT=""
|
||||
I $$PATCH^XPDUTL("OR*3.0*243")=0 D Q RESULT
|
||||
.S RESULT=$P($G(^PXRMD(801.41,DIEN,51,1,0)),U) I RESULT="" Q
|
||||
.I $P($G(^PXRMD(801.41,RESULT,0)),U,3)'="" S RESULT="" Q
|
||||
S CNT=0 F S CNT=$O(^PXRMD(801.41,DIEN,51,CNT)) Q:CNT'>0 D
|
||||
.S TEMP=$P($G(^PXRMD(801.41,DIEN,51,CNT,0)),U) I TEMP="" Q
|
||||
.I $P($G(^PXRMD(801.41,TEMP,0)),U,3)'="" S TEMP="" Q
|
||||
.S RESULT=$S(RESULT="":TEMP,1:RESULT_"~"_TEMP)
|
||||
Q RESULT
|
||||
;
|
||||
TERM(TERMIEN,DFN,IEN) ;
|
||||
;this section is use to for the term evaluation
|
||||
N ARRAY,CNT,NODE,RESULT,TERMARR
|
||||
N DATEORDR,ESUB,FINDPA,FIEVAL,TFIEVAL,NOCC,BDT,EDT,SDIR,SUB,WVIEN
|
||||
S (TERMARR,TFIEVAL,DATEORDR,FIEVAL)=""
|
||||
;build term array
|
||||
D TERM^PXRMLDR(TERMIEN,.TERMARR)
|
||||
;term evaulation
|
||||
D IEVALTER^PXRMTERM(DFN,.TERMARR,.TERMARR,1,.FIEVAL)
|
||||
S RESULT=$G(FIEVAL(1))
|
||||
;if the item is one of the WH review reminders build finding item and
|
||||
;text from the the WVALERTS API in PXRMCWH
|
||||
I RESULT=1,$P($G(^PXRMD(801.41,IEN,0)),U,16)["WHR" D
|
||||
.N IDENT
|
||||
.S IDENT=$P($G(^PXRMD(801.41,IEN,0)),U,16)
|
||||
.I $G(FIEVAL(1,"LINK"))=1,$G(FIEVAL(1,"STATUS"))="OPEN",$G(FIEVAL(1,"VALUE"))="Pending" D
|
||||
..S WVIEN=$G(FIEVAL(1,"WVIEN"))
|
||||
..;DBIA #4102
|
||||
..D RESULTS^WVALERTS(.ARRAY,WVIEN) D
|
||||
...K WHFIND,WHNAME
|
||||
...S NODE=$G(ARRAY(0)) I +$P(NODE,U)'>0 Q
|
||||
...S WHFIND=WVIEN_";WV(790.1,",WHNAME=$P($G(NODE),U,3)
|
||||
...S (ESUB,SUB)=0 F S SUB=$O(DTXT(SUB)) Q:SUB'>0 S ESUB=SUB
|
||||
...S ESUB=ESUB+1
|
||||
...I IDENT="WHRP" D
|
||||
....N MOD
|
||||
....S DATE=""
|
||||
....S DTXT(ESUB)=$P($G(NODE),U,3),ESUB=ESUB+1
|
||||
....S DATE=$P($G(NODE),U,4),STR=$$RJ^XLFSTR("Collected: ",20)
|
||||
....S STR=STR_$P($G(NODE),U,8)
|
||||
....S DTXT(ESUB)=STR,ESUB=ESUB+1
|
||||
....S STR=$$RJ^XLFSTR("Lab Accession #: ",20),STR=STR_$P($G(NODE),U,9)
|
||||
....S DTXT(ESUB)=STR,ESUB=ESUB+1
|
||||
....S STR=$$RJ^XLFSTR("Specimen: ",20),STR=STR_$P($G(NODE),U,10)
|
||||
....S DTXT(ESUB)=STR
|
||||
...I IDENT="WHRM" D
|
||||
....S STR=$$RJ^XLFSTR("Procedure: ",20),STR=STR_$P($G(NODE),U,5)
|
||||
....S DTXT(ESUB)=STR,ESUB=ESUB+1
|
||||
....S STR=$$RJ^XLFSTR("Primary Diagnosis: ",20),STR=STR_$P($G(NODE),U,6)
|
||||
....S DTXT(ESUB)=STR,ESUB=ESUB+1
|
||||
....S STR=$$RJ^XLFSTR("Modifiers: ",20),MOD=$P($G(NODE),U,7)
|
||||
....I $G(MOD)="" S STR=STR_"<none>"
|
||||
....E S STR=STR_$P($G(MOD),"~",1)
|
||||
....S DTXT(ESUB)=STR,ESUB=ESUB+1
|
||||
....I $P($G(MOD),"~",2)'="" S DTXT(ESUB)=$$LJ^XLFSTR($P(MOD,"~",2),23)
|
||||
Q +RESULT
|
||||
;
|
||||
PXRMDLLB ;SLC/PJH - REMINDER DIALOG LOADER ;07/29/2004
|
||||
;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
|
||||
;
|
||||
CODE(DFIEN,DFTYP,ARRAY) ;
|
||||
N ARY,CNT,CNT1
|
||||
I DFTYP["ICD9" S CODE=$P($G(^ICD9(DFIEN,0)),U) D PERIOD^ICDAPIU(CODE,.ARY)
|
||||
I DFTYP["ICPT" S CODE=$P($$CPT^ICPTCOD(DFIEN),U,2) D PERIOD^ICPTAPIU(CODE,.ARY)
|
||||
I $D(ARY)'>0 Q
|
||||
I $P($G(ARY(0)),U,2)'>0 Q
|
||||
S (CNT,CNT1)=0
|
||||
F S CNT=$O(ARY(CNT)) Q:CNT="" D
|
||||
. S ARRAY(CNT1)=CODE_":"_CNT_":"_$P($G(ARY(CNT)),U)
|
||||
. S CNT1=CNT1+1
|
||||
Q
|
||||
;
|
||||
CODES(FILE,TXIEN,ARRAY) ;Return selectable codes from taxonomy file
|
||||
N CNT,CODE,CSCNT,DATA,DATES,DISPLAY,IEN,INSTALL,TEMP,TEXT,NODE,SUB
|
||||
S SUB=0,CNT=0,NODE=$S(FILE=80:"SDX",FILE=81:"SPR")
|
||||
F S SUB=$O(^PXD(811.2,TXIEN,NODE,SUB)) Q:'SUB D
|
||||
.S DATA=$G(^PXD(811.2,TXIEN,NODE,SUB,0)) Q:DATA=""
|
||||
.;Ignore if disabled
|
||||
.S DISPLAY=""
|
||||
.I $P(DATA,U,3)=1 Q
|
||||
.;Get ien of code
|
||||
.S IEN=$P(DATA,U) Q:IEN=""
|
||||
.;get date ranges and text from period api
|
||||
.K ARY
|
||||
.I FILE=80 S CODE=$P($G(^ICD9(IEN,0)),U)
|
||||
.I FILE=81 S CODE=$P($$CPT^ICPTCOD(IEN),U,2)
|
||||
.S DISPLAY=$P($G(DATA),U,2)
|
||||
.S TEMP=$$CODE^PXRMVAL(CODE,FILE) Q:'$P(TEMP,U) Q:$P(TEMP,U,9)=1
|
||||
.;Set display text from taxonomy selectable code text
|
||||
.S TEXT=$P(DATA,U,2)
|
||||
.;otherwise use icd9/cpt description
|
||||
.I TEXT="",FILE=80 S TEXT=$P($$ICDDX^ICDCODE(IEN),U,3)
|
||||
.I TEXT="",FILE=81 S TEXT=$P($$CPT^ICPTCOD(IEN),U,3)
|
||||
.I FILE=80 D PERIOD^ICDAPIU(CODE,.ARY)
|
||||
.I FILE=81 D PERIOD^ICPTAPIU(CODE,.ARY)
|
||||
.I $D(ARY)'>0 Q
|
||||
.I $P($G(ARY(0)),U,2)'>0 Q
|
||||
.S CSCNT=0 F S CSCNT=$O(ARY(CSCNT)) Q:CSCNT="" D
|
||||
..S DATES=":"_CSCNT_":"_$P($G(ARY(CSCNT)),U)
|
||||
..S TEXT=$P($G(ARY(CSCNT)),U,2) I $G(DISPLAY)'="" S TEXT=DISPLAY
|
||||
..S CNT=CNT+1,ARRAY(CNT)=IEN_U_$G(CODE)_$G(DATES)_U_$G(TEXT)
|
||||
Q
|
||||
;
|
||||
EXP(TIEN,DCUR,DTTYP) ;Expand taxonomy codes
|
||||
N CODES,CNT,FILE,LIT,CAT
|
||||
S FILE=$S(DTTYP="POV":80,DTTYP="CPT":81,1:"") Q:'FILE
|
||||
S LIT="Selectable "_$S(FILE=80:"Diagnoses:",1:"Procedures:")
|
||||
S CAT=$P($G(^PXD(811.2,TIEN,0)),U)
|
||||
;
|
||||
S OCNT=OCNT+1
|
||||
S ORY(OCNT)=3_U_DITEM_U_U_DTTYP_U_U_U_U_U_CAT_U_LIT
|
||||
;Get selectable codes
|
||||
D CODES(FILE,TIEN,.CODES)
|
||||
S CNT=0
|
||||
;Save selectable codes as type 5 records
|
||||
F S CNT=$O(CODES(CNT)) Q:'CNT D
|
||||
.S OCNT=OCNT+1,ORY(OCNT)=5_U_DITEM_U_U_DTTYP_U_U_CODES(CNT)
|
||||
Q
|
||||
;
|
||||
;Pass MST code as a forced value
|
||||
MST(DFTYP,DFIEN) ;
|
||||
;Validate finding ien
|
||||
Q:DFIEN=""
|
||||
;For each MST term check if finding is mapped
|
||||
N FOUND,TCOND,TIEN,TNAM,TSUB
|
||||
S FOUND=0
|
||||
F TNAM="POSITIVE","NEGATIVE","DECLINES" D Q:FOUND
|
||||
.;Get term IEN
|
||||
.S TIEN=$O(^PXRMD(811.5,"B","MST "_TNAM_" REPORT","")) Q:'TIEN
|
||||
.;Check if finding is mapped to term
|
||||
.Q:'$D(^PXRMD(811.5,TIEN,20,"E",DFTYP,DFIEN))
|
||||
.;If exam and term condition logic is null ignore
|
||||
.I DFTYP="AUTTEXAM(" D Q:TCOND=""
|
||||
..S TCOND="",TSUB=$O(^PXRMD(811.5,TIEN,20,"E",DFTYP,DFIEN,"")) Q:'TSUB
|
||||
..S TCOND=$P($G(^PXRMD(811.5,TIEN,20,TSUB,3)),U)
|
||||
.;If it is then create additional prompt for MST
|
||||
.N DSEQ,DEXC,DDEF,DGUI,DTYP,DTEXT,DSNL,DREQ
|
||||
.;Add to end of array
|
||||
.S DSEQ=$O(ARRAY(""),-1)+1
|
||||
.;Null fields
|
||||
.S DDEF="",DEXC="",DTEXT="",DSNL="",DREQ=""
|
||||
.;MST status (exept for exams)
|
||||
.I DFTYP'="AUTTEXAM(" S DDEF=$$STCODE^PXRMMST("MST "_TNAM_" REPORT")
|
||||
.;GUI process and forced value
|
||||
.S DGUI="MST",DTYP="F"
|
||||
.;Save in array
|
||||
.S ARRAY(DSEQ)=DGUI_U_DEXC_U_DDEF_U_DTYP_U_DTEXT_U_DSNL_U_DREQ
|
||||
.;Quit after the first term is found
|
||||
.S FOUND=1
|
||||
Q
|
||||
;
|
||||
REPLACE(DFN,TERMNODE,DITEM,DATA,TERMSTAT) ;
|
||||
;this section is use to compare the term evalution result against
|
||||
;the value store in the Reminder Term Status field.
|
||||
;If the value match and the replacement item is active then the orginal
|
||||
;item will be replace with the new item.
|
||||
N TERMOUT
|
||||
S TERMSTAT=1 I +$P(TERMNODE,U),$P($G(TERMNODE),U,2)'="" D Q:+TERMSTAT=0
|
||||
.N DITEMO
|
||||
.S TERMOUT=$$TERM($P(TERMNODE,U),DFN,$G(DITEM))
|
||||
.I TERMOUT'=$P(TERMNODE,U,2) Q
|
||||
.I +$P(TERMNODE,U,3)'>0 S TERMSTAT=0 Q
|
||||
.S DITEMO=DITEM,DITEM=$P(TERMNODE,U,3),DATA=$G(^PXRMD(801.41,DITEM,0))
|
||||
.I $G(DATA)=""!($P(DATA,U,3)]"") S DITEM=DITEMO Q
|
||||
Q
|
||||
;
|
||||
TERM(TERMIEN,DFN,IEN) ;
|
||||
;this section is use to for the term evaluation
|
||||
N ARRAY,CNT,NODE,RESULT,TERMARR
|
||||
N DATEORDR,ESUB,FINDPA,FIEVAL,TFIEVAL,NOCC,BDT,EDT,SDIR,SUB,WVIEN
|
||||
S (TERMARR,TFIEVAL,DATEORDR,FIEVAL)=""
|
||||
;build term array
|
||||
D TERM^PXRMLDR(TERMIEN,.TERMARR)
|
||||
;term evaulation
|
||||
D IEVALTER^PXRMTERM(DFN,.TERMARR,.TERMARR,1,.FIEVAL)
|
||||
S RESULT=$G(FIEVAL(1))
|
||||
;if the item is one of the WH review reminders build finding item and
|
||||
;text from the the WVALERTS API in PXRMCWH
|
||||
I RESULT=1,$P($G(^PXRMD(801.41,IEN,0)),U,16)["WHR" D
|
||||
.N IDENT
|
||||
.S IDENT=$P($G(^PXRMD(801.41,IEN,0)),U,16)
|
||||
.I $G(FIEVAL(1,"LINK"))=1,$G(FIEVAL(1,"STATUS"))="OPEN",$G(FIEVAL(1,"VALUE"))="Pending" D
|
||||
..S WVIEN=$G(FIEVAL(1,"WVIEN"))
|
||||
..;DBIA #4102
|
||||
..D RESULTS^WVALERTS(.ARRAY,WVIEN) D
|
||||
...K WHFIND,WHNAME
|
||||
...S NODE=$G(ARRAY(0)) I +$P(NODE,U)'>0 Q
|
||||
...S WHFIND=WVIEN_";WV(790.1,",WHNAME=$P($G(NODE),U,3)
|
||||
...S (ESUB,SUB)=0 F S SUB=$O(DTXT(SUB)) Q:SUB'>0 S ESUB=SUB
|
||||
...S ESUB=ESUB+1
|
||||
...I IDENT="WHRP" D
|
||||
....N MOD
|
||||
....S DATE=""
|
||||
....S DTXT(ESUB)=$P($G(NODE),U,3),ESUB=ESUB+1
|
||||
....S DATE=$P($G(NODE),U,4),STR=$$RJ^XLFSTR("Collected: ",20)
|
||||
....S STR=STR_$P($G(NODE),U,8)
|
||||
....S DTXT(ESUB)=STR,ESUB=ESUB+1
|
||||
....S STR=$$RJ^XLFSTR("Lab Accession #: ",20),STR=STR_$P($G(NODE),U,9)
|
||||
....S DTXT(ESUB)=STR,ESUB=ESUB+1
|
||||
....S STR=$$RJ^XLFSTR("Specimen: ",20),STR=STR_$P($G(NODE),U,10)
|
||||
....S DTXT(ESUB)=STR
|
||||
...I IDENT="WHRM" D
|
||||
....S STR=$$RJ^XLFSTR("Procedure: ",20),STR=STR_$P($G(NODE),U,5)
|
||||
....S DTXT(ESUB)=STR,ESUB=ESUB+1
|
||||
....S STR=$$RJ^XLFSTR("Primary Diagnosis: ",20),STR=STR_$P($G(NODE),U,6)
|
||||
....S DTXT(ESUB)=STR,ESUB=ESUB+1
|
||||
....S STR=$$RJ^XLFSTR("Modifiers: ",20),MOD=$P($G(NODE),U,7)
|
||||
....I $G(MOD)="" S STR=STR_"<none>"
|
||||
....E S STR=STR_$P($G(MOD),"~",1)
|
||||
....S DTXT(ESUB)=STR,ESUB=ESUB+1
|
||||
....I $P($G(MOD),"~",2)'="" S DTXT(ESUB)=$$LJ^XLFSTR($P(MOD,"~",2),23)
|
||||
Q +RESULT
|
||||
;
|
||||
|
|
|
|||
|
|
@ -1,108 +1,93 @@
|
|||
PXRMDLR ;SLC/PJH - DIALOG RESULTS LOADER ;05/15/2007
|
||||
;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
|
||||
;
|
||||
;Build score related P/N text from score and result group
|
||||
;
|
||||
;If not found
|
||||
START(ORY,RESULT,ORES) ;
|
||||
I '$G(RESULT) S ORY(1)="-1^no results for this test" Q
|
||||
;
|
||||
N ARRAY,ERROR,INSERT,OK,SCORE,SUB,YT,X
|
||||
;
|
||||
I RESULT["~" S RESULT=$P(RESULT,"~")
|
||||
S ERROR=0
|
||||
;
|
||||
;Get score using API
|
||||
K ^TMP($J,"YSCOR")
|
||||
I ORES("CODE")'="DOM80" D Q:ERROR
|
||||
.M YT=ORES
|
||||
.F X=1:1:$L(YT("R1")) I $E(YT("R1"),X)'="X" S YT(X)=X_U_$E(YT("R1"),X)
|
||||
.K YT("R1")
|
||||
.D CHECKCR^YTQPXRM4(.ARRAY,.YT)
|
||||
.S OK=0
|
||||
.;D PREVIEW^YTAPI4(.ARRAY,.YT)
|
||||
.I ^TMP($J,"YSCOR",1)'="[DATA]" S ORY(1)="-1^"_^TMP($J,"YSCOR",1)_^TMP($J,"YSCOD",2),ERROR=1 Q
|
||||
.;I ARRAY(1)'="[DATA]" S ORY(1)="-1^"_ARRAY(1)_ARRAY(2),ERROR=1 Q
|
||||
.I $P($G(^TMP($J,"YSCOR",2)),"=",2)'="" S SCORE=$P($G(^TMP($J,"YSCOR",2)),"=",2),OK=1
|
||||
.;S SUB=0,OK=0
|
||||
.;F S SUB=$O(ARRAY(SUB)) Q:'SUB D Q:OK
|
||||
.;.I $P(ARRAY(SUB),U)="S1" S SCORE=$P(ARRAY(SUB),U,3),OK=1
|
||||
.I 'OK S ORY(1)="-1^[ERROR] no score returned",ERROR=1 Q
|
||||
;
|
||||
;Except for DOM80
|
||||
I ORES("CODE")="DOM80" D
|
||||
.I $E(ORES("R1"))="Y" S SCORE=1 Q
|
||||
.I $E(ORES("R1"),2,3)="YY",($E(ORES("R1"),4)>1) S SCORE=1 Q
|
||||
.S SCORE=0
|
||||
;
|
||||
S DFN=$G(ORES("DFN"))
|
||||
S INSERT("SCORE")=SCORE
|
||||
;
|
||||
;For AIMS special formatting is required
|
||||
I ORES("CODE")="AIMS" D
|
||||
.N CNT,LITS,RESP,SUM
|
||||
.S LITS(0)="none",LITS(1)="minimal",LITS(2)="mild",LITS(3)="moderate"
|
||||
.S LITS(4)="severe",SUM(2)=0,SUM(3)=0,SUM(4)=0
|
||||
.F CNT=1:1 S RESP=$E(ORES("R1"),CNT) Q:RESP="" D
|
||||
..S INSERT("R"_CNT)=$G(LITS(RESP))
|
||||
..I (CNT<8),(234[RESP) S SUM(RESP)=SUM(RESP)+1
|
||||
.F CNT=2,3,4 S INSERT("SUM"_CNT)=SUM(CNT)
|
||||
;
|
||||
TEXT ;
|
||||
I RESULT["~" S RESULT=$P(RESULT,"~")
|
||||
;Load dialog results into ORY array
|
||||
N DATA,DCON,DITEM,DSEQ,DSUB,DTYP,INS,SEP,TEXT
|
||||
;Get the result elements
|
||||
S DSEQ=0,OCNT=0
|
||||
F S DSEQ=$O(^PXRMD(801.41,RESULT,10,"B",DSEQ)) Q:'DSEQ D
|
||||
.S DSUB=$O(^PXRMD(801.41,RESULT,10,"B",DSEQ,"")) Q:'DSUB
|
||||
.S DITEM=$P($G(^PXRMD(801.41,RESULT,10,DSUB,0)),U,2) Q:'DITEM
|
||||
.;Get the result element
|
||||
.S DTYP=$P($G(^PXRMD(801.41,DITEM,0)),U,4) Q:DTYP'="T"
|
||||
.;Get the result element condition
|
||||
.S DCON=$P($G(^PXRMD(801.41,DITEM,0)),U,13)
|
||||
.;Skip if condition not satisfied
|
||||
.I DCON'="" S DCON=$TR(DCON,"~"," ") Q:'$$TRUE(SCORE,DCON,DFN)
|
||||
.;Get progress note text if defined
|
||||
.N LAST,NULL,SUB,TEXT S SUB=0,LAST=0
|
||||
.F S SUB=$O(^PXRMD(801.41,DITEM,35,SUB)) Q:'SUB D
|
||||
..;Insert score into text (if neccessary)
|
||||
..S TEXT=$G(^PXRMD(801.41,DITEM,35,SUB,0))
|
||||
..S NULL=0 I ($E(TEXT)=" ")!(TEXT="") S NULL=1
|
||||
..;Add line breaks if is or preceded by blank line or starts with space
|
||||
..I ('NULL),LAST S TEXT="<br>"_TEXT
|
||||
..S TEXT=$$STRREP^PXRMUTIL(TEXT,"\\","<br>")
|
||||
..S LAST=0 I NULL S TEXT="<br>"_TEXT,LAST=1
|
||||
..;Check for inserts - note there may be embedded TIU markers too
|
||||
..N INS
|
||||
..S INS=""
|
||||
..F S INS=$O(INSERT(INS)) Q:INS="" D
|
||||
...S SEP="|"_INS_"|" I '$F(TEXT,SEP) Q
|
||||
...S TEXT=$P(TEXT,SEP)_$G(INSERT(INS))_$P(TEXT,SEP,2,99)
|
||||
..S OCNT=OCNT+1,ORY(OCNT)=7_U_TEXT
|
||||
Q
|
||||
;
|
||||
MHDLL(ORES,RESULT,SCORE,DFN) ;
|
||||
S INSERT("SCORE")=SCORE
|
||||
D TEXT
|
||||
Q
|
||||
OUT(DATA) ;Display element details
|
||||
N DITEM S DITEM=$P(DATA,U,2) Q:'DITEM
|
||||
W $P($G(^PXRMD(801.41,DITEM,0)),U)
|
||||
W !,$J("Element Condition: ",19)
|
||||
W $TR($P($G(^PXRMD(801.41,DITEM,0)),U,13),"~"," ")
|
||||
W !,$J("Element text:",17)
|
||||
;Get progress note text if defined
|
||||
N SUB,TEXT S SUB=0
|
||||
F S SUB=$O(^PXRMD(801.41,DITEM,35,SUB)) Q:'SUB D
|
||||
.S TEXT=$G(^PXRMD(801.41,DITEM,35,SUB,0)) W !,?5,TEXT
|
||||
Q
|
||||
;
|
||||
TRUE(V,COND,DFN) ; Check if value meets element condition
|
||||
N RESULT,SEX
|
||||
I COND["SEX" D Q RESULT
|
||||
. S RESULT=0
|
||||
. S SEX=$P($G(^DPT(DFN,0)),U,2)
|
||||
. X COND I S RESULT=1
|
||||
X COND I Q 1
|
||||
Q 0
|
||||
PXRMDLR ;SLC/PJH - DIALOG RESULTS LOADER ;06/09/2000
|
||||
;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
|
||||
;
|
||||
;Build score related P/N text from score and result group
|
||||
;
|
||||
;If not found
|
||||
I '$G(RESULT) S ORY(1)="-1^no results for this test" Q
|
||||
;
|
||||
N ARRAY,ERROR,INSERT,OK,SCORE,SUB,YT
|
||||
;
|
||||
S ERROR=0
|
||||
;
|
||||
;Get score using API
|
||||
S DFN=$G(ORES("DFN"))
|
||||
I ORES("CODE")'="DOM80" D Q:ERROR
|
||||
.M YT=ORES
|
||||
.D PREVIEW^YTAPI4(.ARRAY,.YT)
|
||||
.I ARRAY(1)'="[DATA]" S ORY(1)="-1^"_ARRAY(1)_ARRAY(2),ERROR=1 Q
|
||||
.S SUB=0,OK=0
|
||||
.F S SUB=$O(ARRAY(SUB)) Q:'SUB D Q:OK
|
||||
..I $P(ARRAY(SUB),U)="S1" S SCORE=$P(ARRAY(SUB),U,3),OK=1
|
||||
.I 'OK S ORY(1)="-1^[ERROR] no score returned",ERROR=1 Q
|
||||
;
|
||||
;Except for DOM80
|
||||
I ORES("CODE")="DOM80" D
|
||||
.I $E(ORES("R1"))="Y" S SCORE=1 Q
|
||||
.I $E(ORES("R1"),2,3)="YY",($E(ORES("R1"),4)>1) S SCORE=1 Q
|
||||
.S SCORE=0
|
||||
;
|
||||
S INSERT("SCORE")=SCORE
|
||||
;
|
||||
;For AIMS special formatting is required
|
||||
I ORES("CODE")="AIMS" D
|
||||
.N CNT,LITS,RESP,SUM
|
||||
.S LITS(0)="none",LITS(1)="minimal",LITS(2)="mild",LITS(3)="moderate"
|
||||
.S LITS(4)="severe",SUM(2)=0,SUM(3)=0,SUM(4)=0
|
||||
.F CNT=1:1 S RESP=$E(ORES("R1"),CNT) Q:RESP="" D
|
||||
..S INSERT("R"_CNT)=$G(LITS(RESP))
|
||||
..I (CNT<8),(234[RESP) S SUM(RESP)=SUM(RESP)+1
|
||||
.F CNT=2,3,4 S INSERT("SUM"_CNT)=SUM(CNT)
|
||||
;
|
||||
;Load dialog results into ORY array
|
||||
N DATA,DCON,DITEM,DSEQ,DSUB,DTYP,INS,SEP,TEXT
|
||||
;Get the result elements
|
||||
S DSEQ=0,OCNT=0
|
||||
F S DSEQ=$O(^PXRMD(801.41,RESULT,10,"B",DSEQ)) Q:'DSEQ D
|
||||
.S DSUB=$O(^PXRMD(801.41,RESULT,10,"B",DSEQ,"")) Q:'DSUB
|
||||
.S DITEM=$P($G(^PXRMD(801.41,RESULT,10,DSUB,0)),U,2) Q:'DITEM
|
||||
.;Get the result element
|
||||
.S DTYP=$P($G(^PXRMD(801.41,DITEM,0)),U,4) Q:DTYP'="T"
|
||||
.;Get the result element condition
|
||||
.S DCON=$P($G(^PXRMD(801.41,DITEM,0)),U,13)
|
||||
.;Skip if condition not satisfied
|
||||
.I DCON'="" S DCON=$TR(DCON,"~"," ") Q:'$$TRUE(SCORE,DCON,DFN)
|
||||
.;Get progress note text if defined
|
||||
.N LAST,NULL,SUB,TEXT S SUB=0,LAST=0
|
||||
.F S SUB=$O(^PXRMD(801.41,DITEM,35,SUB)) Q:'SUB D
|
||||
..;Insert score into text (if neccessary)
|
||||
..S TEXT=$G(^PXRMD(801.41,DITEM,35,SUB,0))
|
||||
..S NULL=0 I ($E(TEXT)=" ")!(TEXT="") S NULL=1
|
||||
..;Add line breaks if is or preceded by blank line or starts with space
|
||||
..I ('NULL),LAST S TEXT="<br>"_TEXT
|
||||
..S TEXT=$$STRREP^PXRMUTIL(TEXT,"\\","<br>")
|
||||
..S LAST=0 I NULL S TEXT="<br>"_TEXT,LAST=1
|
||||
..;Check for inserts - note there may be embedded TIU markers too
|
||||
..N INS
|
||||
..S INS=""
|
||||
..F S INS=$O(INSERT(INS)) Q:INS="" D
|
||||
...S SEP="|"_INS_"|" I '$F(TEXT,SEP) Q
|
||||
...S TEXT=$P(TEXT,SEP)_$G(INSERT(INS))_$P(TEXT,SEP,2,99)
|
||||
..S OCNT=OCNT+1,ORY(OCNT)=7_U_TEXT
|
||||
Q
|
||||
;
|
||||
OUT(DATA) ;Display element details
|
||||
N DITEM S DITEM=$P(DATA,U,2) Q:'DITEM
|
||||
W $P($G(^PXRMD(801.41,DITEM,0)),U)
|
||||
W !,$J("Element Condition: ",19)
|
||||
W $TR($P($G(^PXRMD(801.41,DITEM,0)),U,13),"~"," ")
|
||||
W !,$J("Element text:",17)
|
||||
;Get progress note text if defined
|
||||
N SUB,TEXT S SUB=0
|
||||
F S SUB=$O(^PXRMD(801.41,DITEM,35,SUB)) Q:'SUB D
|
||||
.S TEXT=$G(^PXRMD(801.41,DITEM,35,SUB,0)) W !,?5,TEXT
|
||||
Q
|
||||
;
|
||||
TRUE(V,COND,DFN) ; Check if value meets element condition
|
||||
N RESULT,SEX
|
||||
I COND["SEX" D Q RESULT
|
||||
. S RESULT=0
|
||||
. S SEX=$P($G(^DPT(DFN,0)),U,2)
|
||||
. X COND I S RESULT=1
|
||||
X COND I Q 1
|
||||
Q 0
|
||||
|
|
|
|||
|
|
@ -1,89 +1,89 @@
|
|||
PXRMDLR1 ; SLC/AGP - DIALOG ORPHAN REPORT. ; 11/16/2007
|
||||
;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
|
||||
;
|
||||
;=======================================================================
|
||||
START(NUM) ;
|
||||
N DIR,POP,ZTDESC,ZTRTN,ZTSAVE
|
||||
S %ZIS="M"
|
||||
I NUM=1 S ZTDESC="Dialog Orphan Report" S ZTRTN="EN^PXRMDLR1"
|
||||
I NUM=2 S ZTDESC="Empty Reminder Dialogs Report" S ZTRTN="EN1^PXRMDLR1"
|
||||
S ZTSAVE("*")=""
|
||||
D EN^XUTMDEVQ(ZTRTN,ZTDESC,.ZTSAVE,.%ZIS)
|
||||
Q
|
||||
;
|
||||
EN ;
|
||||
N NAME,IEN,TYPE
|
||||
K ^TMP("PXRMDLR1",$J)
|
||||
S IEN=0
|
||||
S NAME="" F S NAME=$O(^PXRMD(801.41,"B",NAME)) Q:NAME="" D
|
||||
. S IEN=$O(^PXRMD(801.41,"B",NAME,"")) Q:IEN'>0
|
||||
. S TYPE=$P($G(^PXRMD(801.41,IEN,0)),U,4)
|
||||
. I $G(TYPE)=""!($G(TYPE)="R") Q
|
||||
. I $D(^PXRMD(801.41,"AD",IEN)) Q
|
||||
. S TYPE=$S(TYPE="P":"VPROMPT",TYPE="E":"ELEMENT",TYPE="F":"VVALUE",TYPE="G":"GROUP",TYPE="S":"RGROUP",TYPE="T":"RELEMENT")
|
||||
. S ^TMP("PXRMDLR1",$J,TYPE,NAME)=IEN
|
||||
I $D(^TMP("PXRMDLR1",$J))>0 D OUTPUT
|
||||
Q
|
||||
;
|
||||
EN1 ;
|
||||
N DONE,FOUND,NAME,IEN,TITLE,TYPE
|
||||
W @IOF
|
||||
S PCNT=0,PAGE=1,DONE=0,FOUND=0
|
||||
S TITLE="Empty Reminder Dialogs Report"
|
||||
D HEADER(.PCNT,PAGE,TITLE)
|
||||
S IEN=0
|
||||
S NAME="" F S NAME=$O(^PXRMD(801.41,"B",NAME)) Q:NAME=""!(DONE=1) D
|
||||
. S IEN=$O(^PXRMD(801.41,"B",NAME,"")) Q:IEN'>0
|
||||
. S TYPE=$P($G(^PXRMD(801.41,IEN,0)),U,4)
|
||||
. I ($G(TYPE)'="R") Q
|
||||
. I $D(^PXRMD(801.41,IEN,10))'=0 Q
|
||||
. S FOUND=1
|
||||
. I (PCNT+1)'<IOSL D PAGE(.PCNT,.PAGE) I $G(DONE)=1 Q
|
||||
. W !," "_$G(NAME) S PCNT=PCNT+1 I (PCNT+1)'<IOSL D PAGE(.PCNT,.PAGE) I $G(DONE)=1 Q
|
||||
I FOUND=0 W !,"No empty dialog found"
|
||||
I ($E(IOST,1,2)="C-")&(IO=IO(0)) D
|
||||
. W !
|
||||
. S DIR(0)="E" D ^DIR K DIR
|
||||
Q
|
||||
;
|
||||
OUTPUT ;
|
||||
N CAT,DONE,LENGTH,NAME,OCAT,PAGE,PCNT,TITLE,TYPE,X
|
||||
W @IOF
|
||||
S PCNT=0,PAGE=1,DONE=0
|
||||
S TITLE="Reminder Dialog Elements Orphan Report"
|
||||
D HEADER(.PCNT,PAGE,TITLE)
|
||||
W !
|
||||
F CAT="ELEMENT","GROUP","RELEMENT","RGROUP","VPROMPT","VVALUE" D
|
||||
. I DONE=1 Q
|
||||
. I $D(^TMP("PXRMDLR1",$J,CAT))'>0 Q
|
||||
. S TYPE=$S(CAT="VPROMPT":"Additional Prompts",CAT="ELEMENT":"Dialog Elements",CAT="VVALUE":"Force Values",CAT="GROUP":"Dialog Groups",CAT="RGROUP":"Result Groups",CAT="RELEMENT":"Result Elements")
|
||||
. I (PCNT+4)'<IOSL D PAGE(.PCNT,.PAGE) I $G(DONE)=1 Q
|
||||
. S LENGTH=$L(TYPE) W !!,TYPE,! F X=1:1:LENGTH W "="
|
||||
. S PCNT=PCNT+4
|
||||
. I (PCNT+1)'<IOSL D PAGE(.PCNT,.PAGE) I $G(DONE)=1 Q
|
||||
. S NAME="" F S NAME=$O(^TMP("PXRMDLR1",$J,CAT,NAME)) Q:NAME=""!(DONE=1) D
|
||||
. .W !,$$LJ^XLFSTR("",4)_NAME S PCNT=PCNT+1
|
||||
. .I (PCNT+1)'<IOSL D PAGE(.PCNT,.PAGE) I $G(DONE)=1 Q
|
||||
K ^TMP("PXRMDLR1",$J)
|
||||
I ($E(IOST,1,2)="C-")&(IO=IO(0)) D
|
||||
. W !
|
||||
. S DIR(0)="E" D ^DIR K DIR
|
||||
Q
|
||||
;
|
||||
HEADER(PCNT,PAGE,TITLE) ;
|
||||
W $$LJ^XLFSTR(TITLE,70)_"Page: "_PAGE,!
|
||||
F X=1:1:80 W "="
|
||||
S PCNT=PCNT+3
|
||||
Q
|
||||
;
|
||||
PAGE(PCNT,PAGE) ;
|
||||
N DUOUT,DTOUT,DIROUT,DIR
|
||||
I ($E(IOST,1,2)="C-")&(IO=IO(0)) D
|
||||
.S DIR(0)="E"
|
||||
.W !
|
||||
.D ^DIR K DIR
|
||||
I $D(DUOUT)!($D(DTOUT))!($D(DIROUT)) S DONE=1 Q
|
||||
W:$D(IOF) @IOF
|
||||
S PAGE=PAGE+1,PCNT=0
|
||||
I ($E(IOST,1,2)="C-")&(IO=IO(0)) W @IOF D HEADER(.PCNT,PAGE,TITLE)
|
||||
Q
|
||||
PXRMDLR1 ; SLC/AGP - DIALOG ORPHAN REPORT. ; 02/04/2004
|
||||
;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
|
||||
;
|
||||
;=======================================================================
|
||||
START(NUM) ;
|
||||
N DIR,POP,ZTDESC,ZTRTN,ZTSAVE
|
||||
S %ZIS="M"
|
||||
I NUM=1 S ZTDESC="Dialog Orphan Report" S ZTRTN="EN^PXRMDLR1"
|
||||
I NUM=2 S ZTDESC="Empty Reminder Dialogs Report" S ZTRTN="EN1^PXRMDLR1"
|
||||
S ZTSAVE("*")=""
|
||||
D EN^XUTMDEVQ(ZTRTN,ZTDESC,.ZTSAVE,.%ZIS)
|
||||
Q
|
||||
;
|
||||
EN ;
|
||||
N NAME,IEN,TYPE
|
||||
K ^TMP("PXRMDLR1",$J)
|
||||
S IEN=0
|
||||
S NAME="" F S NAME=$O(^PXRMD(801.41,"B",NAME)) Q:NAME="" D
|
||||
. S IEN=$O(^PXRMD(801.41,"B",NAME,"")) Q:IEN'>0
|
||||
. S TYPE=$P($G(^PXRMD(801.41,IEN,0)),U,4)
|
||||
. I $G(TYPE)=""!($G(TYPE)="R") Q
|
||||
. I $D(^PXRMD(801.41,"AD",IEN)) Q
|
||||
. S TYPE=$S(TYPE="P":"VPROMPT",TYPE="E":"ELEMENT",TYPE="F":"VVALUE",TYPE="G":"GROUP",TYPE="S":"RGROUP",TYPE="T":"RELEMENT")
|
||||
. S ^TMP("PXRMDLR1",$J,TYPE,NAME)=IEN
|
||||
I $D(^TMP("PXRMDLR1",$J))>0 D OUTPUT
|
||||
Q
|
||||
;
|
||||
EN1 ;
|
||||
N DONE,FOUND,NAME,IEN,TITLE,TYPE
|
||||
W @IOF
|
||||
S PCNT=0,PAGE=1,DONE=0,FOUND=0
|
||||
S TITLE="Empty Reminder Dialogs Report"
|
||||
D HEADER(.PCNT,PAGE,TITLE)
|
||||
S IEN=0
|
||||
S NAME="" F S NAME=$O(^PXRMD(801.41,"B",NAME)) Q:NAME=""!(DONE=1) D
|
||||
. S IEN=$O(^PXRMD(801.41,"B",NAME,"")) Q:IEN'>0
|
||||
. S TYPE=$P($G(^PXRMD(801.41,IEN,0)),U,4)
|
||||
. I ($G(TYPE)'="R") Q
|
||||
. I $D(^PXRMD(801.41,IEN,10))'=0 Q
|
||||
. S FOUND=1
|
||||
. I (PCNT+1)'<IOSL D PAGE(.PCNT,.PAGE) I $G(DONE)=1 Q
|
||||
. W !," "_$G(NAME) S PCNT=PCNT+1 I (PCNT+1)'<IOSL D PAGE(.PCNT,.PAGE) I $G(DONE)=1 Q
|
||||
I FOUND=0 W !,"No empty dialog found"
|
||||
I ($E(IOST)="C")&(IO=IO(0)) D
|
||||
. W !
|
||||
. S DIR(0)="E" D ^DIR K DIR
|
||||
Q
|
||||
;
|
||||
OUTPUT ;
|
||||
N CAT,DONE,LENGTH,NAME,OCAT,PAGE,PCNT,TITLE,TYPE,X
|
||||
W @IOF
|
||||
S PCNT=0,PAGE=1,DONE=0
|
||||
S TITLE="Reminder Dialog Elements Orphan Report"
|
||||
D HEADER(.PCNT,PAGE,TITLE)
|
||||
W !
|
||||
F CAT="ELEMENT","GROUP","RELEMENT","RGROUP","VPROMPT","VVALUE" D
|
||||
. I DONE=1 Q
|
||||
. I $D(^TMP("PXRMDLR1",$J,CAT))'>0 Q
|
||||
. S TYPE=$S(CAT="VPROMPT":"Additional Prompts",CAT="ELEMENT":"Dialog Elements",CAT="VVALUE":"Force Values",CAT="GROUP":"Dialog Groups",CAT="RGROUP":"Result Groups",CAT="RELEMENT":"Result Elements")
|
||||
. I (PCNT+4)'<IOSL D PAGE(.PCNT,.PAGE) I $G(DONE)=1 Q
|
||||
. S LENGTH=$L(TYPE) W !!,TYPE,! F X=1:1:LENGTH W "="
|
||||
. S PCNT=PCNT+4
|
||||
. I (PCNT+1)'<IOSL D PAGE(.PCNT,.PAGE) I $G(DONE)=1 Q
|
||||
. S NAME="" F S NAME=$O(^TMP("PXRMDLR1",$J,CAT,NAME)) Q:NAME=""!(DONE=1) D
|
||||
. .W !,$$LJ^XLFSTR("",4)_NAME S PCNT=PCNT+1
|
||||
. .I (PCNT+1)'<IOSL D PAGE(.PCNT,.PAGE) I $G(DONE)=1 Q
|
||||
K ^TMP("PXRMDLR1",$J)
|
||||
I ($E(IOST)="C")&(IO=IO(0)) D
|
||||
. W !
|
||||
. S DIR(0)="E" D ^DIR K DIR
|
||||
Q
|
||||
;
|
||||
HEADER(PCNT,PAGE,TITLE) ;
|
||||
W $$LJ^XLFSTR(TITLE,70)_"Page: "_PAGE,!
|
||||
F X=1:1:80 W "="
|
||||
S PCNT=PCNT+3
|
||||
Q
|
||||
;
|
||||
PAGE(PCNT,PAGE) ;
|
||||
N DUOUT,DTOUT,DIROUT,DIR
|
||||
I ($E(IOST)="C")&(IO=IO(0)) D
|
||||
.S DIR(0)="E"
|
||||
.W !
|
||||
.D ^DIR K DIR
|
||||
I $D(DUOUT)!($D(DTOUT))!($D(DIROUT)) S DONE=1 Q
|
||||
W:$D(IOF) @IOF
|
||||
S PAGE=PAGE+1,PCNT=0
|
||||
I $E(IOST)="C",IO=IO(0) W @IOF D HEADER(.PCNT,PAGE,TITLE)
|
||||
Q
|
||||
|
|
|
|||
|
|
@ -1,49 +1,48 @@
|
|||
PXRMDNVA ; SLC/PKR - Handle non-VA med findings. ;03/14/2007
|
||||
;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
|
||||
;
|
||||
;===============================================
|
||||
GETDATA(DAS,FIEVT) ;Return data for an non-VA med finding.
|
||||
;DBIA #3793
|
||||
D NVA^PSOPXRM1(DAS,.FIEVT)
|
||||
S FIEVT("VALUE")=FIEVT("STATUS")
|
||||
I $G(FIEVT("START DATE"))="" S FIEVT("START DATE")=FIEVT("DOCUMENTED DATE")
|
||||
S FIEVT("DURATION")=$$DURATION^PXRMDATE(FIEVT("START DATE"),FIEVT("DISCONTINUED DATE"))
|
||||
Q
|
||||
;
|
||||
;===============================================
|
||||
EVALTERM(DFN,FINDPA,ENODE,TERMARR,TFIEVAL) ;Evaluate terms.
|
||||
D EVALTERM^PXRMINDX(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL)
|
||||
Q
|
||||
;
|
||||
;====================================================
|
||||
MHVOUT(INDENT,IFIEVAL,NLINES,TEXT) ;Produce the MHV output.
|
||||
N DATE,JND,NOUT,TEMP,TEXTOUT
|
||||
S TEMP="Non-VA med: "_IFIEVAL("ORDERABLE ITEM")_" = "
|
||||
S TEMP=TEMP_"("_$$EDATE^PXRMDATE(IFIEVAL("START DATE"))
|
||||
S DATE=IFIEVAL("DISCONTINUED DATE")
|
||||
S DATE=$S(DATE="":"NONE",1:$$EDATE^PXRMDATE(DATE))
|
||||
D FORMATS^PXRMTEXT(INDENT+2,PXRMRM,TEMP,.NOUT,.TEXTOUT)
|
||||
F JND=1:1:NOUT S NLINES=NLINES+1,TEXT(NLINES)=TEXTOUT(JND)
|
||||
Q
|
||||
;
|
||||
;===============================================
|
||||
OUTPUT(INDENT,IFIEVAL,NLINES,TEXT) ;Produce the clinical
|
||||
;maintenance output.
|
||||
N DATE,JND,NOUT,TEMP,TEXTOUT
|
||||
S NLINES=NLINES+1
|
||||
S TEXT(NLINES)=$$INSCHR^PXRMEXLC(INDENT," ")_"Non-VA med: "_IFIEVAL("ORDERABLE ITEM")
|
||||
S DATE=IFIEVAL("START DATE")
|
||||
S TEMP="Start Date: "_$$EDATE^PXRMDATE(DATE)
|
||||
S DATE=IFIEVAL("DISCONTINUED DATE")
|
||||
S DATE=$S(DATE="":"NONE",1:$$EDATE^PXRMDATE(DATE))
|
||||
S TEMP=TEMP_" Discontinued Date: "_DATE
|
||||
I $D(IFIEVAL("DURATION")) S TEMP=TEMP_" Duration: "_IFIEVAL("DURATION")_" D"
|
||||
S TEMP=TEMP_" Status: "_IFIEVAL("STATUS")_"\\"
|
||||
S TEMP=TEMP_"Dosage Form: "_IFIEVAL("DOSAGE FORM")
|
||||
S TEMP=TEMP_" Dosage: "_IFIEVAL("DOSAGE")
|
||||
S TEMP=TEMP_" Medication Route: "_IFIEVAL("MEDICATION ROUTE")
|
||||
D FORMATS^PXRMTEXT(INDENT+1,PXRMRM,TEMP,.NOUT,.TEXTOUT)
|
||||
F JND=1:1:NOUT S NLINES=NLINES+1,TEXT(NLINES)=TEXTOUT(JND)
|
||||
S NLINES=NLINES+1,TEXT(NLINES)=""
|
||||
Q
|
||||
;
|
||||
PXRMDNVA ; SLC/PKR - Handle non-VA med findings. ;05/24/2006
|
||||
;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
|
||||
;
|
||||
;===============================================
|
||||
GETDATA(DAS,FIEVT) ;Return data for an non-VA med finding.
|
||||
;DBIA #3793
|
||||
D NVA^PSOPXRM1(DAS,.FIEVT)
|
||||
S FIEVT("VALUE")=FIEVT("STATUS")
|
||||
I $G(FIEVT("START DATE"))="" S FIEVT("START DATE")=FIEVT("DOCUMENTED DATE")
|
||||
S FIEVT("DURATION")=$$DURATION^PXRMDATE(FIEVT("START DATE"),FIEVT("DISCONTINUED DATE"))
|
||||
Q
|
||||
;
|
||||
;===============================================
|
||||
EVALTERM(DFN,FINDPA,ENODE,TERMARR,TFIEVAL) ;Evaluate terms.
|
||||
D EVALTERM^PXRMINDX(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL)
|
||||
Q
|
||||
;
|
||||
;====================================================
|
||||
MHVOUT(INDENT,IFIEVAL,NLINES,TEXT) ;Produce the MHV output.
|
||||
N JND,NOUT,TEMP,TEXTOUT
|
||||
S TEMP="Non-VA med: "_IFIEVAL("ORDERABLE ITEM")_" = "
|
||||
S TEMP=TEMP_"("_$$EDATE^PXRMDATE(IFIEVAL("START DATE"))
|
||||
S TEMP=TEMP_" - "_$$EDATE^PXRMDATE(IFIEVAL("STOP DATE"))_")"
|
||||
D FORMATS^PXRMTEXT(INDENT+2,PXRMRM,TEMP,.NOUT,.TEXTOUT)
|
||||
F JND=1:1:NOUT S NLINES=NLINES+1,TEXT(NLINES)=TEXTOUT(JND)
|
||||
Q
|
||||
;
|
||||
;===============================================
|
||||
OUTPUT(INDENT,IFIEVAL,NLINES,TEXT) ;Produce the clinical
|
||||
;maintenance output.
|
||||
N DATE,JND,NOUT,TEMP,TEXTOUT
|
||||
S NLINES=NLINES+1
|
||||
S TEXT(NLINES)=$$INSCHR^PXRMEXLC(INDENT," ")_"Non-VA med: "_IFIEVAL("ORDERABLE ITEM")
|
||||
S DATE=IFIEVAL("START DATE")
|
||||
S TEMP="Start Date: "_$$EDATE^PXRMDATE(DATE)
|
||||
S DATE=IFIEVAL("DISCONTINUED DATE")
|
||||
S DATE=$S(DATE="":"NONE",1:$$EDATE^PXRMDATE(DATE))
|
||||
S TEMP=TEMP_" Discontinued Date: "_DATE
|
||||
I $D(IFIEVAL("DURATION")) S TEMP=TEMP_" Duration: "_IFIEVAL("DURATION")_" D"
|
||||
S TEMP=TEMP_" Status: "_IFIEVAL("STATUS")_"\\"
|
||||
S TEMP=TEMP_"Dosage Form: "_IFIEVAL("DOSAGE FORM")
|
||||
S TEMP=TEMP_" Dosage: "_IFIEVAL("DOSAGE")
|
||||
S TEMP=TEMP_" Medication Route: "_IFIEVAL("MEDICATION ROUTE")
|
||||
D FORMATS^PXRMTEXT(INDENT+1,PXRMRM,TEMP,.NOUT,.TEXTOUT)
|
||||
F JND=1:1:NOUT S NLINES=NLINES+1,TEXT(NLINES)=TEXTOUT(JND)
|
||||
S NLINES=NLINES+1,TEXT(NLINES)=""
|
||||
Q
|
||||
;
|
||||
|
|
|
|||
|
|
@ -1,197 +1,184 @@
|
|||
PXRMDRGR ; SLC/PKR - Handle groups of drug findings. ;06/20/2007
|
||||
;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
|
||||
;Groups are drug classes or VA Generic.
|
||||
;==================================================
|
||||
EVALFI(DFN,DEFARR,ENODE,XREF,FIEVAL) ;Evaluate drug group findings.
|
||||
N DRGRIEN,FIEVT,FINDPA,FINDING,NOINDEX
|
||||
S NOINDEX=0
|
||||
I $G(^PXRMINDX(52,"DATE BUILT"))="" D
|
||||
. D NOINDEX^PXRMERRH("D",PXRMITEM,52)
|
||||
. S NOINDEX=1
|
||||
I $G(^PXRMINDX(55,"DATE BUILT"))="" D
|
||||
. D NOINDEX^PXRMERRH("D",PXRMITEM,55)
|
||||
. S NOINDEX=1
|
||||
S DRGRIEN=""
|
||||
F S DRGRIEN=$O(DEFARR("E",ENODE,DRGRIEN)) Q:+DRGRIEN=0 D
|
||||
. S FINDING=""
|
||||
. F S FINDING=$O(DEFARR("E",ENODE,DRGRIEN,FINDING)) Q:+FINDING=0 D
|
||||
.. I NOINDEX S FIEVAL(FINDING)=0 Q
|
||||
.. K FIEVT,FINDPA
|
||||
.. M FINDPA=DEFARR(20,FINDING)
|
||||
.. D FIEVAL(DFN,DRGRIEN,.FINDPA,.DEFARR,FINDING,XREF,.FIEVT)
|
||||
.. M FIEVAL(FINDING)=FIEVT
|
||||
.. S FIEVAL(FINDING,"FINDING")=$P(FINDPA(0),U,1)
|
||||
Q
|
||||
;
|
||||
;==================================================
|
||||
EVALPL(FINDPA,ENODE,XREF,TERMARR,PLIST) ;Evaluate drug group
|
||||
;terms for building patient lists.
|
||||
N DRGRIEN,NOINDEX,PFINDPA
|
||||
N TEMP,TFINDPA,TFINDING
|
||||
S NOINDEX=0
|
||||
I $G(^PXRMINDX(52,"DATE BUILT"))="" D
|
||||
. D NOINDEX^PXRMERRH("TR",TERMARR("IEN"),52)
|
||||
. S NOINDEX=1
|
||||
I $G(^PXRMINDX(55,"DATE BUILT"))="" D
|
||||
. D NOINDEX^PXRMERRH("TR",TERMARR("IEN"),55)
|
||||
. S NOINDEX=1
|
||||
I NOINDEX Q
|
||||
S DRGRIEN=""
|
||||
F S DRGRIEN=$O(TERMARR("E",ENODE,DRGRIEN)) Q:+DRGRIEN=0 D
|
||||
. S TFINDING=""
|
||||
. F S TFINDING=$O(TERMARR("E",ENODE,DRGRIEN,TFINDING)) Q:+TFINDING=0 D
|
||||
.. K PFINDPA,TFINDPA
|
||||
.. M TFINDPA=TERMARR(20,TFINDING)
|
||||
..;Set the finding parameters.
|
||||
.. D SPFINDPA^PXRMTERM(.FINDPA,.TFINDPA,.PFINDPA)
|
||||
.. D GPLIST(DRGRIEN,.PFINDPA,XREF,.PLIST)
|
||||
Q
|
||||
;
|
||||
;==================================================
|
||||
EVALTERM(DFN,FINDPA,ENODE,XREF,TERMARR,TFIEVAL) ;Evaluate drug
|
||||
;group terms.
|
||||
N DRGRIEN,FIEVT,NOINDEX,PFINDPA
|
||||
N TEMP,TFINDPA,TFINDING
|
||||
S NOINDEX=0
|
||||
I $G(^PXRMINDX(52,"DATE BUILT"))="" D
|
||||
. D NOINDEX^PXRMERRH("TR",TERMARR("IEN"),52)
|
||||
. S NOINDEX=1
|
||||
I $G(^PXRMINDX(55,"DATE BUILT"))="" D
|
||||
. D NOINDEX^PXRMERRH("TR",TERMARR("IEN"),55)
|
||||
. S NOINDEX=1
|
||||
S DRGRIEN=""
|
||||
F S DRGRIEN=$O(TERMARR("E",ENODE,DRGRIEN)) Q:+DRGRIEN=0 D
|
||||
. S TFINDING=""
|
||||
. F S TFINDING=$O(TERMARR("E",ENODE,DRGRIEN,TFINDING)) Q:+TFINDING=0 D
|
||||
.. I NOINDEX S TFIEVAL(TFINDING)=0 Q
|
||||
.. K FIEVT,PFINDPA,TFINDPA
|
||||
.. M TFINDPA=TERMARR(20,TFINDING)
|
||||
..;Set the finding parameters.
|
||||
.. D SPFINDPA^PXRMTERM(.FINDPA,.TFINDPA,.PFINDPA)
|
||||
.. D FIEVAL(DFN,DRGRIEN,.PFINDPA,.TERMARR,TFINDING,XREF,.FIEVT)
|
||||
.. M TFIEVAL(TFINDING)=FIEVT
|
||||
.. S TFIEVAL(TFINDING,"FINDING")=$P(TFINDPA(0),U,1)
|
||||
Q
|
||||
;
|
||||
;==================================================
|
||||
FIEVAL(DFN,DRGRIEN,FINDPA,DEFARR,FINDING,XREF,FIEVAL) ;
|
||||
N DATE,DATEORDR,DRBEG,DREND,DRUG,DRUGIEN,IND,FIEVT,FIEVTL
|
||||
N NOCC,NFOUND,POI,POIBEG,POIEND,POIIEN,RXTYL
|
||||
N SDIR,TDATE,TIND
|
||||
S NOCC=$P(FINDPA(0),U,14)
|
||||
I NOCC="" S NOCC=1
|
||||
S SDIR=$S(NOCC<0:+1,1:-1)
|
||||
S NOCC=$S(NOCC<0:-NOCC,1:NOCC)
|
||||
;Determine where we search.
|
||||
D SRXTYL^PXRMRXTY(FINDPA(0),.RXTYL)
|
||||
D GETPDR(DFN,.RXTYL,.DRBEG,.DREND,.POIBEG,.POIEND)
|
||||
I DREND=0,POIEND=0 S FIEVAL=0 Q
|
||||
S (DRUGIEN,NFOUND)=0
|
||||
F S DRUGIEN=+$O(^PSDRUG(XREF,DRGRIEN,DRUGIEN)) Q:DRUGIEN=0 D
|
||||
. I DRUGIEN'<DRBEG,DRUGIEN'>DREND S DRUG=DRUGIEN
|
||||
. E S DRUG=0
|
||||
.;DBIA #221
|
||||
. S POIIEN=$P($G(^PSDRUG(DRUGIEN,2)),U,1)
|
||||
. I POIIEN'<POIBEG,POIIEN'>POIEND S POI=POIIEN
|
||||
. E S POI=0
|
||||
. K FIEVT
|
||||
. D DEVAL^PXRMDRUG(DFN,.FINDPA,.DEFARR,FINDING,.RXTYL,DRUG,POI,.FIEVT)
|
||||
. I FIEVT D
|
||||
.. S IND=0
|
||||
.. F S IND=+$O(FIEVT(IND)) Q:IND=0 D
|
||||
...;Make sure this is not already on the list
|
||||
... I $$ONLIST(.FIEVTL,IND,.FIEVT) Q
|
||||
... S NFOUND=NFOUND+1,FIEVTL(NFOUND,"DISPENSE DRUG")=DRUGIEN
|
||||
... M FIEVTL(NFOUND)=FIEVT(IND)
|
||||
... S DATEORDR(FIEVT(IND,"DATE"),NFOUND)=FIEVT(IND,"FINDING")
|
||||
...;Don't keep more than NOCC occurrences on the list.
|
||||
... I NFOUND>NOCC D
|
||||
.... S TDATE=$O(DATEORDR(""),-SDIR),TIND=$O(DATEORDR(TDATE,""))
|
||||
.... K FIEVTL(TIND),DATEORDR(TDATE,TIND)
|
||||
I NFOUND=0 S FIEVAL=0 Q
|
||||
;Order by date.
|
||||
S DATE="",NFOUND=0
|
||||
F S DATE=$O(DATEORDR(DATE),SDIR) Q:(DATE="")!(NFOUND=NOCC) D
|
||||
. S IND=0
|
||||
. F S IND=$O(DATEORDR(DATE,IND)) Q:(IND="")!(NFOUND=NOCC) D
|
||||
.. S NFOUND=NFOUND+1
|
||||
.. M FIEVAL(NFOUND)=FIEVTL(IND)
|
||||
;Save the finding result.
|
||||
D SFRES^PXRMUTIL(SDIR,NFOUND,.FIEVAL)
|
||||
Q
|
||||
;
|
||||
;==================================================
|
||||
GETPDR(DFN,RXTYL,DRBEG,DREND,POIBEG,POIEND) ;Return the beginning drug and
|
||||
;ending drug for a patient.
|
||||
N IBEG,IEND,OBEG,OEND
|
||||
I $D(RXTYL("I")) D
|
||||
. S IBEG=+$O(^PXRMINDX(55,"PI",DFN,0))
|
||||
. S IEND=+$O(^PXRMINDX(55,"PI",DFN,""),-1)
|
||||
E S (IBEG,IEND)=0
|
||||
I $D(RXTYL("O")) D
|
||||
. S OBEG=+$O(^PXRMINDX(52,"PI",DFN,0))
|
||||
. S OEND=+$O(^PXRMINDX(52,"PI",DFN,""),-1)
|
||||
E S (OBEG,OEND)=0
|
||||
S DRBEG=$S(IBEG<OBEG:IBEG,1:OBEG)
|
||||
S DREND=$S(IEND>OEND:IEND,1:OEND)
|
||||
I $D(RXTYL("N")) D
|
||||
. S POIBEG=+$O(^PXRMINDX("55NVA","PI",DFN,0))
|
||||
. S POIEND=+$O(^PXRMINDX("55NVA","PI",DFN,""),-1)
|
||||
E S (POIBEG,POIEND)=0
|
||||
Q
|
||||
;
|
||||
;==================================================
|
||||
GPLIST(DRGRIEN,PFINDPA,XREF,PLIST) ;
|
||||
N DATE,DFN,DRUGIEN,FILENUM,IND,ITEM,NFOUND,NOCC,POI,RXTYL
|
||||
N TF,TEMP,TGLIST,TLIST
|
||||
S TGLIST="GPLIST_PXRMDRGR"
|
||||
K ^TMP($J,TGLIST)
|
||||
;Determine where we search.
|
||||
D SRXTYL^PXRMRXTY(PFINDPA(0),.RXTYL)
|
||||
S DRUGIEN=0
|
||||
F S DRUGIEN=$O(^PSDRUG(XREF,DRGRIEN,DRUGIEN)) Q:+DRUGIEN=0 D
|
||||
. ;DBIA #221
|
||||
. S POI=$P($G(^PSDRUG(DRUGIEN,2)),U,1)
|
||||
. I $D(RXTYL("I")) D GPLIST^PXRMINDL(55,"IP",DRUGIEN,.PFINDPA,TGLIST)
|
||||
. I $D(RXTYL("N")),POI'="" D GPLIST^PXRMINDL("55NVA","IP",POI,.PFINDPA,TGLIST)
|
||||
. I $D(RXTYL("O")) D GPLIST^PXRMINDL(52,"IP",DRUGIEN,.PFINDPA,TGLIST)
|
||||
;Return the NOCC most recent results for each DFN.
|
||||
S NOCC=$P(FINDPA(0),U,14)
|
||||
S NOCC=$S(NOCC<0:-NOCC,NOCC="":1,1:NOCC)
|
||||
F TF=0,1 D
|
||||
. S DFN=0
|
||||
. F S DFN=$O(^TMP($J,TGLIST,TF,DFN)) Q:DFN="" D
|
||||
.. K TLIST
|
||||
.. S ITEM=""
|
||||
.. F S ITEM=$O(^TMP($J,TGLIST,TF,DFN,ITEM)) Q:ITEM="" D
|
||||
... S NFOUND=""
|
||||
... F S NFOUND=$O(^TMP($J,TGLIST,TF,DFN,ITEM,NFOUND)) Q:NFOUND="" D
|
||||
.... S FILENUM=""
|
||||
.... F S FILENUM=$O(^TMP($J,TGLIST,TF,DFN,ITEM,NFOUND,FILENUM)) Q:FILENUM="" D
|
||||
..... S TEMP=^TMP($J,TGLIST,TF,DFN,ITEM,NFOUND,FILENUM)
|
||||
..... S DATE=+$P(TEMP,U,3)
|
||||
..... S TLIST(TF,DATE,ITEM,NFOUND,FILENUM)=""
|
||||
.. S DATE="",NFOUND=0
|
||||
.. F S DATE=$O(TLIST(TF,DATE),-1) Q:(DATE="")!(NFOUND=NOCC) D
|
||||
... S ITEM=""
|
||||
... F S ITEM=$O(TLIST(TF,DATE,ITEM)) Q:(ITEM="")!(NFOUND=NOCC) D
|
||||
.... S IND=""
|
||||
.... F S IND=$O(TLIST(TF,DATE,ITEM,IND)) Q:(IND="")!(NFOUND=NOCC) D
|
||||
..... S FILENUM=""
|
||||
..... F S FILENUM=$O(TLIST(TF,DATE,ITEM,IND,FILENUM)) Q:(FILENUM="")!(NFOUND=NOCC) D
|
||||
...... S NFOUND=NFOUND+1
|
||||
...... S ^TMP($J,PLIST,TF,DFN,ITEM,NFOUND,FILENUM)=^TMP($J,TGLIST,TF,DFN,ITEM,IND,FILENUM)
|
||||
K ^TMP($J,TGLIST)
|
||||
Q
|
||||
;
|
||||
;==================================================
|
||||
ONLIST(FIEVTL,IND,FIEVT) ;Return true if FIEVT(IND) is already on
|
||||
;FIEVTL.
|
||||
N JND,ONLIST
|
||||
S (JND,ONLIST)=0
|
||||
F S JND=$O(FIEVTL(JND)) Q:(ONLIST)!(JND="") D
|
||||
. I FIEVTL(JND,"FILE NUMBER")'=FIEVT(IND,"FILE NUMBER") Q
|
||||
. I FIEVTL(JND,"DAS")'=FIEVT(IND,"DAS") Q
|
||||
. S ONLIST=1
|
||||
Q ONLIST
|
||||
;
|
||||
PXRMDRGR ; SLC/PKR - Handle groups of drug findings. ;06/12/2006
|
||||
;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
|
||||
;Groups are drug classes or VA Generic.
|
||||
;==================================================
|
||||
EVALFI(DFN,DEFARR,ENODE,XREF,FIEVAL) ;Evaluate drug group findings.
|
||||
N DRGRIEN,FIEVT,FINDPA,FINDING,NOINDEX
|
||||
S NOINDEX=0
|
||||
I $G(^PXRMINDX(52,"DATE BUILT"))="" D
|
||||
. D NOINDEX^PXRMERRH("D",PXRMITEM,52)
|
||||
. S NOINDEX=1
|
||||
I $G(^PXRMINDX(55,"DATE BUILT"))="" D
|
||||
. D NOINDEX^PXRMERRH("D",PXRMITEM,55)
|
||||
. S NOINDEX=1
|
||||
S DRGRIEN=""
|
||||
F S DRGRIEN=$O(DEFARR("E",ENODE,DRGRIEN)) Q:+DRGRIEN=0 D
|
||||
. S FINDING=""
|
||||
. F S FINDING=$O(DEFARR("E",ENODE,DRGRIEN,FINDING)) Q:+FINDING=0 D
|
||||
.. I NOINDEX S FIEVAL(FINDING)=0 Q
|
||||
.. K FIEVT,FINDPA
|
||||
.. M FINDPA=DEFARR(20,FINDING)
|
||||
.. D FIEVAL(DFN,DRGRIEN,.FINDPA,.DEFARR,FINDING,XREF,.FIEVT)
|
||||
.. M FIEVAL(FINDING)=FIEVT
|
||||
.. S FIEVAL(FINDING,"FINDING")=$P(FINDPA(0),U,1)
|
||||
Q
|
||||
;
|
||||
;==================================================
|
||||
EVALPL(FINDPA,ENODE,XREF,TERMARR,PLIST) ;Evaluate drug group
|
||||
;terms for building patient lists.
|
||||
N DRGRIEN,NOINDEX,PFINDPA
|
||||
N TEMP,TFINDPA,TFINDING
|
||||
S NOINDEX=0
|
||||
I $G(^PXRMINDX(52,"DATE BUILT"))="" D
|
||||
. D NOINDEX^PXRMERRH("TR",TERMARR("IEN"),52)
|
||||
. S NOINDEX=1
|
||||
I $G(^PXRMINDX(55,"DATE BUILT"))="" D
|
||||
. D NOINDEX^PXRMERRH("TR",TERMARR("IEN"),55)
|
||||
. S NOINDEX=1
|
||||
I NOINDEX Q
|
||||
S DRGRIEN=""
|
||||
F S DRGRIEN=$O(TERMARR("E",ENODE,DRGRIEN)) Q:+DRGRIEN=0 D
|
||||
. S TFINDING=""
|
||||
. F S TFINDING=$O(TERMARR("E",ENODE,DRGRIEN,TFINDING)) Q:+TFINDING=0 D
|
||||
.. K PFINDPA,TFINDPA
|
||||
.. M TFINDPA=TERMARR(20,TFINDING)
|
||||
..;Set the finding parameters.
|
||||
.. D SPFINDPA^PXRMTERM(.FINDPA,.TFINDPA,.PFINDPA)
|
||||
.. D GPLIST(DRGRIEN,.PFINDPA,XREF,.PLIST)
|
||||
Q
|
||||
;
|
||||
;==================================================
|
||||
EVALTERM(DFN,FINDPA,ENODE,XREF,TERMARR,TFIEVAL) ;Evaluate drug
|
||||
;group terms.
|
||||
N DRGRIEN,FIEVT,NOINDEX,PFINDPA
|
||||
N TEMP,TFINDPA,TFINDING
|
||||
S NOINDEX=0
|
||||
I $G(^PXRMINDX(52,"DATE BUILT"))="" D
|
||||
. D NOINDEX^PXRMERRH("TR",TERMARR("IEN"),52)
|
||||
. S NOINDEX=1
|
||||
I $G(^PXRMINDX(55,"DATE BUILT"))="" D
|
||||
. D NOINDEX^PXRMERRH("TR",TERMARR("IEN"),55)
|
||||
. S NOINDEX=1
|
||||
S DRGRIEN=""
|
||||
F S DRGRIEN=$O(TERMARR("E",ENODE,DRGRIEN)) Q:+DRGRIEN=0 D
|
||||
. S TFINDING=""
|
||||
. F S TFINDING=$O(TERMARR("E",ENODE,DRGRIEN,TFINDING)) Q:+TFINDING=0 D
|
||||
.. I NOINDEX S TFIEVAL(TFINDING)=0 Q
|
||||
.. K FIEVT,PFINDPA,TFINDPA
|
||||
.. M TFINDPA=TERMARR(20,TFINDING)
|
||||
..;Set the finding parameters.
|
||||
.. D SPFINDPA^PXRMTERM(.FINDPA,.TFINDPA,.PFINDPA)
|
||||
.. D FIEVAL(DFN,DRGRIEN,.PFINDPA,.TERMARR,TFINDING,XREF,.FIEVT)
|
||||
.. M TFIEVAL(TFINDING)=FIEVT
|
||||
.. S TFIEVAL(TFINDING,"FINDING")=$P(TFINDPA(0),U,1)
|
||||
Q
|
||||
;
|
||||
;==================================================
|
||||
FIEVAL(DFN,DRGRIEN,FINDPA,DEFARR,FINDING,XREF,FIEVAL) ;
|
||||
N DATE,DATEORDR,DRBEG,DREND,DRUG,DRUGIEN,IND,FIEVT,FIEVTL
|
||||
N NOCC,NFOUND,POI,POIBEG,POIEND,POIIEN,RXTYL
|
||||
N SDIR,TDATE,TIND
|
||||
S NOCC=$P(FINDPA(0),U,14)
|
||||
I NOCC="" S NOCC=1
|
||||
S SDIR=$S(NOCC<0:+1,1:-1)
|
||||
S NOCC=$S(NOCC<0:-NOCC,1:NOCC)
|
||||
;Determine where we search.
|
||||
D SRXTYL^PXRMRXTY(FINDPA(0),.RXTYL)
|
||||
D GETPDR(DFN,.RXTYL,.DRBEG,.DREND,.POIBEG,.POIEND)
|
||||
I DREND=0,POIEND=0 S FIEVAL=0 Q
|
||||
S (DRUGIEN,NFOUND)=0
|
||||
F S DRUGIEN=+$O(^PSDRUG(XREF,DRGRIEN,DRUGIEN)) Q:DRUGIEN=0 D
|
||||
. I DRUGIEN'<DRBEG,DRUGIEN'>DREND S DRUG=DRUGIEN
|
||||
. E S DRUG=0
|
||||
.;DBIA #221
|
||||
. S POIIEN=$P($G(^PSDRUG(DRUGIEN,2)),U,1)
|
||||
. I POIIEN'<POIBEG,POIIEN'>POIEND S POI=POIIEN
|
||||
. E S POI=0
|
||||
. K FIEVT
|
||||
. D DEVAL^PXRMDRUG(DFN,.FINDPA,.DEFARR,FINDING,.RXTYL,DRUG,POI,.FIEVT)
|
||||
. I FIEVT D
|
||||
.. S IND=0
|
||||
.. F S IND=+$O(FIEVT(IND)) Q:IND=0 D
|
||||
... S NFOUND=NFOUND+1,FIEVTL(NFOUND,"DISPENSE DRUG")=DRUGIEN
|
||||
... M FIEVTL(NFOUND)=FIEVT(IND)
|
||||
... S DATEORDR(FIEVT(IND,"DATE"),NFOUND)=FIEVT(IND,"FINDING")
|
||||
...;Don't keep more than NOCC occurrences on the list.
|
||||
... I NFOUND>NOCC D
|
||||
.... S TDATE=$O(DATEORDR(""),-SDIR),TIND=$O(DATEORDR(TDATE,""))
|
||||
.... K FIEVTL(TIND),DATEORDR(TDATE,TIND)
|
||||
I NFOUND=0 S FIEVAL=0 Q
|
||||
;Order by date.
|
||||
S DATE="",NFOUND=0
|
||||
F S DATE=$O(DATEORDR(DATE),SDIR) Q:(DATE="")!(NFOUND=NOCC) D
|
||||
. S IND=0
|
||||
. F S IND=$O(DATEORDR(DATE,IND)) Q:(IND="")!(NFOUND=NOCC) D
|
||||
.. S NFOUND=NFOUND+1
|
||||
.. M FIEVAL(NFOUND)=FIEVTL(IND)
|
||||
;Save the finding result.
|
||||
D SFRES^PXRMUTIL(SDIR,NFOUND,.FIEVAL)
|
||||
Q
|
||||
;
|
||||
;==================================================
|
||||
GETPDR(DFN,RXTYL,DRBEG,DREND,POIBEG,POIEND) ;Return the beginning drug and
|
||||
;ending drug for a patient.
|
||||
N IBEG,IEND,OBEG,OEND
|
||||
I $D(RXTYL("I")) D
|
||||
. S IBEG=+$O(^PXRMINDX(55,"PI",DFN,0))
|
||||
. S IEND=+$O(^PXRMINDX(55,"PI",DFN,""),-1)
|
||||
E S (IBEG,IEND)=0
|
||||
I $D(RXTYL("O")) D
|
||||
. S OBEG=+$O(^PXRMINDX(52,"PI",DFN,0))
|
||||
. S OEND=+$O(^PXRMINDX(52,"PI",DFN,""),-1)
|
||||
E S (OBEG,OEND)=0
|
||||
S DRBEG=$S(IBEG<OBEG:IBEG,1:OBEG)
|
||||
S DREND=$S(IEND>OEND:IEND,1:OEND)
|
||||
I $D(RXTYL("N")) D
|
||||
. S POIBEG=+$O(^PXRMINDX("55NVA","PI",DFN,0))
|
||||
. S POIEND=+$O(^PXRMINDX("55NVA","PI",DFN,""),-1)
|
||||
E S (POIBEG,POIEND)=0
|
||||
Q
|
||||
;
|
||||
;==================================================
|
||||
GPLIST(DRGRIEN,PFINDPA,XREF,PLIST) ;
|
||||
N DATE,DFN,DRUGIEN,FILENUM,IND,ITEM,NFOUND,NOCC,POI,RXTYL
|
||||
N TF,TEMP,TGLIST,TLIST
|
||||
S TGLIST="GPLIST_PXRMDRGR"
|
||||
K ^TMP($J,TGLIST)
|
||||
;Determine where we search.
|
||||
D SRXTYL^PXRMRXTY(PFINDPA(0),.RXTYL)
|
||||
S DRUGIEN=0
|
||||
F S DRUGIEN=$O(^PSDRUG(XREF,DRGRIEN,DRUGIEN)) Q:+DRUGIEN=0 D
|
||||
. ;DBIA #221
|
||||
. S POI=$P($G(^PSDRUG(DRUGIEN,2)),U,1)
|
||||
. I $D(RXTYL("I")) D GPLIST^PXRMINDL(55,"IP",DRUGIEN,.PFINDPA,TGLIST)
|
||||
. I $D(RXTYL("N")),POI'="" D GPLIST^PXRMINDL("55NVA","IP",POI,.PFINDPA,TGLIST)
|
||||
. I $D(RXTYL("O")) D GPLIST^PXRMINDL(52,"IP",DRUGIEN,.PFINDPA,TGLIST)
|
||||
;Return the NOCC most recent results for each DFN.
|
||||
S NOCC=$P(FINDPA(0),U,14)
|
||||
S NOCC=$S(NOCC<0:-NOCC,NOCC="":1,1:NOCC)
|
||||
F TF=0,1 D
|
||||
. S DFN=0
|
||||
. F S DFN=$O(^TMP($J,TGLIST,TF,DFN)) Q:DFN="" D
|
||||
.. K TLIST
|
||||
.. S ITEM=""
|
||||
.. F S ITEM=$O(^TMP($J,TGLIST,TF,DFN,ITEM)) Q:ITEM="" D
|
||||
... S NFOUND=""
|
||||
... F S NFOUND=$O(^TMP($J,TGLIST,TF,DFN,ITEM,NFOUND)) Q:NFOUND="" D
|
||||
.... S FILENUM=""
|
||||
.... F S FILENUM=$O(^TMP($J,TGLIST,TF,DFN,ITEM,NFOUND,FILENUM)) Q:FILENUM="" D
|
||||
..... S TEMP=^TMP($J,TGLIST,TF,DFN,ITEM,NFOUND,FILENUM)
|
||||
..... S DATE=+$P(TEMP,U,3)
|
||||
..... S TLIST(TF,DATE,ITEM,NFOUND,FILENUM)=""
|
||||
.. S DATE="",NFOUND=0
|
||||
.. F S DATE=$O(TLIST(TF,DATE),-1) Q:(DATE="")!(NFOUND=NOCC) D
|
||||
... S ITEM=""
|
||||
... F S ITEM=$O(TLIST(TF,DATE,ITEM)) Q:(ITEM="")!(NFOUND=NOCC) D
|
||||
.... S IND=""
|
||||
.... F S IND=$O(TLIST(TF,DATE,ITEM,IND)) Q:(IND="")!(NFOUND=NOCC) D
|
||||
..... S FILENUM=""
|
||||
..... F S FILENUM=$O(TLIST(TF,DATE,ITEM,IND,FILENUM)) Q:(FILENUM="")!(NFOUND=NOCC) D
|
||||
...... S NFOUND=NFOUND+1
|
||||
...... S ^TMP($J,PLIST,TF,DFN,ITEM,NFOUND,FILENUM)=^TMP($J,TGLIST,TF,DFN,ITEM,IND,FILENUM)
|
||||
K ^TMP($J,TGLIST)
|
||||
Q
|
||||
;
|
||||
|
|
|
|||
|
|
@ -1,205 +1,203 @@
|
|||
PXRMDRUG ; SLC/PKR - Handle drug findings. ;04/23/2007
|
||||
;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
|
||||
;
|
||||
;===============================================
|
||||
DEVAL(DFN,FINDPA,DEFARR,FINDING,RXTYL,DRUG,POI,FIEVAL) ;Evaluate a drug
|
||||
;finding.
|
||||
I DRUG=0,POI=0 S FIEVAL=0 Q
|
||||
N DTERM,FIEVT
|
||||
;Create the pseudo term.
|
||||
S DTERM(0)="DTERM",DTERM("IEN")=0
|
||||
I $D(RXTYL("I")),DRUG>0 D
|
||||
. M DTERM(20,1)=DEFARR(20,FINDING)
|
||||
. S $P(DTERM(20,1,0),U,1)=DRUG_";PS(55,"
|
||||
. S DTERM("E","PS(55,",DRUG,1)=""
|
||||
I $D(RXTYL("O")),DRUG>0 D
|
||||
. M DTERM(20,3)=DEFARR(20,FINDING)
|
||||
. S $P(DTERM(20,3,0),U,1)=DRUG_";PSRX("
|
||||
. S DTERM("E","PSRX(",DRUG,3)=""
|
||||
I $D(RXTYL("N")),POI>0 D
|
||||
. M DTERM(20,2)=DEFARR(20,FINDING)
|
||||
. S $P(DTERM(20,2,0),U,1)=POI_";PS(55NVA,"
|
||||
. S DTERM("E","PS(55NVA,",POI,2)=""
|
||||
K FIEVT
|
||||
D IEVALTER^PXRMTERM(DFN,.FINDPA,.DTERM,1,.FIEVT)
|
||||
M FIEVAL=FIEVT(1)
|
||||
I FIEVAL S FIEVAL("FINDING")=DRUG_";PSDRUG(",FIEVAL("DISPENSE DRUG")=DRUG
|
||||
Q
|
||||
;
|
||||
;===============================================
|
||||
EVALFI(DFN,DEFARR,ENODE,FIEVAL) ;Evaluate drug findings.
|
||||
N DRUGIEN,DTERM,FIEVT,FINDPA,FINDING
|
||||
N NOINDEX,POI,RXTYL
|
||||
S NOINDEX=0
|
||||
I $G(^PXRMINDX(52,"DATE BUILT"))="" D
|
||||
. D NOINDEX^PXRMERRH("D",PXRMITEM,52)
|
||||
. S NOINDEX=1
|
||||
I $G(^PXRMINDX(55,"DATE BUILT"))="" D
|
||||
. D NOINDEX^PXRMERRH("D",PXRMITEM,55)
|
||||
. S NOINDEX=1
|
||||
S DRUGIEN=""
|
||||
F S DRUGIEN=$O(DEFARR("E",ENODE,DRUGIEN)) Q:+DRUGIEN=0 D
|
||||
. ;DBIA #221
|
||||
. S POI=$P($G(^PSDRUG(DRUGIEN,2)),U,1)
|
||||
. S FINDING=""
|
||||
. F S FINDING=$O(DEFARR("E",ENODE,DRUGIEN,FINDING)) Q:+FINDING=0 D
|
||||
.. I NOINDEX S FIEVAL(FINDING)=0 Q
|
||||
.. M FINDPA=DEFARR(20,FINDING)
|
||||
.. K FIEVT,RXTYL
|
||||
..;Determine where we search.
|
||||
.. D SRXTYL^PXRMRXTY(FINDPA(0),.RXTYL)
|
||||
.. D DEVAL(DFN,.FINDPA,.DEFARR,FINDING,.RXTYL,DRUGIEN,POI,.FIEVT)
|
||||
.. M FIEVAL(FINDING)=FIEVT
|
||||
Q
|
||||
;
|
||||
;===============================================
|
||||
EVALPL(FINDPA,ENODE,TERMARR,PLIST) ;Evaluate drug terms for
|
||||
;building patient lists.
|
||||
N BDT,EDT,DATE,DFN,DRUGIEN,ITEM,FILENUM,IND,LIST,NFOUND,NOCC,NOINDEX
|
||||
N PFINDPA,POI,RXTYL,TEMP,TF,TFINDPA,TFINDING,TGLIST,TLIST
|
||||
S NOINDEX=0
|
||||
I $G(^PXRMINDX(52,"DATE BUILT"))="" D
|
||||
. D NOINDEX^PXRMERRH("TR",TERMARR("IEN"),52)
|
||||
. S NOINDEX=1
|
||||
I $G(^PXRMINDX(55,"DATE BUILT"))="" D
|
||||
. D NOINDEX^PXRMERRH("TR",TERMARR("IEN"),55)
|
||||
. S NOINDEX=1
|
||||
I NOINDEX Q
|
||||
S TGLIST="EVALPL_PXRMDRUG"
|
||||
K ^TMP($J,TGLIST)
|
||||
S DRUGIEN=""
|
||||
F S DRUGIEN=$O(TERMARR("E",ENODE,DRUGIEN)) Q:+DRUGIEN=0 D
|
||||
. ;DBIA #221
|
||||
. S POI=$P($G(^PSDRUG(DRUGIEN,2)),U,1)
|
||||
. S TFINDING=""
|
||||
. F S TFINDING=$O(TERMARR("E",ENODE,DRUGIEN,TFINDING)) Q:+TFINDING=0 D
|
||||
.. K PFINDPA,TFINDPA
|
||||
.. M TFINDPA=TERMARR(20,TFINDING)
|
||||
..;Set the finding parameters.
|
||||
.. D SPFINDPA^PXRMTERM(.FINDPA,.TFINDPA,.PFINDPA)
|
||||
..;Determine where we search.
|
||||
.. D SRXTYL^PXRMRXTY(PFINDPA(0),.RXTYL)
|
||||
.. I $D(RXTYL("I")) D GPLIST^PXRMINDL(55,"IP",DRUGIEN,.PFINDPA,TGLIST)
|
||||
.. I $D(RXTYL("N")),POI'="" D GPLIST^PXRMINDL("55NVA","IP",POI,.PFINDPA,TGLIST)
|
||||
.. I $D(RXTYL("O")) D GPLIST^PXRMINDL(52,"IP",DRUGIEN,.PFINDPA,TGLIST)
|
||||
;Return the NOCC most recent results for each DFN.
|
||||
S NOCC=$P(FINDPA(0),U,14)
|
||||
S NOCC=$S(NOCC<0:-NOCC,NOCC="":1,1:NOCC)
|
||||
F TF=0,1 D
|
||||
. S DFN=0
|
||||
. F S DFN=$O(^TMP($J,TGLIST,TF,DFN)) Q:DFN="" D
|
||||
.. K TLIST
|
||||
.. S ITEM=""
|
||||
.. F S ITEM=$O(^TMP($J,TGLIST,TF,DFN,ITEM)) Q:ITEM="" D
|
||||
... S NFOUND=""
|
||||
... F S NFOUND=$O(^TMP($J,TGLIST,TF,DFN,ITEM,NFOUND)) Q:NFOUND="" D
|
||||
.... S FILENUM=""
|
||||
.... F S FILENUM=$O(^TMP($J,TGLIST,TF,DFN,ITEM,NFOUND,FILENUM)) Q:FILENUM="" D
|
||||
..... S TEMP=^TMP($J,TGLIST,TF,DFN,ITEM,NFOUND,FILENUM)
|
||||
..... S DATE=+$P(TEMP,U,3)
|
||||
..... S TLIST(TF,DATE,ITEM,NFOUND,FILENUM)=""
|
||||
.. S DATE="",NFOUND=0
|
||||
.. F S DATE=$O(TLIST(TF,DATE),-1) Q:(DATE="")!(NFOUND=NOCC) D
|
||||
... S ITEM=""
|
||||
... F S ITEM=$O(TLIST(TF,DATE,ITEM)) Q:(ITEM="")!(NFOUND=NOCC) D
|
||||
.... S IND=""
|
||||
.... F S IND=$O(TLIST(TF,DATE,ITEM,IND)) Q:(IND="")!(NFOUND=NOCC) D
|
||||
..... S FILENUM=""
|
||||
..... F S FILENUM=$O(TLIST(TF,DATE,ITEM,IND,FILENUM)) Q:(FILENUM="")!(NFOUND=NOCC) D
|
||||
...... S NFOUND=NFOUND+1
|
||||
...... S ^TMP($J,PLIST,TF,DFN,ITEM,NFOUND,FILENUM)=^TMP($J,TGLIST,TF,DFN,ITEM,IND,FILENUM)
|
||||
K ^TMP($J,TGLIST)
|
||||
Q
|
||||
;
|
||||
;===============================================
|
||||
EVALTERM(DFN,FINDPA,ENODE,TERMARR,TFIEVAL) ;Evaluate drug terms.
|
||||
N DATEORDR,DRUGIEN,DTERM,DTFIEVAL,IND,JND,NOINDEX,PFINDPA,POI
|
||||
N RXTYL,TEMP,TFINDING,TFINDPA
|
||||
N DATEORDR,NOCC,SDIR
|
||||
S NOINDEX=0
|
||||
I $G(^PXRMINDX(52,"DATE BUILT"))="" D
|
||||
. D NOINDEX^PXRMERRH("TR",TERMARR("IEN"),52)
|
||||
. S NOINDEX=1
|
||||
I $G(^PXRMINDX(55,"DATE BUILT"))="" D
|
||||
. D NOINDEX^PXRMERRH("TR",TERMARR("IEN"),55)
|
||||
. S NOINDEX=1
|
||||
;Set NOCC and SDIR.
|
||||
S NOCC=$P(FINDPA(0),U,14)
|
||||
I NOCC="" S NOCC=1
|
||||
S SDIR=$S(NOCC<0:+1,1:-1)
|
||||
S NOCC=$S(NOCC<0:-NOCC,1:NOCC)
|
||||
S DRUGIEN=""
|
||||
F S DRUGIEN=$O(TERMARR("E",ENODE,DRUGIEN)) Q:+DRUGIEN=0 D
|
||||
. ;DBIA #221
|
||||
. S POI=$P($G(^PSDRUG(DRUGIEN,2)),U,1)
|
||||
. S TFINDING=""
|
||||
. F S TFINDING=$O(TERMARR("E",ENODE,DRUGIEN,TFINDING)) Q:+TFINDING=0 D
|
||||
.. S TFIEVAL(TFINDING)=0
|
||||
.. I NOINDEX Q
|
||||
.. K DTERM,DTFIEVAL,PFINDPA,TFINDPA
|
||||
.. S DTERM(0)="DTERM",DTERM("IEN")=0
|
||||
.. M TFINDPA=TERMARR(20,TFINDING)
|
||||
..;Set the finding parameters.
|
||||
.. D SPFINDPA^PXRMTERM(.FINDPA,.TFINDPA,.PFINDPA)
|
||||
..;Determine where we search.
|
||||
.. D SRXTYL^PXRMRXTY(PFINDPA(0),.RXTYL)
|
||||
.. I $D(RXTYL("I")) D
|
||||
... M DTERM(20,1)=TERMARR(20,TFINDING)
|
||||
... S $P(DTERM(20,1,0),U,1)=DRUGIEN_";PS(55,"
|
||||
... S DTERM("E","PS(55,",DRUGIEN,1)=""
|
||||
.. I $D(RXTYL("N")),POI'="" D
|
||||
... M DTERM(20,2)=TERMARR(20,TFINDING)
|
||||
... S $P(DTERM(20,2,0),U,1)=POI_";PS(55NVA,"
|
||||
... S DTERM("E","PS(55NVA,",POI,2)=""
|
||||
.. I $D(RXTYL("O")) D
|
||||
... M DTERM(20,3)=TERMARR(20,TFINDING)
|
||||
... S $P(DTERM(20,3,0),U,1)=DRUGIEN_";PSRX("
|
||||
... S DTERM("E","PSRX(",DRUGIEN,3)=""
|
||||
.. D IEVALTER^PXRMTERM(DFN,.PFINDPA,.DTERM,TFINDING,.DTFIEVAL)
|
||||
.. D DORDER^PXRMTERM(.DTFIEVAL,.DATEORDR)
|
||||
.. D COPY^PXRMTERM(NOCC,SDIR,.DTFIEVAL,.DATEORDR,TFINDING,.TFIEVAL)
|
||||
..;Save the dispense drug
|
||||
.. S JND=0
|
||||
.. F S JND=+$O(TFIEVAL(TFINDING,JND)) Q:JND=0 S TFIEVAL(TFINDING,JND,"DISPENSE DRUG")=DRUGIEN
|
||||
Q
|
||||
;
|
||||
;===============================================
|
||||
MHVOUT(INDENT,IFIEVAL,NLINES,TEXT) ;Produce the MHV output.
|
||||
N DRUG,DRUGIEN,IND,FTYPE,NAME,PFIEVAL,TEMP
|
||||
S DRUGIEN=IFIEVAL("DISPENSE DRUG")
|
||||
;DBIA #10043
|
||||
S DRUG=$P(^PSDRUG(DRUGIEN,0),U,1)
|
||||
S NAME="Drug: "_DRUG_" = "
|
||||
S NLINES=NLINES+1
|
||||
S TEXT(NLINES)=$$INSCHR^PXRMEXLC(INDENT," ")_"Drug: "_DRUG
|
||||
S IND=0
|
||||
F S IND=+$O(IFIEVAL(IND)) Q:IND=0 D
|
||||
. S TEMP=IFIEVAL(IND,"FINDING")
|
||||
. S FTYPE=$P(TEMP,";",2)
|
||||
. K PFIEVAL M PFIEVAL=IFIEVAL(IND)
|
||||
. S PFIEVAL("DISPENSE DRUG")=DRUG
|
||||
. I FTYPE="PS(55," D MHVOUT^PXRMDIN(INDENT+1,.PFIEVAL,.NLINES,.TEXT) Q
|
||||
. I FTYPE="PS(55NVA," D MHVOUT^PXRMDNVA(INDENT+1,.PFIEVAL,.NLINES,.TEXT) Q
|
||||
. I FTYPE="PSRX(" D MHVOUT^PXRMDOUT(INDENT+1,.PFIEVAL,.NLINES,.TEXT) Q
|
||||
S NLINES=NLINES+1,TEXT(NLINES)=""
|
||||
Q
|
||||
;
|
||||
;===============================================
|
||||
OUTPUT(INDENT,IFIEVAL,NLINES,TEXT) ;Produce the clinical
|
||||
;maintenance output.
|
||||
N DRUG,FTYPE,IND,PFIEVAL,TEMP,TEXTOUT
|
||||
;DBIA #10043
|
||||
S DRUG=$P(^PSDRUG(IFIEVAL("DISPENSE DRUG"),0),U,1)
|
||||
S NLINES=NLINES+1
|
||||
S TEXT(NLINES)=$$INSCHR^PXRMEXLC(INDENT," ")_"Drug: "_DRUG
|
||||
S IND=0
|
||||
F S IND=+$O(IFIEVAL(IND)) Q:IND=0 D
|
||||
. S TEMP=IFIEVAL(IND,"FINDING")
|
||||
. S FTYPE=$P(TEMP,";",2)
|
||||
. K PFIEVAL M PFIEVAL=IFIEVAL(IND)
|
||||
. S PFIEVAL("DISPENSE DRUG")=DRUG
|
||||
. I FTYPE="PS(55," D OUTPUT^PXRMDIN(INDENT+1,.PFIEVAL,.NLINES,.TEXT) Q
|
||||
. I FTYPE="PS(55NVA," D OUTPUT^PXRMDNVA(INDENT+1,.PFIEVAL,.NLINES,.TEXT) Q
|
||||
. I FTYPE="PSRX(" D OUTPUT^PXRMDOUT(INDENT+1,.PFIEVAL,.NLINES,.TEXT) Q
|
||||
Q
|
||||
;
|
||||
PXRMDRUG ; SLC/PKR - Handle drug findings. ;06/08/2006
|
||||
;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
|
||||
;
|
||||
;===============================================
|
||||
DEVAL(DFN,FINDPA,DEFARR,FINDING,RXTYL,DRUG,POI,FIEVAL) ;Evaluate a drug
|
||||
;finding.
|
||||
I DRUG=0,POI=0 S FIEVAL=0 Q
|
||||
N DTERM,FIEVT
|
||||
;Create the pseudo term.
|
||||
S DTERM(0)="DTERM",DTERM("IEN")=0
|
||||
I $D(RXTYL("I")),DRUG>0 D
|
||||
. M DTERM(20,1)=DEFARR(20,FINDING)
|
||||
. S $P(DTERM(20,1,0),U,1)=DRUG_";PS(55,"
|
||||
. S DTERM("E","PS(55,",DRUG,1)=""
|
||||
I $D(RXTYL("O")),DRUG>0 D
|
||||
. M DTERM(20,3)=DEFARR(20,FINDING)
|
||||
. S $P(DTERM(20,3,0),U,1)=DRUG_";PSRX("
|
||||
. S DTERM("E","PSRX(",DRUG,3)=""
|
||||
I $D(RXTYL("N")),POI>0 D
|
||||
. M DTERM(20,2)=DEFARR(20,FINDING)
|
||||
. S $P(DTERM(20,2,0),U,1)=POI_";PS(55NVA,"
|
||||
. S DTERM("E","PS(55NVA,",POI,2)=""
|
||||
K FIEVT
|
||||
D IEVALTER^PXRMTERM(DFN,.FINDPA,.DTERM,1,.FIEVT)
|
||||
M FIEVAL=FIEVT(1)
|
||||
I FIEVAL S FIEVAL("FINDING")=DRUG_";PSDRUG(",FIEVAL("DISPENSE DRUG")=DRUG
|
||||
Q
|
||||
;
|
||||
;===============================================
|
||||
EVALFI(DFN,DEFARR,ENODE,FIEVAL) ;Evaluate drug findings.
|
||||
N DRUGIEN,DTERM,FIEVT,FINDPA,FINDING
|
||||
N NOINDEX,POI,RXTYL
|
||||
S NOINDEX=0
|
||||
I $G(^PXRMINDX(52,"DATE BUILT"))="" D
|
||||
. D NOINDEX^PXRMERRH("D",PXRMITEM,52)
|
||||
. S NOINDEX=1
|
||||
I $G(^PXRMINDX(55,"DATE BUILT"))="" D
|
||||
. D NOINDEX^PXRMERRH("D",PXRMITEM,55)
|
||||
. S NOINDEX=1
|
||||
S DRUGIEN=""
|
||||
F S DRUGIEN=$O(DEFARR("E",ENODE,DRUGIEN)) Q:+DRUGIEN=0 D
|
||||
. ;DBIA #221
|
||||
. S POI=$P($G(^PSDRUG(DRUGIEN,2)),U,1)
|
||||
. S FINDING=""
|
||||
. F S FINDING=$O(DEFARR("E",ENODE,DRUGIEN,FINDING)) Q:+FINDING=0 D
|
||||
.. I NOINDEX S FIEVAL(FINDING)=0 Q
|
||||
.. M FINDPA=DEFARR(20,FINDING)
|
||||
.. K FIEVT,RXTYL
|
||||
..;Determine where we search.
|
||||
.. D SRXTYL^PXRMRXTY(FINDPA(0),.RXTYL)
|
||||
.. D DEVAL(DFN,.FINDPA,.DEFARR,FINDING,.RXTYL,DRUGIEN,POI,.FIEVT)
|
||||
.. M FIEVAL(FINDING)=FIEVT
|
||||
Q
|
||||
;
|
||||
;===============================================
|
||||
EVALPL(FINDPA,ENODE,TERMARR,PLIST) ;Evaluate drug terms for
|
||||
;building patient lists.
|
||||
N BDT,EDT,DATE,DFN,DRUGIEN,ITEM,FILENUM,IND,LIST,NFOUND,NOCC,NOINDEX
|
||||
N PFINDPA,POI,RXTYL,TEMP,TF,TFINDPA,TFINDING,TGLIST,TLIST
|
||||
S NOINDEX=0
|
||||
I $G(^PXRMINDX(52,"DATE BUILT"))="" D
|
||||
. D NOINDEX^PXRMERRH("TR",TERMARR("IEN"),52)
|
||||
. S NOINDEX=1
|
||||
I $G(^PXRMINDX(55,"DATE BUILT"))="" D
|
||||
. D NOINDEX^PXRMERRH("TR",TERMARR("IEN"),55)
|
||||
. S NOINDEX=1
|
||||
I NOINDEX Q
|
||||
S TGLIST="EVALPL_PXRMDRUG"
|
||||
K ^TMP($J,TGLIST)
|
||||
S DRUGIEN=""
|
||||
F S DRUGIEN=$O(TERMARR("E",ENODE,DRUGIEN)) Q:+DRUGIEN=0 D
|
||||
. ;DBIA #221
|
||||
. S POI=$P($G(^PSDRUG(DRUGIEN,2)),U,1)
|
||||
. S TFINDING=""
|
||||
. F S TFINDING=$O(TERMARR("E",ENODE,DRUGIEN,TFINDING)) Q:+TFINDING=0 D
|
||||
.. K PFINDPA,TFINDPA
|
||||
.. M TFINDPA=TERMARR(20,TFINDING)
|
||||
..;Set the finding parameters.
|
||||
.. D SPFINDPA^PXRMTERM(.FINDPA,.TFINDPA,.PFINDPA)
|
||||
..;Determine where we search.
|
||||
.. D SRXTYL^PXRMRXTY(PFINDPA(0),.RXTYL)
|
||||
.. I $D(RXTYL("I")) D GPLIST^PXRMINDL(55,"IP",DRUGIEN,.PFINDPA,TGLIST)
|
||||
.. I $D(RXTYL("N")),POI'="" D GPLIST^PXRMINDL("55NVA","IP",POI,.PFINDPA,TGLIST)
|
||||
.. I $D(RXTYL("O")) D GPLIST^PXRMINDL(52,"IP",DRUGIEN,.PFINDPA,TGLIST)
|
||||
;Return the NOCC most recent results for each DFN.
|
||||
S NOCC=$P(FINDPA(0),U,14)
|
||||
S NOCC=$S(NOCC<0:-NOCC,NOCC="":1,1:NOCC)
|
||||
F TF=0,1 D
|
||||
. S DFN=0
|
||||
. F S DFN=$O(^TMP($J,TGLIST,TF,DFN)) Q:DFN="" D
|
||||
.. K TLIST
|
||||
.. S ITEM=""
|
||||
.. F S ITEM=$O(^TMP($J,TGLIST,TF,DFN,ITEM)) Q:ITEM="" D
|
||||
... S NFOUND=""
|
||||
... F S NFOUND=$O(^TMP($J,TGLIST,TF,DFN,ITEM,NFOUND)) Q:NFOUND="" D
|
||||
.... S FILENUM=""
|
||||
.... F S FILENUM=$O(^TMP($J,TGLIST,TF,DFN,ITEM,NFOUND,FILENUM)) Q:FILENUM="" D
|
||||
..... S TEMP=^TMP($J,TGLIST,TF,DFN,ITEM,NFOUND,FILENUM)
|
||||
..... S DATE=+$P(TEMP,U,3)
|
||||
..... S TLIST(TF,DATE,ITEM,NFOUND,FILENUM)=""
|
||||
.. S DATE="",NFOUND=0
|
||||
.. F S DATE=$O(TLIST(TF,DATE),-1) Q:(DATE="")!(NFOUND=NOCC) D
|
||||
... S ITEM=""
|
||||
... F S ITEM=$O(TLIST(TF,DATE,ITEM)) Q:(ITEM="")!(NFOUND=NOCC) D
|
||||
.... S IND=""
|
||||
.... F S IND=$O(TLIST(TF,DATE,ITEM,IND)) Q:(IND="")!(NFOUND=NOCC) D
|
||||
..... S FILENUM=""
|
||||
..... F S FILENUM=$O(TLIST(TF,DATE,ITEM,IND,FILENUM)) Q:(FILENUM="")!(NFOUND=NOCC) D
|
||||
...... S NFOUND=NFOUND+1
|
||||
...... S ^TMP($J,PLIST,TF,DFN,ITEM,NFOUND,FILENUM)=^TMP($J,TGLIST,TF,DFN,ITEM,IND,FILENUM)
|
||||
K ^TMP($J,TGLIST)
|
||||
Q
|
||||
;
|
||||
;===============================================
|
||||
EVALTERM(DFN,FINDPA,ENODE,TERMARR,TFIEVAL) ;Evaluate drug terms.
|
||||
N DATEORDR,DRUGIEN,DTERM,DTFIEVAL,IND,NOINDEX,PFINDPA,POI
|
||||
N RXTYL,TEMP,TFINDING,TFINDPA
|
||||
N DATEORDR,NOCC,SDIR
|
||||
S NOINDEX=0
|
||||
I $G(^PXRMINDX(52,"DATE BUILT"))="" D
|
||||
. D NOINDEX^PXRMERRH("TR",TERMARR("IEN"),52)
|
||||
. S NOINDEX=1
|
||||
I $G(^PXRMINDX(55,"DATE BUILT"))="" D
|
||||
. D NOINDEX^PXRMERRH("TR",TERMARR("IEN"),55)
|
||||
. S NOINDEX=1
|
||||
;Set NOCC and SDIR.
|
||||
S NOCC=$P(FINDPA(0),U,14)
|
||||
I NOCC="" S NOCC=1
|
||||
S SDIR=$S(NOCC<0:+1,1:-1)
|
||||
S NOCC=$S(NOCC<0:-NOCC,1:NOCC)
|
||||
S DRUGIEN=""
|
||||
F S DRUGIEN=$O(TERMARR("E",ENODE,DRUGIEN)) Q:+DRUGIEN=0 D
|
||||
. ;DBIA #221
|
||||
. S POI=$P($G(^PSDRUG(DRUGIEN,2)),U,1)
|
||||
. S TFINDING=""
|
||||
. F S TFINDING=$O(TERMARR("E",ENODE,DRUGIEN,TFINDING)) Q:+TFINDING=0 D
|
||||
.. S TFIEVAL(TFINDING)=0
|
||||
.. I NOINDEX Q
|
||||
.. K DTERM,DTFIEVAL,PFINDPA,TFINDPA
|
||||
.. S DTERM(0)="DTERM",DTERM("IEN")=0
|
||||
.. M TFINDPA=TERMARR(20,TFINDING)
|
||||
..;Set the finding parameters.
|
||||
.. D SPFINDPA^PXRMTERM(.FINDPA,.TFINDPA,.PFINDPA)
|
||||
..;Determine where we search.
|
||||
.. D SRXTYL^PXRMRXTY(PFINDPA(0),.RXTYL)
|
||||
.. I $D(RXTYL("I")) D
|
||||
... M DTERM(20,1)=TERMARR(20,TFINDING)
|
||||
... S $P(DTERM(20,1,0),U,1)=DRUGIEN_";PS(55,"
|
||||
... S DTERM("E","PS(55,",DRUGIEN,1)=""
|
||||
.. I $D(RXTYL("N")),POI'="" D
|
||||
... M DTERM(20,2)=TERMARR(20,TFINDING)
|
||||
... S $P(DTERM(20,2,0),U,1)=POI_";PS(55NVA,"
|
||||
... S DTERM("E","PS(55NVA,",POI,2)=""
|
||||
.. I $D(RXTYL("O")) D
|
||||
... M DTERM(20,3)=TERMARR(20,TFINDING)
|
||||
... S $P(DTERM(20,3,0),U,1)=DRUGIEN_";PSRX("
|
||||
... S DTERM("E","PSRX(",DRUGIEN,3)=""
|
||||
.. D IEVALTER^PXRMTERM(DFN,.PFINDPA,.DTERM,TFINDING,.DTFIEVAL)
|
||||
.. D DORDER^PXRMTERM(.DTFIEVAL,.DATEORDR)
|
||||
.. D COPY^PXRMTERM(NOCC,SDIR,.DTFIEVAL,.DATEORDR,TFINDING,.TFIEVAL)
|
||||
.. I TFIEVAL(TFINDING) S TFIEVAL(TFINDING,"DISPENSE DRUG")=DRUGIEN
|
||||
Q
|
||||
;
|
||||
;===============================================
|
||||
MHVOUT(INDENT,IFIEVAL,NLINES,TEXT) ;Produce the MHV output.
|
||||
N DRUG,DRUGIEN,IND,FTYPE,NAME,PFIEVAL,TEMP
|
||||
S DRUGIEN=IFIEVAL("DISPENSE DRUG")
|
||||
;DBIA #10043
|
||||
S DRUG=$P(^PSDRUG(DRUGIEN,0),U,1)
|
||||
S NAME="Drug: "_DRUG_" = "
|
||||
S NLINES=NLINES+1
|
||||
S TEXT(NLINES)=$$INSCHR^PXRMEXLC(INDENT," ")_"Drug: "_DRUG
|
||||
S IND=0
|
||||
F S IND=+$O(IFIEVAL(IND)) Q:IND=0 D
|
||||
. S TEMP=IFIEVAL(IND,"FINDING")
|
||||
. S FTYPE=$P(TEMP,";",2)
|
||||
. K PFIEVAL M PFIEVAL=IFIEVAL(IND)
|
||||
. S PFIEVAL("DISPENSE DRUG")=DRUG
|
||||
. I FTYPE="PS(55," D MHVOUT^PXRMDIN(INDENT+1,.PFIEVAL,.NLINES,.TEXT) Q
|
||||
. I FTYPE="PS(55NVA," D MHVOUT^PXRMDNVA(INDENT+1,.PFIEVAL,.NLINES,.TEXT) Q
|
||||
. I FTYPE="PSRX(" D MHVOUT^PXRMDOUT(INDENT+1,.PFIEVAL,.NLINES,.TEXT) Q
|
||||
S NLINES=NLINES+1,TEXT(NLINES)=""
|
||||
Q
|
||||
;
|
||||
;===============================================
|
||||
OUTPUT(INDENT,IFIEVAL,NLINES,TEXT) ;Produce the clinical
|
||||
;maintenance output.
|
||||
N DRUG,FTYPE,IND,PFIEVAL,TEMP,TEXTOUT
|
||||
;DBIA #10043
|
||||
S DRUG=$P(^PSDRUG(IFIEVAL("DISPENSE DRUG"),0),U,1)
|
||||
S NLINES=NLINES+1
|
||||
S TEXT(NLINES)=$$INSCHR^PXRMEXLC(INDENT," ")_"Drug: "_DRUG
|
||||
S IND=0
|
||||
F S IND=+$O(IFIEVAL(IND)) Q:IND=0 D
|
||||
. S TEMP=IFIEVAL(IND,"FINDING")
|
||||
. S FTYPE=$P(TEMP,";",2)
|
||||
. K PFIEVAL M PFIEVAL=IFIEVAL(IND)
|
||||
. S PFIEVAL("DISPENSE DRUG")=DRUG
|
||||
. I FTYPE="PS(55," D OUTPUT^PXRMDIN(INDENT+1,.PFIEVAL,.NLINES,.TEXT) Q
|
||||
. I FTYPE="PS(55NVA," D OUTPUT^PXRMDNVA(INDENT+1,.PFIEVAL,.NLINES,.TEXT) Q
|
||||
. I FTYPE="PSRX(" D OUTPUT^PXRMDOUT(INDENT+1,.PFIEVAL,.NLINES,.TEXT) Q
|
||||
Q
|
||||
;
|
||||
|
|
|
|||
|
|
@ -1,21 +1,18 @@
|
|||
PXRMEDIT ; SLC/PKR - Clinical Reminder edit driver. ;06/04/2007
|
||||
;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
|
||||
;
|
||||
EDIT(ROOT,IENN) ;Call the appropriate edit routine.
|
||||
;Reminder location list
|
||||
I ROOT="^PXRMD(810.9," D EDIT^PXRMLLED(ROOT,IENN) Q
|
||||
;
|
||||
;Taxonomy
|
||||
I ROOT="^PXD(811.2," D EDIT^PXRMTEDT(ROOT,IENN) Q
|
||||
;
|
||||
;Reminder term
|
||||
I ROOT="^PXRMD(811.5," D EDIT^PXRMTMED(ROOT,IENN) Q
|
||||
;
|
||||
;Reminder definition
|
||||
I ROOT="^PXD(811.9," D
|
||||
.;Build list of finding types for finding edit
|
||||
. N DEF,DEF1,DEF2 D DEF^PXRMRUTL("811.902",.DEF,.DEF1,.DEF2)
|
||||
.;Edit reminder
|
||||
. D ALL^PXRMREDT(ROOT,IENN) Q
|
||||
Q
|
||||
;
|
||||
PXRMEDIT ; SLC/PKR - Clinical Reminder edit driver. ;05/18/2000
|
||||
;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
|
||||
;
|
||||
EDIT(ROOT,IENN) ;Call the appropriate edit routine.
|
||||
;Taxonomy
|
||||
I ROOT="^PXD(811.2," D EDIT^PXRMTEDT(ROOT,IENN) Q
|
||||
;
|
||||
;Reminder term
|
||||
I ROOT="^PXRMD(811.5," D EDIT^PXRMTMED(ROOT,IENN) Q
|
||||
;
|
||||
;Reminder
|
||||
I ROOT="^PXD(811.9," D
|
||||
.;Build list of finding types for finding edit
|
||||
. N DEF,DEF1,DEF2 D DEF^PXRMRUTL("811.902",.DEF,.DEF1,.DEF2)
|
||||
.;Edit reminder
|
||||
. D ALL^PXRMREDT(ROOT,IENN) Q
|
||||
Q
|
||||
;
|
||||
|
|
|
|||
|
|
@ -1,50 +1,49 @@
|
|||
PXRMENOD ; SLC/PKR - Clinical Reminders "E" node routines. ;12/13/2006
|
||||
;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
|
||||
;
|
||||
;========================================================
|
||||
KENODE(X,DA,FILENUM) ;Kill the enode in the finding multiple for definitions
|
||||
;and terms.
|
||||
;Do not execute as part of a verify fields.
|
||||
I $G(DIUTIL)="VERIFY FIELDS" Q
|
||||
N DAS,GLOBAL,IEN
|
||||
S IEN=$P(X,";",1)
|
||||
S GLOBAL=$P(X,";",2)
|
||||
I GLOBAL="LAB(60," D
|
||||
. N SUB
|
||||
.;DBIA #91-A
|
||||
. S SUB=$P(^LAB(60,IEN,0),U,4)
|
||||
. I SUB="CH" Q
|
||||
. I (SUB="BB")!(SUB="WK") S IEN="" Q
|
||||
. I SUB="MI" S IEN="M;T;"_IEN Q
|
||||
.;All other SUB values: AU, CY, EM, SP
|
||||
. S IEN="A;T;"_IEN
|
||||
S DAS=IEN
|
||||
I DAS="" Q
|
||||
I FILENUM=811.5 K ^PXRMD(811.5,DA(1),20,"E",GLOBAL,DAS,DA)
|
||||
I FILENUM=811.9 K ^PXD(811.9,DA(1),20,"E",GLOBAL,DAS,DA)
|
||||
Q
|
||||
;
|
||||
;========================================================
|
||||
SENODE(X,DA,FILENUM) ;Set the enode in the finding multiple for definitions
|
||||
;and terms.
|
||||
;Do not execute as part of a verify fields.
|
||||
I $G(DIUTIL)="VERIFY FIELDS" Q
|
||||
N DAS,GLOBAL,IEN,NAME
|
||||
S IEN=$P(X,";",1)
|
||||
S GLOBAL=$P(X,";",2)
|
||||
I GLOBAL="LAB(60," D
|
||||
. N SUB
|
||||
.;DBIA #91-A
|
||||
. S SUB=$P(^LAB(60,IEN,0),U,4)
|
||||
. I SUB="CH" Q
|
||||
. I (SUB="BB")!(SUB="WK") S IEN="" Q
|
||||
. I SUB="MI" S IEN="M;T;"_IEN Q
|
||||
.;All other SUB values: AU, CY, EM, SP
|
||||
. S IEN="A;T;"_IEN
|
||||
S DAS=IEN
|
||||
I DAS="" Q
|
||||
S NAME=""
|
||||
I FILENUM=811.5 S ^PXRMD(811.5,DA(1),20,"E",GLOBAL,DAS,DA)=NAME
|
||||
I FILENUM=811.9 S ^PXD(811.9,DA(1),20,"E",GLOBAL,DAS,DA)=NAME
|
||||
Q
|
||||
;
|
||||
PXRMENOD ; SLC/PKR - Clinical Reminders "E" node routines. ;04/17/2006
|
||||
;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
|
||||
;
|
||||
;========================================================
|
||||
KENODE(X,DA,FILENUM) ;Kill the enode in the finding multiple for definitions
|
||||
;and terms.
|
||||
;Do not execute as part of a verify fields.
|
||||
I $G(DIUTIL)="VERIFY FIELDS" Q
|
||||
N DAS,GLOBAL,IEN
|
||||
S IEN=$P(X,";",1)
|
||||
S GLOBAL=$P(X,";",2)
|
||||
I GLOBAL="LAB(60," D
|
||||
. N SUB
|
||||
.;DBIA #91-A
|
||||
. S SUB=$P(^LAB(60,IEN,0),U,4)
|
||||
. I SUB="CH" Q
|
||||
. I (SUB="BB")!(SUB="WK") S IEN="" Q
|
||||
. I SUB="MI" S IEN="M;T;"_IEN Q
|
||||
.;All other SUB values: AU, CY, EM, SP
|
||||
. S IEN="A;T;"_IEN
|
||||
S DAS=IEN
|
||||
I DAS="" Q
|
||||
I FILENUM=811.5 K ^PXRMD(811.5,DA(1),20,"E",GLOBAL,DAS,DA)
|
||||
I FILENUM=811.9 K ^PXD(811.9,DA(1),20,"E",GLOBAL,DAS,DA)
|
||||
Q
|
||||
;
|
||||
;========================================================
|
||||
SENODE(X,DA,FILENUM) ;Set the enode in the finding multiple for definitions
|
||||
;and terms.
|
||||
;Do not execute as part of a verify fields.
|
||||
I $G(DIUTIL)="VERIFY FIELDS" Q
|
||||
N DAS,GLOBAL,IEN
|
||||
S IEN=$P(X,";",1)
|
||||
S GLOBAL=$P(X,";",2)
|
||||
I GLOBAL="LAB(60," D
|
||||
. N SUB
|
||||
.;DBIA #91-A
|
||||
. S SUB=$P(^LAB(60,IEN,0),U,4)
|
||||
. I SUB="CH" Q
|
||||
. I (SUB="BB")!(SUB="WK") S IEN="" Q
|
||||
. I SUB="MI" S IEN="M;T;"_IEN Q
|
||||
.;All other SUB values: AU, CY, EM, SP
|
||||
. S IEN="A;T;"_IEN
|
||||
S DAS=IEN
|
||||
I DAS="" Q
|
||||
I FILENUM=811.5 S ^PXRMD(811.5,DA(1),20,"E",GLOBAL,DAS,DA)=""
|
||||
I FILENUM=811.9 S ^PXD(811.9,DA(1),20,"E",GLOBAL,DAS,DA)=""
|
||||
Q
|
||||
;
|
||||
|
|
|
|||
|
|
@ -1,174 +1,180 @@
|
|||
PXRMEPM ; SLC/PKR/PJH - Extract Definition Management ;07/17/2007
|
||||
;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
|
||||
;
|
||||
;Main entry point for PXRM EXTRACT DEFINITIONS
|
||||
START N PXRMDONE,VALMBCK,VALMCNT,VALMSG,X,XMZ,XQORM,XQORNOD
|
||||
S X="IORESET"
|
||||
D ENDR^%ZISS
|
||||
S VALMCNT=0
|
||||
D EN^VALM("PXRM EXTRACT DEFINITIONS")
|
||||
Q
|
||||
;
|
||||
BLDLIST ;Build workfile
|
||||
K ^TMP("PXRMEPM",$J)
|
||||
N IEN,IND,PLIST
|
||||
D LIST^PXRMETM("PXRMEPM",.VALMCNT)
|
||||
Q
|
||||
;
|
||||
ENTRY ;Entry code
|
||||
D BLDLIST,XQORM
|
||||
Q
|
||||
;
|
||||
EXIT ;Exit code
|
||||
K ^TMP("PXRMEPM",$J)
|
||||
K ^TMP("PXRMEPMH",$J)
|
||||
D CLEAN^VALM10
|
||||
D FULL^VALM1
|
||||
S VALMBCK="Q"
|
||||
Q
|
||||
;
|
||||
HDR ; Header code
|
||||
S VALMSG="+ Next Screen - Prev Screen ?? More Actions"
|
||||
Q
|
||||
;
|
||||
HLP ;Help code
|
||||
N ORU,ORUPRMT,SUB,XQORM
|
||||
S SUB="PXRMEPMH"
|
||||
D EN^VALM("PXRM EXTRACT HELP")
|
||||
Q
|
||||
;
|
||||
INIT ;Init
|
||||
S VALMCNT=0
|
||||
Q
|
||||
;
|
||||
PEXIT ;PXRM EXCH MENU protocol exit code
|
||||
S VALMSG="+ Next Screen - Prev Screen ?? More Actions"
|
||||
;Reset after page up/down etc
|
||||
D XQORM
|
||||
Q
|
||||
;
|
||||
XQORM S XQORM("#")=$O(^ORD(101,"B","PXRM EXTRACT DEFINITION SELECT ENTRY",0))_U_"1:"_VALMCNT
|
||||
S XQORM("A")="Select Item: "
|
||||
Q
|
||||
;
|
||||
XSEL ;PXRM EXTRACT DEFINITION SELECT ENTRY validation
|
||||
N SEL,IEN
|
||||
S SEL=$P(XQORNOD(0),"=",2)
|
||||
;Remove trailing ,
|
||||
I $E(SEL,$L(SEL))="," S SEL=$E(SEL,1,$L(SEL)-1)
|
||||
;Invalid selection
|
||||
I SEL["," D Q
|
||||
.W $C(7),!,"Only one item number allowed." H 2
|
||||
.S VALMBCK="R"
|
||||
I ('SEL)!(SEL>VALMCNT)!('$D(@VALMAR@("SEL",SEL))) D Q
|
||||
.W $C(7),!,SEL_" is not a valid item number." H 2
|
||||
.S VALMBCK="R"
|
||||
;
|
||||
;Get the list ien.
|
||||
S IEN=^TMP("PXRMEPM",$J,"SEL",SEL)
|
||||
;Display/Edit Extract Definition
|
||||
D START^PXRMEPED(IEN)
|
||||
D BLDLIST
|
||||
S VALMBCK="R"
|
||||
Q
|
||||
;
|
||||
HELP(CALL) ;General help text routine
|
||||
N HTEXT
|
||||
I CALL=1 D
|
||||
.S HTEXT(1)="Select DE to display or edit a definition."
|
||||
.S HTEXT(2)="Select ED to edit a definition"
|
||||
D HELP^PXRMEUT(.HTEXT)
|
||||
Q
|
||||
;
|
||||
EPADD ;Add Rule Option
|
||||
;Reset Screen Mode
|
||||
W IORESET
|
||||
;
|
||||
;Add Rule
|
||||
D ADD^PXRMEPED
|
||||
;
|
||||
;Rebuild Workfile
|
||||
D BLDLIST
|
||||
S VALMBCK="R"
|
||||
Q
|
||||
;
|
||||
EPINQ ;Definition Inquiry - PXRM EXTRACT DEFINITION DISPLAY/EDIT entry
|
||||
N IND,LRIEN,VALMY
|
||||
D EN^VALM2(XQORNOD(0))
|
||||
;
|
||||
;If there is no list quit.
|
||||
I '$D(VALMY) Q
|
||||
S PXRMDONE=0
|
||||
S IND=""
|
||||
F S IND=$O(VALMY(IND)) Q:(+IND=0)!(PXRMDONE) D
|
||||
.;Get the ien.
|
||||
.S LRIEN=^TMP("PXRMEPM",$J,"SEL",IND)
|
||||
.D START^PXRMEPED(LRIEN)
|
||||
D BLDLIST
|
||||
S VALMBCK="R"
|
||||
Q
|
||||
;
|
||||
PPLR ;Display rule set components
|
||||
;used by [PXRM EXTRACT DEFINITION] template)
|
||||
N ACT,DATA,FIRST,IEN,LRDATA,LRIEN,SEQ,SUB
|
||||
S IEN=$P(X,U,2) Q:'IEN
|
||||
W !," Description: ",$P($G(^PXRM(810.4,IEN,0)),U,2)
|
||||
S SEQ="",FIRST=1
|
||||
F S SEQ=$O(^PXRM(810.4,IEN,30,"B",SEQ)) Q:'SEQ D
|
||||
.S SUB=$O(^PXRM(810.4,IEN,30,"B",SEQ,"")) Q:'SUB
|
||||
.S DATA=$G(^PXRM(810.4,IEN,30,SUB,0)) Q:DATA=""
|
||||
.S LRIEN=$P(DATA,U,2) Q:LRIEN=""
|
||||
.S ACT=$P(DATA,U,3),LRDATA=$G(^PXRM(810.4,LRIEN,0))
|
||||
.I FIRST W !!,?2,"List Rules:" S FIRST=0
|
||||
.W !,?2,SEQ,?7,$P(LRDATA,U),?66
|
||||
.W $S(ACT="A":"ADD PATIENT",ACT="R":"REMOVE PATIENT",ACT="F":"INSERT FINDING",1:"SELECT PATIENT")
|
||||
.;Display List Rule fields
|
||||
.D LROUT^PXRMLRED(LRIEN,23)
|
||||
.W !
|
||||
Q
|
||||
;
|
||||
PPFR ;Display counting rules and count type
|
||||
;used by [PXRM EXTRACT DEFINITION] template)
|
||||
W !
|
||||
N DATA,GIEN,GSTATUS,IEN,SEQ,SUB
|
||||
S IEN=$P(X,U,3) Q:'IEN
|
||||
S SEQ=""
|
||||
F S SEQ=$O(^PXRM(810.7,IEN,10,"B",SEQ)) Q:SEQ="" D
|
||||
.S SUB=$O(^PXRM(810.7,IEN,10,"B",SEQ,"")) Q:'SUB
|
||||
.S DATA=$G(^PXRM(810.7,IEN,10,SUB,0)) Q:DATA=""
|
||||
.S GIEN=$P(DATA,U,2) Q:GIEN=""
|
||||
.S GSTATUS=$P(DATA,U,3)
|
||||
.;Get counting groups
|
||||
.N CTYP,CTXT,DATA,EXCL,FIRST,GNAME,PNAME,TIEN,TNAME,GSEQ,GSUB
|
||||
.S DATA=$G(^PXRM(810.8,GIEN,0)),GNAME=$P(DATA,U)
|
||||
.S CTYP=$P(DATA,U,3),PNAME=$P(DATA,U,2),GSEQ="",FIRST=1
|
||||
.S CTXT=$$TXT(CTYP,GSTATUS)
|
||||
.F S GSEQ=$O(^PXRM(810.8,GIEN,10,"B",GSEQ)) Q:GSEQ="" D
|
||||
..S GSUB=$O(^PXRM(810.8,GIEN,10,"B",GSEQ,"")) Q:'GSUB
|
||||
..S DATA=$G(^PXRM(810.8,GIEN,10,GSUB,0)) Q:DATA=""
|
||||
..S TIEN=$P(DATA,U,2) Q:TIEN=""
|
||||
..S EXCL=$P(DATA,U,3) Q:EXCL="E"
|
||||
..S TNAME=$P($G(^PXRMD(811.5,TIEN,0)),U)
|
||||
..I FIRST D
|
||||
...W !,?14,SEQ
|
||||
...W ?18,"Counting Group: ",GNAME
|
||||
...W !,?18,$$TXT(CTYP,GSTATUS)
|
||||
...W !,?23,"Terms:" S FIRST=0
|
||||
..W ?30,TNAME,!
|
||||
Q
|
||||
;
|
||||
SCREEN ;Screen for 810.210 field .02
|
||||
S DIC("S")="I $P(^(0),U,3)=3"
|
||||
Q
|
||||
;
|
||||
TXT(COUNT,COHORT) ;Text to describe group
|
||||
N TXT
|
||||
;Determine count type
|
||||
I COUNT="MRFP" S TXT="Most recent finding patient counts for "
|
||||
I COUNT="MRF" S TXT="Most recent finding counts for "
|
||||
I COUNT="UR" S TXT="Utilization in period finding counts for "
|
||||
;Error
|
||||
I $G(TXT)="" Q "Unknown count type - error"
|
||||
;Determine cohort
|
||||
S TXT=TXT_$S(COHORT="A":"APPLICABLE",1:"TOTAL")_" patients"
|
||||
Q TXT
|
||||
PXRMEPM ; SLC/PKR/PJH - Extract Definition Management ;06/21/2006
|
||||
;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
|
||||
;
|
||||
;Main entry point for PXRM EXTRACT DEFINITIONS
|
||||
START N PXRMDONE,VALMBCK,VALMCNT,VALMSG,X,XMZ,XQORM,XQORNOD
|
||||
S X="IORESET"
|
||||
D ENDR^%ZISS
|
||||
S VALMCNT=0
|
||||
D EN^VALM("PXRM EXTRACT DEFINITIONS")
|
||||
Q
|
||||
;
|
||||
BLDLIST ;Build workfile
|
||||
K ^TMP("PXRMEPM",$J)
|
||||
N IEN,IND,PLIST
|
||||
D LIST^PXRMETM(.PLIST,.IEN)
|
||||
M ^TMP("PXRMEPM",$J)=PLIST
|
||||
S VALMCNT=PLIST("VALMCNT")
|
||||
F IND=1:1:VALMCNT D
|
||||
.S ^TMP("PXRMEPM",$J,"IDX",IND,IND)=IEN(IND)
|
||||
Q
|
||||
;
|
||||
ENTRY ;Entry code
|
||||
D BLDLIST,XQORM
|
||||
Q
|
||||
;
|
||||
EXIT ;Exit code
|
||||
K ^TMP("PXRMEPM",$J)
|
||||
K ^TMP("PXRMEPMH",$J)
|
||||
D CLEAN^VALM10
|
||||
D FULL^VALM1
|
||||
S VALMBCK="Q"
|
||||
Q
|
||||
;
|
||||
HDR ; Header code
|
||||
S VALMSG="+ Next Screen - Prev Screen ?? More Actions"
|
||||
Q
|
||||
;
|
||||
HLP ;Help code
|
||||
N ORU,ORUPRMT,SUB,XQORM
|
||||
S SUB="PXRMEPMH"
|
||||
D EN^VALM("PXRM EXTRACT HELP")
|
||||
Q
|
||||
;
|
||||
INIT ;Init
|
||||
S VALMCNT=0
|
||||
Q
|
||||
;
|
||||
PEXIT ;PXRM EXCH MENU protocol exit code
|
||||
S VALMSG="+ Next Screen - Prev Screen ?? More Actions"
|
||||
;Reset after page up/down etc
|
||||
D XQORM
|
||||
Q
|
||||
;
|
||||
XQORM S XQORM("#")=$O(^ORD(101,"B","PXRM EXTRACT DEFINITION SELECT ENTRY",0))_U_"1:"_VALMCNT
|
||||
S XQORM("A")="Select Item: "
|
||||
Q
|
||||
;
|
||||
XSEL ;PXRM EXTRACT DEFINITION SELECT ENTRY validation
|
||||
N SEL,IEN
|
||||
S SEL=$P(XQORNOD(0),"=",2)
|
||||
;Remove trailing ,
|
||||
I $E(SEL,$L(SEL))="," S SEL=$E(SEL,1,$L(SEL)-1)
|
||||
;Invalid selection
|
||||
I SEL["," D Q
|
||||
.W $C(7),!,"Only one item number allowed." H 2
|
||||
.S VALMBCK="R"
|
||||
I ('SEL)!(SEL>VALMCNT)!('$D(@VALMAR@("IDX",SEL))) D Q
|
||||
.W $C(7),!,SEL_" is not a valid item number." H 2
|
||||
.S VALMBCK="R"
|
||||
;
|
||||
;Get the list ien.
|
||||
S IEN=^TMP("PXRMEPM",$J,"IDX",SEL,SEL)
|
||||
;Display/Edit Extract Definition
|
||||
D START^PXRMEPED(IEN)
|
||||
D BLDLIST
|
||||
S VALMBCK="R"
|
||||
Q
|
||||
;
|
||||
HELP(CALL) ;General help text routine
|
||||
N HTEXT
|
||||
I CALL=1 D
|
||||
.S HTEXT(1)="Select DE to display or edit a definition."
|
||||
.S HTEXT(2)="Select ED to edit a definition"
|
||||
D HELP^PXRMEUT(.HTEXT)
|
||||
Q
|
||||
;
|
||||
EPADD ;Add Rule Option
|
||||
;
|
||||
;Reset Screen Mode
|
||||
W IORESET
|
||||
;
|
||||
;Add Rule
|
||||
D ADD^PXRMEPED
|
||||
;
|
||||
;Rebuild Workfile
|
||||
D BLDLIST
|
||||
;
|
||||
S VALMBCK="R"
|
||||
Q
|
||||
;
|
||||
EPINQ ;Definition Inquiry - PXRM EXTRACT DEFINITION DISPLAY/EDIT entry
|
||||
N IND,LRIEN,VALMY
|
||||
D EN^VALM2(XQORNOD(0))
|
||||
;
|
||||
;If there is no list quit.
|
||||
I '$D(VALMY) Q
|
||||
S PXRMDONE=0
|
||||
S IND=""
|
||||
F S IND=$O(VALMY(IND)) Q:(+IND=0)!(PXRMDONE) D
|
||||
.;Get the ien.
|
||||
.S LRIEN=^TMP("PXRMEPM",$J,"IDX",IND,IND)
|
||||
.D START^PXRMEPED(LRIEN)
|
||||
D BLDLIST
|
||||
S VALMBCK="R"
|
||||
Q
|
||||
;
|
||||
PPLR ;Display rule set components
|
||||
;used by [PXRM EXTRACT DEFINITION] template)
|
||||
N ACT,DATA,FIRST,IEN,LRDATA,LRIEN,SEQ,SUB
|
||||
S IEN=$P(X,U,2) Q:'IEN
|
||||
W !," Description: ",$P($G(^PXRM(810.4,IEN,0)),U,2)
|
||||
S SEQ="",FIRST=1
|
||||
F S SEQ=$O(^PXRM(810.4,IEN,30,"B",SEQ)) Q:'SEQ D
|
||||
.S SUB=$O(^PXRM(810.4,IEN,30,"B",SEQ,"")) Q:'SUB
|
||||
.S DATA=$G(^PXRM(810.4,IEN,30,SUB,0)) Q:DATA=""
|
||||
.S LRIEN=$P(DATA,U,2) Q:LRIEN=""
|
||||
.S ACT=$P(DATA,U,3),LRDATA=$G(^PXRM(810.4,LRIEN,0))
|
||||
.I FIRST W !!,?2,"List Rules:" S FIRST=0
|
||||
.W !,?2,SEQ,?7,$P(LRDATA,U),?66
|
||||
.W $S(ACT="A":"ADD PATIENT",ACT="R":"REMOVE PATIENT",ACT="F":"INSERT FINDING",1:"SELECT PATIENT")
|
||||
.;Display List Rule fields
|
||||
.D LROUT^PXRMLRED(LRIEN,23)
|
||||
.W !
|
||||
Q
|
||||
;
|
||||
PPFR ;Display counting rules and count type
|
||||
;used by [PXRM EXTRACT DEFINITION] template)
|
||||
W !
|
||||
N DATA,GIEN,GSTATUS,IEN,SEQ,SUB
|
||||
S IEN=$P(X,U,3) Q:'IEN
|
||||
S SEQ=""
|
||||
F S SEQ=$O(^PXRM(810.7,IEN,10,"B",SEQ)) Q:SEQ="" D
|
||||
.S SUB=$O(^PXRM(810.7,IEN,10,"B",SEQ,"")) Q:'SUB
|
||||
.S DATA=$G(^PXRM(810.7,IEN,10,SUB,0)) Q:DATA=""
|
||||
.S GIEN=$P(DATA,U,2) Q:GIEN=""
|
||||
.S GSTATUS=$P(DATA,U,3)
|
||||
.;Get counting groups
|
||||
.N CTYP,CTXT,DATA,EXCL,FIRST,GNAME,PNAME,TIEN,TNAME,GSEQ,GSUB
|
||||
.S DATA=$G(^PXRM(810.8,GIEN,0)),GNAME=$P(DATA,U)
|
||||
.S CTYP=$P(DATA,U,3),PNAME=$P(DATA,U,2),GSEQ="",FIRST=1
|
||||
.S CTXT=$$TXT(CTYP,GSTATUS)
|
||||
.F S GSEQ=$O(^PXRM(810.8,GIEN,10,"B",GSEQ)) Q:GSEQ="" D
|
||||
..S GSUB=$O(^PXRM(810.8,GIEN,10,"B",GSEQ,"")) Q:'GSUB
|
||||
..S DATA=$G(^PXRM(810.8,GIEN,10,GSUB,0)) Q:DATA=""
|
||||
..S TIEN=$P(DATA,U,2) Q:TIEN=""
|
||||
..S EXCL=$P(DATA,U,3) Q:EXCL="E"
|
||||
..S TNAME=$P($G(^PXRMD(811.5,TIEN,0)),U)
|
||||
..I FIRST D
|
||||
...W !,?14,SEQ
|
||||
...W ?18,"Counting Group: ",GNAME
|
||||
...W !,?18,$$TXT(CTYP,GSTATUS)
|
||||
...W !,?23,"Terms:" S FIRST=0
|
||||
..W ?30,TNAME,!
|
||||
Q
|
||||
;
|
||||
SCREEN ;Screen for 810.210 field .02
|
||||
S DIC("S")="I $P(^(0),U,3)=3"
|
||||
Q
|
||||
;
|
||||
TXT(COUNT,COHORT) ;Text to describe group
|
||||
N TXT
|
||||
;Determine count type
|
||||
I COUNT="MRFP" S TXT="Most recent finding patient counts for "
|
||||
I COUNT="MRF" S TXT="Most recent finding counts for "
|
||||
I COUNT="UR" S TXT="Utilization in period finding counts for "
|
||||
;Error
|
||||
I $G(TXT)="" Q "Unknown count type - error"
|
||||
;Determine cohort
|
||||
S TXT=TXT_$S(COHORT="A":"APPLICABLE",1:"TOTAL")_" patients"
|
||||
Q TXT
|
||||
|
|
|
|||
|
|
@ -1,147 +1,144 @@
|
|||
PXRMETCO ; SLC/PJH - QUERI Extract Compliance Report ;03/27/2007
|
||||
;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
|
||||
;
|
||||
;
|
||||
ADHOC(IEN,PXRMSTRT,PXRMSTOP) ;Ad Hoc Conformance Report
|
||||
D DUMMY1^PXRMRUTL
|
||||
Q
|
||||
;
|
||||
D JOB
|
||||
Q
|
||||
;
|
||||
;BOOKMARK - cloned from PXRMETX, needs modifying to avoid patient list
|
||||
;update. Build ^TMP("PXRMETX",$J) for report
|
||||
;
|
||||
REPORT ;Initialise
|
||||
K ^TMP("PXRMETX",$J)
|
||||
;Workfile node for ^TMP
|
||||
S PXRMNODE="PXRMRULE"
|
||||
;Get details from parameter file
|
||||
N DATA,DATES,LIST,NAME,PARTYPE,TEXT
|
||||
;N PERIOD,TEXT,YEAR
|
||||
S DATA=$G(^PXRM(810.2,IEN,0))
|
||||
;
|
||||
;Determine Extract Name and period
|
||||
S NAME=$P(DATA,U),PARTYPE=$P(DATA,U,2)
|
||||
;S YEAR=$P(NEXT,"/",2),PERIOD=$P(NEXT,"/")
|
||||
;Calculate report period start and end dates
|
||||
;D CALC^PXRMEUT(NEXT,.PXRMSTRT,.PXRMSTOP)
|
||||
;Determine output name for patient list and extract summary
|
||||
S DATES=$$FMTE^XLFDT(PXRMSTRT)_" - "_$$FMTE^XLFDT(PXRMSTOP)
|
||||
;
|
||||
;Bookmark - Needs inventive patient list names
|
||||
S LIST=NAME_" REPORT "_DATES
|
||||
;Process (single) Denominator rule into patient list
|
||||
N INDP,INTP,SEQ,SUB,SUFFIX
|
||||
S SEQ=""
|
||||
F S SEQ=$O(^PXRM(810.2,IEN,10,"B",SEQ)) Q:'SEQ D
|
||||
.S SUB=$O(^PXRM(810.2,IEN,10,"B",SEQ,"")) Q:'SUB
|
||||
.S DATA=$G(^PXRM(810.2,IEN,10,SUB,0)) Q:DATA=""
|
||||
.S PXRMRULE=$P(DATA,U,2) Q:'PXRMRULE
|
||||
.S SUFFIX=$P(DATA,U,3)
|
||||
.I SUFFIX="" S SUFFIX="DENOMINATOR "_SEQ
|
||||
.S INDP=+$P(DATA,U,4)
|
||||
.S INTP=+$P(DATA,U,5)
|
||||
.;Create new patient list
|
||||
.S PXRMLIST=$$CRLST^PXRMRUL1(LIST_" "_SUFFIX) Q:'PXRMLIST
|
||||
.D START^PXRMRULE(PXRMRULE,PXRMLIST,PXRMNODE,PXRMSTRT,PXRMSTOP,IEN,INDP,INTP)
|
||||
.;Clear ^TMP lists created for rule
|
||||
.D CLEAR^PXRMRULE(PXRMRULE,PXRMNODE)
|
||||
.;Process reminders
|
||||
.D REM^PXRMETXR(SUB,PXRMLIST)
|
||||
;
|
||||
;Bookmark - Report stuff goes here
|
||||
;Update totals section
|
||||
N APPL,DUE,DATA,ETYP,EVAL
|
||||
N FAPPL,FCNT,FDATA,FDUE,FEVAL,FGNAM,FIND,FNAPPL,FNDUE,FSEQ
|
||||
N NAPPL,NDUE,PXRMLIST,RCNT,RIEN,RSEQ,SEQ
|
||||
S SEQ=0,CNT=1
|
||||
F S SEQ=$O(^TMP("PXRMETX",$J,SEQ)) Q:'SEQ D
|
||||
.S RCNT=0,RSEQ=0
|
||||
.F S RCNT=$O(^TMP("PXRMETX",$J,SEQ,RCNT)) Q:'RCNT D
|
||||
..S DATA=$G(^TMP("PXRMETX",$J,SEQ,RCNT)) Q:'DATA
|
||||
..S RIEN=$P(DATA,U),PXRMLIST=$P(DATA,U,5)
|
||||
..S EVAL=$P(DATA,U,2),APPL=$P(DATA,U,3),DUE=$P(DATA,U,4)
|
||||
..S NAPPL=EVAL-APPL,NDUE=APPL-DUE
|
||||
..S CNT=CNT+1,RSEQ=RSEQ+1
|
||||
..;bookmark - write patient line
|
||||
..;For each count type
|
||||
..S ETYP="",FCNT=CNT
|
||||
..F S ETYP=$O(^TMP("PXRMETX",$J,SEQ,RCNT,ETYP)) Q:ETYP="" D
|
||||
...;For each term
|
||||
...S FIND=0,FSEQ=0
|
||||
...F S FIND=$O(^TMP("PXRMETX",$J,SEQ,RCNT,ETYP,FIND)) Q:FIND="" D
|
||||
....;Update finding totals
|
||||
....S FDATA=$G(^TMP("PXRMETX",$J,SEQ,RCNT,ETYP,FIND)),FCNT=FCNT+1
|
||||
....S FEVAL=$P(FDATA,U,2),FAPPL=$P(FDATA,U,3),FDUE=$P(FDATA,U,4)
|
||||
....S FNAPPL=FEVAL-FAPPL,FNDUE=FAPPL-FDUE
|
||||
....S FSEQ=FSEQ+1,FGNAM=$P(DATA,U,9)
|
||||
....;Bookmark - write finding line
|
||||
..;Update CNT
|
||||
..S CNT=FCNT
|
||||
Q
|
||||
;
|
||||
;Determine whether the report should be queued.
|
||||
JOB ;
|
||||
N %ZIS,ZTDESC,ZTSAVE,ZTRTN,ZTSK
|
||||
S DBDUZ=DUZ
|
||||
D SAVE^PXRMXQUE
|
||||
S %ZIS="Q"
|
||||
S ZTDESC="QUERI Compliance Report - print"
|
||||
S ZTRTN="REPORT^PXRMETCO"
|
||||
S ZTSK=1
|
||||
S PXRMQUE=0
|
||||
S PXRMQUE=$$DEVICE^PXRMXQUE(ZTRTN,ZTDESC,.ZTSAVE,.%ZIS,.ZTSK)
|
||||
I PXRMQUE=1 G EXIT
|
||||
I PXRMQUE>0 S ^XTMP(PXRMXTMP,"PRZTSK")=PXRMQUE
|
||||
Q
|
||||
;
|
||||
EXIT ;Clean things up.
|
||||
D ^%ZISC
|
||||
D HOME^%ZIS
|
||||
K IO("Q")
|
||||
K DIRUT,DTOUT,DUOUT,POP,ZTREQ
|
||||
I $D(ZTSK) D KILL^%ZTLOAD
|
||||
K ZTSK,ZTQUEUED
|
||||
K ^TMP("PXRMXTR",$J)
|
||||
Q
|
||||
;
|
||||
SAVE ;Save the variables for queing.
|
||||
S ZTSAVE("IEN")=""
|
||||
S ZTSAVE("PXRMSTRT")=""
|
||||
S ZTSAVE("PXRMSTOP")=""
|
||||
Q
|
||||
;
|
||||
;
|
||||
QUE ;BOOKMARK - NOT USED
|
||||
;Queue the MST synchronization job.
|
||||
N DIR,DTOUT,DUOUT,MINDT,SDTIME,STIME,X,Y
|
||||
S MINDT=$$NOW^XLFDT
|
||||
W !,"Queue the Clinical Reminders MST synchronization."
|
||||
S DIR("A",1)="Enter the date and time you want the job to start."
|
||||
S DIR("A",2)="It must be after "_$$FMTE^XLFDT(MINDT,"5Z")
|
||||
S DIR("A")="Start the task at: "
|
||||
S DIR(0)="DAU"_U_MINDT_"::RSX"
|
||||
D ^DIR
|
||||
I $D(DTOUT)!$D(DUOUT) Q
|
||||
S SDTIME=Y
|
||||
K DIR
|
||||
S DIR(0)="YA"
|
||||
S DIR("A")="Do you want to run the MST synchronization at the same time every day? "
|
||||
S DIR("B")="Y"
|
||||
D ^DIR
|
||||
I $D(DTOUT)!$D(DUOUT) Q
|
||||
I Y S STIME="1."_$P(SDTIME,".",2)
|
||||
E S STIME=-1
|
||||
;
|
||||
;Put the task into the queue.
|
||||
K ZTSAVE
|
||||
;S ZTSAVE("START")=SDTIME
|
||||
S ZTSAVE("STIME")=STIME
|
||||
S ZTRTN="SYNCH^PXRMMST"
|
||||
S ZTDESC="Clinical Reminders MST synchronization job"
|
||||
S ZTDTH=SDTIME
|
||||
S ZTIO=""
|
||||
D ^%ZTLOAD
|
||||
W !,"Task number ",ZTSK," queued."
|
||||
Q
|
||||
PXRMETCO ; SLC/PJH - QUERI Extract Compliance Report ;01/19/2005
|
||||
;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
|
||||
;
|
||||
;
|
||||
ADHOC(IEN,PXRMSTRT,PXRMSTOP) ;Ad Hoc Conformance Report
|
||||
D DUMMY1^PXRMRUTL
|
||||
Q
|
||||
;
|
||||
D JOB
|
||||
Q
|
||||
;
|
||||
;BOOKMARK - cloned from PXRMETX, needs modifying to avoid patient list
|
||||
;update. Build ^TMP("PXRMETX",$J) for report
|
||||
;
|
||||
REPORT ;Initialise
|
||||
K ^TMP("PXRMETX",$J)
|
||||
;Workfile node for ^TMP
|
||||
S PXRMNODE="PXRMRULE"
|
||||
;Get details from parameter file
|
||||
N DATA,DATES,LIST,NAME,PARTYPE,TEXT
|
||||
;N PERIOD,TEXT,YEAR
|
||||
S DATA=$G(^PXRM(810.2,IEN,0))
|
||||
;
|
||||
;Determine Extract Name and period
|
||||
S NAME=$P(DATA,U),PARTYPE=$P(DATA,U,2)
|
||||
;S YEAR=$P(NEXT,"/",2),PERIOD=$P(NEXT,"/")
|
||||
;Calculate report period start and end dates
|
||||
;D CALC^PXRMEUT(NEXT,.PXRMSTRT,.PXRMSTOP)
|
||||
;Determine output name for patient list and extract summary
|
||||
S DATES=$$FMTE^XLFDT(PXRMSTRT)_" - "_$$FMTE^XLFDT(PXRMSTOP)
|
||||
;
|
||||
;Bookmark - Needs inventive patient list names
|
||||
S LIST=NAME_" REPORT "_DATES
|
||||
;Process (single) Denominator rule into patient list
|
||||
N SEQ,SUB,SUFFIX
|
||||
S SEQ=""
|
||||
F S SEQ=$O(^PXRM(810.2,IEN,10,"B",SEQ)) Q:'SEQ D
|
||||
.S SUB=$O(^PXRM(810.2,IEN,10,"B",SEQ,"")) Q:'SUB
|
||||
.S DATA=$G(^PXRM(810.2,IEN,10,SUB,0)) Q:DATA=""
|
||||
.S PXRMRULE=$P(DATA,U,2) Q:'PXRMRULE
|
||||
.S SUFFIX=$P(DATA,U,3)
|
||||
.I SUFFIX="" S SUFFIX="DENOMINATOR "_SEQ
|
||||
.;Create new patient list
|
||||
.S PXRMLIST=$$CRLST^PXRMRULE(LIST_" "_SUFFIX) Q:'PXRMLIST
|
||||
.D START^PXRMRULE(PXRMRULE,PXRMLIST,PXRMNODE,PXRMSTRT,PXRMSTOP,IEN,"","")
|
||||
.;Clear ^TMP lists created for rule
|
||||
.D CLEAR^PXRMRULE(PXRMRULE,PXRMNODE)
|
||||
.;Process reminders
|
||||
.D REM^PXRMETXR(SUB,PXRMLIST)
|
||||
;
|
||||
;Bookmark - Report stuff goes here
|
||||
;Update totals section
|
||||
N APPL,DUE,DATA,ETYP,EVAL
|
||||
N FAPPL,FCNT,FDATA,FDUE,FEVAL,FGNAM,FIND,FNAPPL,FNDUE,FSEQ
|
||||
N NAPPL,NDUE,PXRMLIST,RCNT,RIEN,RSEQ,SEQ
|
||||
S SEQ=0,CNT=1
|
||||
F S SEQ=$O(^TMP("PXRMETX",$J,SEQ)) Q:'SEQ D
|
||||
.S RCNT=0,RSEQ=0
|
||||
.F S RCNT=$O(^TMP("PXRMETX",$J,SEQ,RCNT)) Q:'RCNT D
|
||||
..S DATA=$G(^TMP("PXRMETX",$J,SEQ,RCNT)) Q:'DATA
|
||||
..S RIEN=$P(DATA,U),PXRMLIST=$P(DATA,U,5)
|
||||
..S EVAL=$P(DATA,U,2),APPL=$P(DATA,U,3),DUE=$P(DATA,U,4)
|
||||
..S NAPPL=EVAL-APPL,NDUE=APPL-DUE
|
||||
..S CNT=CNT+1,RSEQ=RSEQ+1
|
||||
..;bookmark - write patient line
|
||||
..;For each count type
|
||||
..S ETYP="",FCNT=CNT
|
||||
..F S ETYP=$O(^TMP("PXRMETX",$J,SEQ,RCNT,ETYP)) Q:ETYP="" D
|
||||
...;For each term
|
||||
...S FIND=0,FSEQ=0
|
||||
...F S FIND=$O(^TMP("PXRMETX",$J,SEQ,RCNT,ETYP,FIND)) Q:FIND="" D
|
||||
....;Update finding totals
|
||||
....S FDATA=$G(^TMP("PXRMETX",$J,SEQ,RCNT,ETYP,FIND)),FCNT=FCNT+1
|
||||
....S FEVAL=$P(FDATA,U,2),FAPPL=$P(FDATA,U,3),FDUE=$P(FDATA,U,4)
|
||||
....S FNAPPL=FEVAL-FAPPL,FNDUE=FAPPL-FDUE
|
||||
....S FSEQ=FSEQ+1,FGNAM=$P(DATA,U,9)
|
||||
....;Bookmark - write finding line
|
||||
..;Update CNT
|
||||
..S CNT=FCNT
|
||||
Q
|
||||
;
|
||||
;Determine whether the report should be queued.
|
||||
JOB ;
|
||||
N %ZIS,ZTDESC,ZTSAVE,ZTRTN,ZTSK
|
||||
S DBDUZ=DUZ
|
||||
D SAVE^PXRMXQUE
|
||||
S %ZIS="Q"
|
||||
S ZTDESC="QUERI Compliance Report - print"
|
||||
S ZTRTN="REPORT^PXRMETCO"
|
||||
S ZTSK=1
|
||||
S PXRMQUE=0
|
||||
S PXRMQUE=$$DEVICE^PXRMXQUE(ZTRTN,ZTDESC,.ZTSAVE,.%ZIS,.ZTSK)
|
||||
I PXRMQUE=1 G EXIT
|
||||
I PXRMQUE>0 S ^XTMP(PXRMXTMP,"PRZTSK")=PXRMQUE
|
||||
Q
|
||||
;
|
||||
EXIT ;Clean things up.
|
||||
D ^%ZISC
|
||||
D HOME^%ZIS
|
||||
K IO("Q")
|
||||
K DIRUT,DTOUT,DUOUT,POP,ZTREQ
|
||||
I $D(ZTSK) D KILL^%ZTLOAD
|
||||
K ZTSK,ZTQUEUED
|
||||
K ^TMP("PXRMXTR",$J)
|
||||
Q
|
||||
;
|
||||
SAVE ;Save the variables for queing.
|
||||
S ZTSAVE("IEN")=""
|
||||
S ZTSAVE("PXRMSTRT")=""
|
||||
S ZTSAVE("PXRMSTOP")=""
|
||||
Q
|
||||
;
|
||||
;
|
||||
QUE ;BOOKMARK - NOT USED
|
||||
;Queue the MST synchronization job.
|
||||
N DIR,DTOUT,DUOUT,MINDT,SDTIME,STIME,X,Y
|
||||
S MINDT=$$NOW^XLFDT
|
||||
W !,"Queue the Clinical Reminders MST synchronization."
|
||||
S DIR("A",1)="Enter the date and time you want the job to start."
|
||||
S DIR("A")="It must be after "_$$FMTE^XLFDT(MINDT,"5Z")_" "
|
||||
S DIR(0)="DAU"_U_MINDT_"::RSX"
|
||||
D ^DIR
|
||||
I $D(DTOUT)!$D(DUOUT) Q
|
||||
S SDTIME=Y
|
||||
K DIR
|
||||
S DIR(0)="YA"
|
||||
S DIR("A")="Do you want to run the MST synchronization at the same time every day? "
|
||||
S DIR("B")="Y"
|
||||
D ^DIR
|
||||
I $D(DTOUT)!$D(DUOUT) Q
|
||||
I Y S STIME="1."_$P(SDTIME,".",2)
|
||||
E S STIME=-1
|
||||
;
|
||||
;Put the task into the queue.
|
||||
K ZTSAVE
|
||||
;S ZTSAVE("START")=SDTIME
|
||||
S ZTSAVE("STIME")=STIME
|
||||
S ZTRTN="SYNCH^PXRMMST"
|
||||
S ZTDESC="Clinical Reminders MST synchronization job"
|
||||
S ZTDTH=SDTIME
|
||||
S ZTIO=""
|
||||
D ^%ZTLOAD
|
||||
W !,"Task number ",ZTSK," queued."
|
||||
Q
|
||||
|
|
|
|||
|
|
@ -1,339 +1,329 @@
|
|||
PXRMETH ; SLC/PJH - Reminder Extract History ;10/11/2007
|
||||
;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
|
||||
;
|
||||
;Main entry point for PXRM EXTRACT HISTORY
|
||||
START(EDIEN) ;
|
||||
;EDIEN is the extract definition IEN.
|
||||
N VALMBCK,VALMCNT,VALMSG,X,XMZ,XQORM,XQORNOD
|
||||
;Details of last run
|
||||
N DATA,NPERIOD,NSDATE,NTAS,PXRMVIEW
|
||||
S DATA=$G(^PXRM(810.2,EDIEN,0))
|
||||
S NPERIOD=$P(DATA,U,6),NSDATE=$P(DATA,U,7)
|
||||
;Default view is in date created order
|
||||
S PXRMVIEW="D"
|
||||
S X="IORESET"
|
||||
D ENDR^%ZISS
|
||||
S VALMCNT=0
|
||||
D EN^VALM("PXRM EXTRACT HISTORY")
|
||||
Q
|
||||
;
|
||||
DELETE ;Delete an extract, called by protocol PXRM EXTRACT SUMMARY DELETE.
|
||||
N CLASS,IEN,IENLIST,IND
|
||||
S IENLIST=$$LMSEL
|
||||
F IND=1:1:$L(IENLIST,U) D
|
||||
.S IEN=$P(IENLIST,U,IND)
|
||||
.D DELETE^PXRMETXU(IEN)
|
||||
;Rebuild workfile
|
||||
D BLDLIST^PXRMETH1(EDIEN)
|
||||
;Refresh
|
||||
S VALMBCK="R"
|
||||
Q
|
||||
;
|
||||
ENTRY ;Entry code
|
||||
D BLDLIST^PXRMETH1(EDIEN),XQORM
|
||||
Q
|
||||
;
|
||||
EXIT ;Exit code
|
||||
K ^TMP("PXRMETH",$J)
|
||||
K ^TMP("PXRMETHH",$J)
|
||||
D CLEAN^VALM10
|
||||
D FULL^VALM1
|
||||
S VALMBCK="Q"
|
||||
Q
|
||||
;
|
||||
EXTRACT(EDIEN) ;Run Extract/Transmission
|
||||
;Reset screen mode
|
||||
W IORESET
|
||||
;Refresh on exit
|
||||
S VALMBCK="R"
|
||||
;
|
||||
;Get details from parameter file
|
||||
N ANS,DATA,DUOUT,DTOUT,EDATE,EXSUMPUG,FREQ,MODE
|
||||
N NAME,NAT,NEXT,PLISTPUG,RTN,REPL,STATUS,SNEXT,TEXT,XMIT
|
||||
S DATA=$G(^PXRM(810.2,EDIEN,0))
|
||||
S NAT=$P($G(^PXRM(810.2,EDIEN,100)),U)
|
||||
;Determine Extract Name and Frequency
|
||||
S NAME=$P(DATA,U),FREQ=$P(DATA,U,3),NEXT=$P(DATA,U,6),RTN="PXRMETX"
|
||||
;Save next scheduled extract
|
||||
S SNEXT=NEXT
|
||||
;Select extract period
|
||||
EXSEL D SELECT(FREQ,.NEXT) Q:$D(DUOUT)!$D(DTOUT)
|
||||
;Warn if period is still open
|
||||
D WARN(NEXT,.STATUS)
|
||||
;Option to continue
|
||||
S TEXT="Are you sure you want to run a "_NAME_" extract for "_$TR(NEXT,"/"," ")
|
||||
SURE ;
|
||||
S ANS=$$ASKYN^PXRMEUT("N",TEXT,RTN,1) Q:$D(DUOUT)!$D(DTOUT) Q:'ANS
|
||||
;Purge options
|
||||
PLIST ;
|
||||
S PLISTPUG="N" D ASK^PXRMXD(.PLISTPUG,"Purge Patient List after 5 years?: ",5)
|
||||
G:$D(DUOUT) SURE Q:$D(DTOUT)
|
||||
S EXSUMPUG="N" D ASK^PXRMXD(.EXSUMPUG,"Purge Extract Summary after 5 years?: ",5)
|
||||
G:$D(DUOUT) PLIST Q:$D(DTOUT)
|
||||
;Option to transmit
|
||||
S TEXT="Transmit extract results to AAC"
|
||||
I NAT="N" S XMIT=$$ASKYN^PXRMEUT("N",TEXT,RTN,3) Q:$D(DUOUT)!$D(DTOUT)
|
||||
E S XMIT=0
|
||||
;Option to replace scheduled run
|
||||
S REPL=0
|
||||
I XMIT,SNEXT=NEXT,STATUS="COMPLETE" D Q:$D(DUOUT)!$D(DTOUT)
|
||||
.S TEXT="Does this extract replace the scheduled extract"
|
||||
.S REPL=$$ASKYN^PXRMEUT("N",TEXT,RTN,4) Q:$D(DUOUT)!$D(DTOUT)
|
||||
;
|
||||
;Note that the manual extract does not update 810.2
|
||||
;exept if the selected period is the same as the scheduled
|
||||
;period AND this period is complete
|
||||
;
|
||||
;Default is to extract and transmit and not update 810.2
|
||||
S MODE=2 I 'XMIT S MODE=3
|
||||
;Update 810.2 if this extract is for current completed period
|
||||
I REPL S MODE=0 I 'XMIT S MODE=1
|
||||
;
|
||||
;Extract/transmission run
|
||||
N ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE
|
||||
S ZTDESC="Reminder Extract "_NAME
|
||||
S ZTRTN="RUN^PXRMETX(EDIEN,NEXT,MODE,EXSUMPUG)"
|
||||
S ZTSAVE("EDIEN")=""
|
||||
S ZTSAVE("MODE")=""
|
||||
S ZTSAVE("NEXT")=""
|
||||
S ZTSAVE("PLISTPUG")=""
|
||||
S ZTSAVE("EXSUMPUG")=""
|
||||
S ZTIO=""
|
||||
;
|
||||
;Select and verify start date/time for task
|
||||
N DIR,DTOUT,DUOUT,MINDT,SDTIME,STIME,X,Y
|
||||
S MINDT=$$NOW^XLFDT
|
||||
W !,"Queue a "_ZTDESC_" for "_NEXT
|
||||
S DIR("A",1)="Enter the date and time you want the job to start."
|
||||
S DIR("A",2)="It must be after "_$$FMTE^XLFDT(MINDT,"5Z")
|
||||
S DIR("A")="Start the task at: "
|
||||
S DIR(0)="DAU"_U_MINDT_"::RSX"
|
||||
D ^DIR
|
||||
I $D(DTOUT)!$D(DUOUT) Q
|
||||
S SDTIME=Y
|
||||
;
|
||||
;Put the task into the queue.
|
||||
S ZTDTH=SDTIME
|
||||
D ^%ZTLOAD
|
||||
W !,"Task number ",ZTSK," queued." H 2
|
||||
S VALMBCK="Q"
|
||||
Q
|
||||
;
|
||||
HDR ; Header code
|
||||
N VIEW
|
||||
S VIEW=$S(PXRMVIEW="D":"Creation Date Order",1:"Extract Period Order")
|
||||
S VALMHDR(2)=" Extract Name: "_$P($G(^PXRM(810.2,EDIEN,0)),U)
|
||||
S VALMHDR(3)=" Next Extract Period: "_NPERIOD
|
||||
S VALMHDR(4)=" Scheduled to Run: "_$$FMTE^XLFDT(NSDATE,"5Z")
|
||||
S VALMHDR(4)=$$LJ^XLFSTR(VALMHDR(4),45)_" View: "_VIEW
|
||||
S VALMSG="+ Next Screen - Prev Screen ?? More Actions"
|
||||
Q
|
||||
;
|
||||
HLP ;Help code
|
||||
N ORU,ORUPRMT,SUB,XQORM
|
||||
S SUB="PXRMETHH"
|
||||
D EN^VALM("PXRM EXTRACT HELP")
|
||||
Q
|
||||
;
|
||||
INIT ;Init
|
||||
S VALMCNT=0
|
||||
Q
|
||||
;
|
||||
LMSEL() ;Return selection list
|
||||
N IENLIST,IND,VALMY,XIEN
|
||||
D EN^VALM2(XQORNOD(0))
|
||||
;If there is no list quit.
|
||||
I '$D(VALMY) Q ""
|
||||
S PXRMDONE=0,IENLIST=""
|
||||
S IND=""
|
||||
F S IND=$O(VALMY(IND)) Q:(+IND=0)!(PXRMDONE) D
|
||||
.;Get the ien.
|
||||
.S XIEN=^TMP("PXRMETH",$J,"SEL",IND)
|
||||
.S IENLIST=$S(IENLIST'="":IENLIST_U_XIEN,1:XIEN)
|
||||
Q IENLIST
|
||||
;
|
||||
PEXIT ;PXRM EXCH MENU protocol exit code
|
||||
S VALMSG="+ Next Screen - Prev Screen ?? More Actions"
|
||||
D XQORM
|
||||
Q
|
||||
;
|
||||
SELECT(FREQ,SEL) ;Select extract period
|
||||
N BDATE,EDATE,DA,DIE,DIK,DIR,DR,FDATE,VALID,X
|
||||
;Get the new name.
|
||||
F D Q:$D(DTOUT)!$D(DUOUT) Q:SEL]""
|
||||
.S DIR("A")="Select EXTRACT PERIOD "
|
||||
.I FREQ="M" D
|
||||
..S DIR("A")=DIR("A")_"(Mnn/yyyy)"
|
||||
..S DIR(0)="F"_U_"7:8"_U_"K:'$$VALID^PXRMETH(FREQ,X) X"
|
||||
.I FREQ="Q" D
|
||||
..S DIR("A")=DIR("A")_"(Qnn/yyyy)"
|
||||
..S DIR(0)="F"_U_"7:7"_U_"K:'$$VALID^PXRMETH(FREQ,X) X"
|
||||
.I FREQ="Y" D
|
||||
..S DIR("A")=DIR("A")_"(yyyy)"
|
||||
..S DIR(0)="N"_U_"2000:2050"_U_"K:(X'?4N) X"
|
||||
.;Default is next period
|
||||
.S DIR("B")=NEXT
|
||||
.W ! D ^DIR Q:$D(DTOUT)!$D(DUOUT)
|
||||
.;Calculate beginning and end dates for period
|
||||
.S Y=$$UP^XLFSTR(Y) D CALC^PXRMEUT(Y,.BDATE,.EDATE)
|
||||
.;Abort if period has not started
|
||||
.I $$FMDIFF^XLFDT(BDATE,$$NOW^XLFDT)>0 D Q
|
||||
..S FDATE=$$FMTE^XLFDT(BDATE,5)
|
||||
..W !,"ERROR -This period does not start until "_FDATE,*7
|
||||
.S SEL=Y
|
||||
Q
|
||||
;
|
||||
TLIST ;Extract summary display
|
||||
N IEN,IENLIST,IND
|
||||
S IENLIST=$$LMSEL
|
||||
F IND=1:1:$L(IENLIST,U) D
|
||||
.S IEN=$P(IENLIST,U,IND)
|
||||
.D START^PXRMETT(IEN)
|
||||
.S VALMBCK="R"
|
||||
S VALMBCK="R"
|
||||
Q
|
||||
;
|
||||
TRANS ;Run Transmission
|
||||
N IEN,IENLIST,IND
|
||||
S IENLIST=$$LMSEL
|
||||
F IND=1:1:$L(IENLIST,U) D
|
||||
.S IEN=$P(IENLIST,U,IND)
|
||||
.I $P($G(^PXRMXT(810.3,IEN,100)),U)'="N" D Q
|
||||
..W !,"Local extracts cannot be transmitted to AAC." H 2
|
||||
.;Transmit extract summary
|
||||
.N ANS,DUOUT,DTOUT,RTN,TEXT
|
||||
.S TEXT="Transmit this extract to AAC",ANS="",RTN="PXRMETH"
|
||||
.S ANS=$$ASKYN^PXRMEUT("N",TEXT,RTN,3) Q:$D(DUOUT)!$D(DTOUT)
|
||||
.I ANS D TRANS^PXRMETX(IEN)
|
||||
;
|
||||
;Rebuild workfile
|
||||
D BLDLIST^PXRMETH1(EDIEN)
|
||||
;Refresh
|
||||
S VALMBCK="R"
|
||||
Q
|
||||
;
|
||||
TRHIST ;Transmission History
|
||||
N IEN,IENLIST,IND
|
||||
S IENLIST=$$LMSEL
|
||||
F IND=1:1:$L(IENLIST,U) D
|
||||
.S IEN=$P(IENLIST,U,IND)
|
||||
.D START^PXRMETHL(IEN)
|
||||
S VALMBCK="R"
|
||||
Q
|
||||
;
|
||||
VALID(FREQ,INP) ;Validate Period input
|
||||
W !
|
||||
N PERIOD,YEAR
|
||||
;Convert to upper case
|
||||
S INP=$$UP^XLFSTR(INP)
|
||||
;General format
|
||||
I $E(INP)'=FREQ D EN^DDIOL("Format should be "_FREQ_"nn/yyyy") Q 0
|
||||
S PERIOD=$P(INP,"/"),YEAR=$P(INP,"/",2)
|
||||
S PERIOD=$P(PERIOD,FREQ,2)
|
||||
;All runs
|
||||
I (YEAR<2000)!(YEAR>2050) D EN^DDIOL("Year should be in range 2000-2050") Q 0
|
||||
;Quarterly run
|
||||
I FREQ="Q",(PERIOD>4)!(PERIOD<1) D EN^DDIOL("Quarter should be in range 1-4") Q 0
|
||||
;Monthly run
|
||||
I FREQ="M",(PERIOD>12)!(PERIOD<1) D EN^DDIOL("Month should be in range 1-12") Q 0
|
||||
;Otherwise
|
||||
Q 1
|
||||
;
|
||||
VIEW ;Select view
|
||||
W IORESET
|
||||
S VALMBCK="R"
|
||||
N X,Y,CODE,DIR
|
||||
K DIROUT,DIRUT,DTOUT,DUOUT
|
||||
S DIR(0)="S"_U_"D:Sort by Creation Date;"
|
||||
S DIR(0)=DIR(0)_"P:Sort by Extract Period;"
|
||||
S DIR("A")="TYPE OF VIEW"
|
||||
S DIR("B")=$S(PXRMVIEW="P":"D",1:"P")
|
||||
S DIR("?")="Select from the codes displayed. For detailed help type ??"
|
||||
;BOOKMARK - HELP NEEDS MOVING
|
||||
S DIR("??")=U_"D HELP^PXRMSEL2(3)"
|
||||
D ^DIR K DIR
|
||||
I $D(DIROUT) S DTOUT=1
|
||||
I $D(DTOUT)!($D(DUOUT)) Q
|
||||
;Change display type
|
||||
S PXRMVIEW=Y
|
||||
;
|
||||
;Rebuild Workfile
|
||||
D BLDLIST^PXRMETH1(EDIEN),HDR
|
||||
Q
|
||||
;
|
||||
WARN(NEXT,STATUS) ;Warn if period is not completed
|
||||
N BDATE,EDATE,FDATE
|
||||
;Calculate beginning and end dates for period
|
||||
D CALC^PXRMEUT(NEXT,.BDATE,.EDATE)
|
||||
;No warning if period end date is a prior date
|
||||
I $$FMDIFF^XLFDT($$NOW^XLFDT,EDATE)>0 S STATUS="COMPLETE" Q
|
||||
;Else Format date
|
||||
S FDATE=$$FMTE^XLFDT(EDATE,5),STATUS="INCOMPLETE"
|
||||
;And Warn that period end date is a future date
|
||||
W !!,"WARNING -This period is not complete until "_FDATE
|
||||
Q
|
||||
XQORM S XQORM("#")=$O(^ORD(101,"B","PXRM EXTRACT HISTORY SELECT ENTRY",0))_U_"1:"_VALMCNT
|
||||
S XQORM("A")="Select Item: "
|
||||
Q
|
||||
;
|
||||
XSEL ;PXRM EXTRACT HISTORY SELECT ENTRY validation
|
||||
N SEL,PXRMSIEN
|
||||
S SEL=$P(XQORNOD(0),"=",2)
|
||||
;Remove trailing ,
|
||||
I $E(SEL,$L(SEL))="," S SEL=$E(SEL,1,$L(SEL)-1)
|
||||
;Invalid selection
|
||||
I SEL["," D Q
|
||||
.W $C(7),!,"Only one item number allowed." H 2
|
||||
.S VALMBCK="R"
|
||||
I ('SEL)!(SEL>VALMCNT)!('$D(@VALMAR@("SEL",SEL))) D Q
|
||||
.W $C(7),!,SEL_" is not a valid item number." H 2
|
||||
.S VALMBCK="R"
|
||||
;
|
||||
;Get the list ien.
|
||||
;S PXRMSIEN=^TMP("PXRMETH",$J,"IDX",SEL,SEL)
|
||||
S PXRMSIEN=^TMP("PXRMETH",$J,"SEL",SEL)
|
||||
;
|
||||
;Full screen mode
|
||||
D FULL^VALM1
|
||||
;
|
||||
;Options
|
||||
N X,Y,DIR,OPTION K DIROUT,DIRUT,DTOUT,DUOUT
|
||||
S DIR(0)="SBM"_U_"DE:Delete Extract;"
|
||||
S DIR(0)=DIR(0)_"ES:Extract Summary;"
|
||||
S DIR(0)=DIR(0)_"MT:Manual Transmission;"
|
||||
S DIR(0)=DIR(0)_"TH:Transmission History;"
|
||||
S DIR("A")="Select Action"
|
||||
S DIR("B")="ES"
|
||||
S DIR("?")="Select from the codes displayed. For detailed help type ??"
|
||||
S DIR("??")=U_"D HELP^PXRMETH1(1)"
|
||||
D ^DIR K DIR
|
||||
I $D(DIROUT) S DTOUT=1
|
||||
I $D(DTOUT)!($D(DUOUT)) S VALMBCK="R" Q
|
||||
S OPTION=Y
|
||||
;
|
||||
;Delete an extract
|
||||
I OPTION="DE" D
|
||||
.D DELETE^PXRMETXU(PXRMSIEN)
|
||||
.;Rebuild workfile
|
||||
.D BLDLIST^PXRMETH1(PXRMSIEN)
|
||||
.;Refresh
|
||||
.S VALMBCK="R"
|
||||
;
|
||||
;Display Extract Summary
|
||||
I OPTION="ES" D START^PXRMETT(PXRMSIEN)
|
||||
;
|
||||
;Transmission option
|
||||
I OPTION="MT" D
|
||||
.N ANS,DUOUT,DTOUT,RTN,TEXT
|
||||
.I $P($G(^PXRMXT(810.3,PXRMSIEN,100)),U)'="N" D Q
|
||||
..W !,"Local extracts cannot be transmitted to AAC" H 2 Q
|
||||
.S TEXT="Transmit this extract to AAC",ANS="",RTN="PXRMETH"
|
||||
.S ANS=$$ASKYN^PXRMEUT("N",TEXT,RTN,3) Q:$D(DUOUT)!$D(DTOUT)
|
||||
.I ANS D TRANS^PXRMETX(PXRMSIEN)
|
||||
;
|
||||
;Transmission History
|
||||
I OPTION="TH" D START^PXRMETHL(PXRMSIEN)
|
||||
;
|
||||
S VALMBCK="R"
|
||||
Q
|
||||
;
|
||||
PXRMETH ; SLC/PJH - Reminder Extract History ;08/15/2006
|
||||
;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
|
||||
;
|
||||
;Main entry point for PXRM EXTRACT HISTORY
|
||||
START(IEN) ;
|
||||
N VALMBCK,VALMCNT,VALMSG,X,XMZ,XQORM,XQORNOD
|
||||
;Details of last run
|
||||
N DATA,NPERIOD,NSDATE,NTAS,PXRMVIEW
|
||||
S DATA=$G(^PXRM(810.2,IEN,0))
|
||||
S NPERIOD=$P(DATA,U,6),NSDATE=$P(DATA,U,7)
|
||||
;Default view is in date created order
|
||||
S PXRMVIEW="D"
|
||||
S X="IORESET"
|
||||
D ENDR^%ZISS
|
||||
S VALMCNT=0
|
||||
D EN^VALM("PXRM EXTRACT HISTORY")
|
||||
Q
|
||||
;
|
||||
ENTRY ;Entry code
|
||||
D BLDLIST^PXRMETH1(IEN),XQORM
|
||||
Q
|
||||
;
|
||||
EXIT ;Exit code
|
||||
K ^TMP("PXRMETH",$J)
|
||||
K ^TMP("PXRMETHH",$J)
|
||||
D CLEAN^VALM10
|
||||
D FULL^VALM1
|
||||
S VALMBCK="Q"
|
||||
Q
|
||||
;
|
||||
HDR ; Header code
|
||||
N VIEW
|
||||
S VIEW=$S(PXRMVIEW="D":"Creation Date Order",1:"Extract Period Order")
|
||||
S VALMHDR(2)=" Extract Name: "_$P($G(^PXRM(810.2,IEN,0)),U)
|
||||
S VALMHDR(3)=" Next Extract Period: "_NPERIOD
|
||||
S VALMHDR(4)=" Scheduled to Run: "_NSDATE
|
||||
S VALMHDR(4)=$$LJ^XLFSTR(VALMHDR(4),45)_" View: "_VIEW
|
||||
S VALMSG="+ Next Screen - Prev Screen ?? More Actions"
|
||||
Q
|
||||
;
|
||||
HLP ;Help code
|
||||
N ORU,ORUPRMT,SUB,XQORM
|
||||
S SUB="PXRMETHH"
|
||||
D EN^VALM("PXRM EXTRACT HELP")
|
||||
Q
|
||||
;
|
||||
INIT ;Init
|
||||
S VALMCNT=0
|
||||
Q
|
||||
;
|
||||
PEXIT ;PXRM EXCH MENU protocol exit code
|
||||
S VALMSG="+ Next Screen - Prev Screen ?? More Actions"
|
||||
D XQORM
|
||||
Q
|
||||
;
|
||||
XQORM S XQORM("#")=$O(^ORD(101,"B","PXRM EXTRACT HISTORY SELECT ENTRY",0))_U_"1:"_VALMCNT
|
||||
S XQORM("A")="Select Item: "
|
||||
Q
|
||||
;
|
||||
XSEL ;PXRM EXTRACT HISTORY SELECT ENTRY validation
|
||||
N SEL,PXRMSIEN
|
||||
S SEL=$P(XQORNOD(0),"=",2)
|
||||
;Remove trailing ,
|
||||
I $E(SEL,$L(SEL))="," S SEL=$E(SEL,1,$L(SEL)-1)
|
||||
;Invalid selection
|
||||
I SEL["," D Q
|
||||
.W $C(7),!,"Only one item number allowed." H 2
|
||||
.S VALMBCK="R"
|
||||
I ('SEL)!(SEL>VALMCNT)!('$D(@VALMAR@("IDX",SEL))) D Q
|
||||
.W $C(7),!,SEL_" is not a valid item number." H 2
|
||||
.S VALMBCK="R"
|
||||
;
|
||||
;Get the list ien.
|
||||
S PXRMSIEN=^TMP("PXRMETH",$J,"IDX",SEL,SEL)
|
||||
;
|
||||
;Full screen mode
|
||||
D FULL^VALM1
|
||||
;
|
||||
;Options
|
||||
N X,Y,DIR,OPTION K DIROUT,DIRUT,DTOUT,DUOUT
|
||||
S DIR(0)="SBM"_U_"ES:Extract Summary;"
|
||||
S DIR(0)=DIR(0)_"MT:Manual Transmission;"
|
||||
S DIR(0)=DIR(0)_"TH:Transmission History;"
|
||||
S DIR("A")="Select Action"
|
||||
S DIR("B")="ES"
|
||||
S DIR("?")="Select from the codes displayed. For detailed help type ??"
|
||||
S DIR("??")=U_"D HELP^PXRMETH1(1)"
|
||||
D ^DIR K DIR
|
||||
I $D(DIROUT) S DTOUT=1
|
||||
I $D(DTOUT)!($D(DUOUT)) S VALMBCK="R" Q
|
||||
S OPTION=Y
|
||||
;
|
||||
;Display Extract Summary
|
||||
I OPTION="ES" D
|
||||
.D START^PXRMETT(PXRMSIEN)
|
||||
;
|
||||
;Transmission option
|
||||
I OPTION="MT" D
|
||||
.N ANS,DUOUT,DTOUT,RTN,TEXT
|
||||
.I $P($G(^PXRMXT(810.3,PXRMSIEN,100)),U)'="N" D Q
|
||||
..W !,"Local extracts cannot be transmitted to AAC" H 2 Q
|
||||
.S TEXT="Transmit this extract to AAC",ANS="",RTN="PXRMETH"
|
||||
.S ANS=$$ASKYN^PXRMEUT("N",TEXT,RTN,3) Q:$D(DUOUT)!$D(DTOUT)
|
||||
.I ANS D TRANS^PXRMETX(PXRMSIEN)
|
||||
;
|
||||
;Transmission History
|
||||
I OPTION="TH" D
|
||||
.D START^PXRMETHL(PXRMSIEN)
|
||||
;
|
||||
S VALMBCK="R"
|
||||
Q
|
||||
;
|
||||
EXTRACT(IEN) ;Run Extract/Transmission
|
||||
;
|
||||
;Reset screen mode
|
||||
W IORESET
|
||||
;Refresh on exit
|
||||
S VALMBCK="R"
|
||||
;
|
||||
;Get details from parameter file
|
||||
N ANS,DATA,DUOUT,DTOUT,EDATE,EXSUMPUG,FREQ,MODE
|
||||
N NAME,NAT,NEXT,PLISTPUG,RTN,REPL,STATUS,SNEXT,TEXT,XMIT
|
||||
S DATA=$G(^PXRM(810.2,IEN,0))
|
||||
S NAT=$P($G(^PXRM(810.2,IEN,100)),U)
|
||||
;Determine Extract Name and Frequency
|
||||
S NAME=$P(DATA,U),FREQ=$P(DATA,U,3),NEXT=$P(DATA,U,6),RTN="PXRMETX"
|
||||
;Save next scheduled extract
|
||||
S SNEXT=NEXT
|
||||
;Select extract period
|
||||
EXSEL D SELECT(FREQ,.NEXT) Q:$D(DUOUT)!$D(DTOUT)
|
||||
;Warn if period is still open
|
||||
D WARN(NEXT,.STATUS)
|
||||
;Option to continue
|
||||
S TEXT="Are you sure you want to run a "_NAME_" extract for "_$TR(NEXT,"/"," ")
|
||||
SURE ;
|
||||
S ANS=$$ASKYN^PXRMEUT("N",TEXT,RTN,1) Q:$D(DUOUT)!$D(DTOUT) Q:'ANS
|
||||
;Purge options
|
||||
PLIST ;
|
||||
S PLISTPUG="N" D ASK^PXRMXD(.PLISTPUG,"Purge Patient List after 5 years?: ",5)
|
||||
G:$D(DUOUT) SURE Q:$D(DTOUT)
|
||||
S EXSUMPUG="N" D ASK^PXRMXD(.EXSUMPUG,"Purge Extract Summary after 5 years?: ",5)
|
||||
G:$D(DUOUT) PLIST Q:$D(DTOUT)
|
||||
;Option to transmit
|
||||
S TEXT="Transmit extract results to AAC"
|
||||
I NAT="N" S XMIT=$$ASKYN^PXRMEUT("N",TEXT,RTN,3) Q:$D(DUOUT)!$D(DTOUT)
|
||||
E S XMIT=0
|
||||
;Option to replace scheduled run
|
||||
S REPL=0
|
||||
I XMIT,SNEXT=NEXT,STATUS="COMPLETE" D Q:$D(DUOUT)!$D(DTOUT)
|
||||
.S TEXT="Does this extract replace the scheduled extract"
|
||||
.S REPL=$$ASKYN^PXRMEUT("N",TEXT,RTN,4) Q:$D(DUOUT)!$D(DTOUT)
|
||||
;
|
||||
;Note that the manual extract does not update 810.2
|
||||
;exept if the selected period is the same as the scheduled
|
||||
;period AND this period is complete
|
||||
;
|
||||
;Default is to extract and transmit and not update 810.2
|
||||
S MODE=2 I 'XMIT S MODE=3
|
||||
;Update 810.2 if this extract is for current completed period
|
||||
I REPL S MODE=0 I 'XMIT S MODE=1
|
||||
;
|
||||
;Extract/transmission run
|
||||
N ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE
|
||||
S ZTDESC="Reminder Extract "_NAME
|
||||
S ZTRTN="RUN^PXRMETX(IEN,NEXT,MODE,EXSUMPUG)"
|
||||
S ZTSAVE("IEN")=""
|
||||
S ZTSAVE("MODE")=""
|
||||
S ZTSAVE("NEXT")=""
|
||||
S ZTSAVE("PLISTPUG")=""
|
||||
S ZTSAVE("EXSUMPUG")=""
|
||||
S ZTIO=""
|
||||
;
|
||||
;Select and verify start date/time for task
|
||||
N DIR,DTOUT,DUOUT,MINDT,SDTIME,STIME,X,Y
|
||||
S MINDT=$$NOW^XLFDT
|
||||
W !,"Queue a "_ZTDESC_" for "_NEXT
|
||||
S DIR("A",1)="Enter the date and time you want the job to start."
|
||||
S DIR("A",2)="It must be after "_$$FMTE^XLFDT(MINDT,"5Z")
|
||||
S DIR("A")="Start the task at: "
|
||||
S DIR(0)="DAU"_U_MINDT_"::RSX"
|
||||
D ^DIR
|
||||
I $D(DTOUT)!$D(DUOUT) Q
|
||||
S SDTIME=Y
|
||||
;
|
||||
;Put the task into the queue.
|
||||
S ZTDTH=SDTIME
|
||||
D ^%ZTLOAD
|
||||
W !,"Task number ",ZTSK," queued." H 2
|
||||
;
|
||||
S VALMBCK="Q"
|
||||
Q
|
||||
;
|
||||
SELECT(FREQ,SEL) ;Select extract period
|
||||
;
|
||||
N BDATE,EDATE,DA,DIE,DIK,DIR,DR,FDATE,VALID,X
|
||||
;Get the new name.
|
||||
F D Q:$D(DTOUT)!$D(DUOUT) Q:SEL]""
|
||||
.S DIR("A")="Select EXTRACT PERIOD "
|
||||
.I FREQ="M" D
|
||||
..S DIR("A")=DIR("A")_"(Mnn/yyyy)"
|
||||
..S DIR(0)="F"_U_"7:8"_U_"K:'$$VALID^PXRMETH(FREQ,X) X"
|
||||
.I FREQ="Q" D
|
||||
..S DIR("A")=DIR("A")_"(Qnn/yyyy)"
|
||||
..S DIR(0)="F"_U_"7:7"_U_"K:'$$VALID^PXRMETH(FREQ,X) X"
|
||||
.I FREQ="Y" D
|
||||
..S DIR("A")=DIR("A")_"(yyyy)"
|
||||
..S DIR(0)="N"_U_"2000:2050"_U_"K:(X'?4N) X"
|
||||
.;Default is next period
|
||||
.S DIR("B")=NEXT
|
||||
.W ! D ^DIR Q:$D(DTOUT)!$D(DUOUT)
|
||||
.;Calculate beginning and end dates for period
|
||||
.S Y=$$UP^XLFSTR(Y) D CALC^PXRMEUT(Y,.BDATE,.EDATE)
|
||||
.;Abort if period has not started
|
||||
.I $$FMDIFF^XLFDT(BDATE,$$NOW^XLFDT)>0 D Q
|
||||
..S FDATE=$$FMTE^XLFDT(BDATE,5)
|
||||
..W !,"ERROR -This period does not start until "_FDATE,*7
|
||||
.S SEL=Y
|
||||
Q
|
||||
;
|
||||
TLIST ;Extract Totals
|
||||
N IND,PXRMSIEN,VALMY
|
||||
D EN^VALM2(XQORNOD(0))
|
||||
;If there is no list quit.
|
||||
I '$D(VALMY) Q
|
||||
;PXRMDONE is newed in PXRMLPM
|
||||
S PXRMDONE=0
|
||||
S IND=""
|
||||
F S IND=$O(VALMY(IND)) Q:(+IND=0)!(PXRMDONE) D
|
||||
.;Get the ien.
|
||||
.S PXRMSIEN=^TMP("PXRMETH",$J,"IDX",IND,IND)
|
||||
.D START^PXRMETT(PXRMSIEN)
|
||||
;
|
||||
S VALMBCK="R"
|
||||
Q
|
||||
;
|
||||
TRANS ;Run Transmission
|
||||
N IND,PXRMXIEN,VALMY
|
||||
D EN^VALM2(XQORNOD(0))
|
||||
;If there is no list quit.
|
||||
I '$D(VALMY) Q
|
||||
S PXRMDONE=0
|
||||
S IND=""
|
||||
F S IND=$O(VALMY(IND)) Q:(+IND=0)!(PXRMDONE) D
|
||||
.;Get the ien.
|
||||
.S PXRMXIEN=^TMP("PXRMETH",$J,"IDX",IND,IND)
|
||||
.I $P($G(^PXRMXT(810.3,PXRMXIEN,100)),U)'="N" D Q
|
||||
..W !,"Local extracts cannot be transmitted to AAC." H 1
|
||||
.;Transmit extract summary
|
||||
.N ANS,DUOUT,DTOUT,RTN,TEXT
|
||||
.S TEXT="Transmit this extract to AAC",ANS="",RTN="PXRMETH"
|
||||
.S ANS=$$ASKYN^PXRMEUT("N",TEXT,RTN,3) Q:$D(DUOUT)!$D(DTOUT)
|
||||
.I ANS D TRANS^PXRMETX(PXRMXIEN)
|
||||
;
|
||||
;Rebuild workfile
|
||||
D BLDLIST^PXRMETH1(IEN)
|
||||
;Refresh
|
||||
S VALMBCK="R"
|
||||
Q
|
||||
;
|
||||
TRHIST ;Transmission History
|
||||
N IND,PXRMSIEN,VALMY
|
||||
D EN^VALM2(XQORNOD(0))
|
||||
;If there is no list quit.
|
||||
I '$D(VALMY) Q
|
||||
;PXRMDONE is newed in PXRMLPM
|
||||
S PXRMDONE=0
|
||||
S IND=""
|
||||
F S IND=$O(VALMY(IND)) Q:(+IND=0)!(PXRMDONE) D
|
||||
.;Get the ien.
|
||||
.S PXRMSIEN=^TMP("PXRMETH",$J,"IDX",IND,IND)
|
||||
.D START^PXRMETHL(PXRMSIEN)
|
||||
;
|
||||
S VALMBCK="R"
|
||||
Q
|
||||
;
|
||||
VALID(FREQ,INP) ;Validate Period input
|
||||
W !
|
||||
N PERIOD,YEAR
|
||||
;Convert to upper case
|
||||
S INP=$$UP^XLFSTR(INP)
|
||||
;General format
|
||||
I $E(INP)'=FREQ D EN^DDIOL("Format should be "_FREQ_"nn/yyyy") Q 0
|
||||
S PERIOD=$P(INP,"/"),YEAR=$P(INP,"/",2)
|
||||
S PERIOD=$P(PERIOD,FREQ,2)
|
||||
;All runs
|
||||
I (YEAR<2000)!(YEAR>2050) D EN^DDIOL("Year should be in range 2000-2050") Q 0
|
||||
;Quarterly run
|
||||
I FREQ="Q",(PERIOD>4)!(PERIOD<1) D EN^DDIOL("Quarter should be in range 1-4") Q 0
|
||||
;Monthly run
|
||||
I FREQ="M",(PERIOD>12)!(PERIOD<1) D EN^DDIOL("Month should be in range 1-12") Q 0
|
||||
;Otherwise
|
||||
Q 1
|
||||
;
|
||||
VIEW ;Select view
|
||||
;
|
||||
W IORESET
|
||||
;
|
||||
S VALMBCK="R"
|
||||
;
|
||||
N X,Y,CODE,DIR
|
||||
K DIROUT,DIRUT,DTOUT,DUOUT
|
||||
S DIR(0)="S"_U_"D:Sort by Creation Date;"
|
||||
S DIR(0)=DIR(0)_"P:Sort by Extract Period;"
|
||||
S DIR("A")="TYPE OF VIEW"
|
||||
S DIR("B")=$S(PXRMVIEW="P":"D",1:"P")
|
||||
S DIR("?")="Select from the codes displayed. For detailed help type ??"
|
||||
;BOOKMARK - HELP NEEDS MOVING
|
||||
S DIR("??")=U_"D HELP^PXRMSEL2(3)"
|
||||
D ^DIR K DIR
|
||||
I $D(DIROUT) S DTOUT=1
|
||||
I $D(DTOUT)!($D(DUOUT)) Q
|
||||
;Change display type
|
||||
S PXRMVIEW=Y
|
||||
;
|
||||
;Rebuild Workfile
|
||||
D BLDLIST^PXRMETH1(IEN),HDR
|
||||
Q
|
||||
;
|
||||
WARN(NEXT,STATUS) ;Warn if period is not completed
|
||||
N BDATE,EDATE,FDATE
|
||||
;Calculate beginning and end dates for period
|
||||
D CALC^PXRMEUT(NEXT,.BDATE,.EDATE)
|
||||
;No warning if period end date is a prior date
|
||||
I $$FMDIFF^XLFDT($$NOW^XLFDT,EDATE)>0 S STATUS="COMPLETE" Q
|
||||
;Else Format date
|
||||
S FDATE=$$FMTE^XLFDT(EDATE,5),STATUS="INCOMPLETE"
|
||||
;And Warn that period end date is a future date
|
||||
W !!,"WARNING -This period is not complete until "_FDATE
|
||||
Q
|
||||
|
|
|
|||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue