- PSONEWF ;BIR/RTR - Copay finish questions ;07/26/96
- ;;7.0;OUTPATIENT PHARMACY;**71,157,143,219,226,239,225,303**;DEC 1997;Build 19
- ;External reference VADPT supported by DBIA 10061
- START ;
- N PSOPENIB,PSOSCOTH,PSOSCOTX,PSOMESFI
- S PSOPENIB=$S($G(ORD):$G(^PS(52.41,+$G(ORD),"IBQ")),1:"")
- ;set PSOSCOTH for display of Provider Copay intent, used with PSORX(SC)
- S PSOSCOTH=0 I $P(PSOPENIB,"^")=1!($P(PSOPENIB,"^",2)=1)!($P(PSOPENIB,"^",3)=1)!($P(PSOPENIB,"^",4)=1)!($P(PSOPENIB,"^",5)=1)!($P(PSOPENIB,"^",6)=1)!($P(PSOPENIB,"^",7)=1) S PSOSCOTH=1
- S PSOSCOTX=0 I $G(PSOSCOTH)!($G(PSORX("SC"))="SC")!($G(PSORX("SC"))="NSC") S PSOSCOTX=1
- ;Check for Orderable Item change to display message
- S PSOMESFI=0 I $G(OR0),$G(PSODRUG("OI")) D
- .I $G(PSODRUG("OI"))'=$P($G(OR0),"^",8) S PSOMESFI=1
- S PSONEWFF=1,PSOFLAG=1
- ;Copay exemption checks
- D SCP^PSORN52D
- K PSOANSQ D SET S PSOCPZ("DFLG")=0,PSONEW("NEWCOPAY")=0
- I (PSOSCP<50)&($P($G(^PS(53,+$G(PSONEW("PATIENT STATUS")),0)),"^",7)'=1),$G(DUZ("AG"))="V" D COPAY^PSOCPB W !
- I $G(PSOCPZ("DFLG")) K PSONEW("NEWCOPAY"),PSONEWFF,PSOSCOTH,PSOSCOTX,PSOMESFI Q
- I PSOSCA&(PSOSCP>49)!((PSOSCA!(PSOBILL=2))&($P($G(^PS(53,+$G(PSONEW("PATIENT STATUS")),0)),"^",7)=1))!(PSOSCP>49&(PSOBILL=2)) D I $G(PSOCPZ("DFLG")) K PSOANSQ,PSONEW("NEWCOPAY"),PSONEWFF,PSOSCOTH,PSOSCOTX,PSOMESFI Q
- . I PSOSCP<50 D MESS S:PSOSCP<50 PSOANSQD("SC>50")=$G(PSOANSQD("SC"))
- . D SC^PSOMLLD2
- . I PSOSCP<50&($D(PSOANSQD("SC"))) S PSOANSQD("SC")=PSOANSQD("SC>50") K PSOANSQD("SC")
- ;IF MILL BILL, AND COPAY (*******TEST THE COPAY CHECK)
- I $$DT^PSOMLLDT D I $G(PSOCPZ("DFLG")) K PSOANSQ,PSONEW("NEWCOPAY"),PSONEWFF,PSOSCOTH,PSOSCOTX,PSOMESFI Q
- .;New prompts Quit after first '^'
- .I $D(PSOIBQS(PSODFN,"CV")) D D MESSOI,MESS D CV^PSOMLLDT I $G(PSOCPZ("DFLG"))!($G(PSOANSQ("CV"))) K PSONEW("NEWCOPAY")
- ..I '$D(PSOANSQD("CV")),($P(PSOPENIB,"^",6)=0!($P(PSOPENIB,"^",6)=1)) S PSOANSQD("CV")=$P(PSOPENIB,"^",6)
- .I $D(PSOIBQS(PSODFN,"VEH")) D D MESSOI,MESS D VEH^PSOMLLDT I $G(PSOCPZ("DFLG"))!($G(PSOANSQ("VEH"))) K PSONEW("NEWCOPAY")
- ..I '$D(PSOANSQD("VEH")),($P(PSOPENIB,"^",2)=0!($P(PSOPENIB,"^",2)=1)) S PSOANSQD("VEH")=$P(PSOPENIB,"^",2)
- .I $D(PSOIBQS(PSODFN,"RAD")) D D MESSOI,MESS D RAD^PSOMLLDT I $G(PSOCPZ("DFLG"))!($G(PSOANSQ("RAD"))) K PSONEW("NEWCOPAY")
- ..I '$D(PSOANSQD("RAD")),($P(PSOPENIB,"^",3)=0!($P(PSOPENIB,"^",3)=1)) S PSOANSQD("RAD")=$P(PSOPENIB,"^",3)
- .I $D(PSOIBQS(PSODFN,"PGW")) D D MESSOI,MESS D PGW^PSOMLLDT I $G(PSOCPZ("DFLG"))!($G(PSOANSQ("PGW"))) K PSONEW("NEWCOPAY")
- ..I '$D(PSOANSQD("PGW")),($P(PSOPENIB,"^",4)=0!($P(PSOPENIB,"^",4)=1)) S PSOANSQD("PGW")=$P(PSOPENIB,"^",4)
- .I $D(PSOIBQS(PSODFN,"SHAD")) D D MESSOI,MESS D SHAD^PSOMLLD2 I $G(PSOCPZ("DFLG"))!($G(PSOANSQ("SHAD"))) K PSONEW("NEWCOPAY")
- ..I '$D(PSOANSQD("SHAD")),($P(PSOPENIB,"^",7)=0!($P(PSOPENIB,"^",7)=1)) S PSOANSQD("SHAD")=$P(PSOPENIB,"^",7)
- .I $D(PSOIBQS(PSODFN,"MST")) D D MESSOI,MESS D MST^PSOMLLDT I $G(PSOCPZ("DFLG"))!($G(PSOANSQ("MST"))) K PSONEW("NEWCOPAY")
- ..I '$D(PSOANSQD("MST")),($P(PSOPENIB,"^")=0!($P(PSOPENIB,"^")=1)) S PSOANSQD("MST")=$P(PSOPENIB,"^")
- .I $D(PSOIBQS(PSODFN,"HNC")) D D MESSOI,MESS D HNC^PSOMLLDT I $G(PSOCPZ("DFLG"))!($G(PSOANSQ("HNC"))) K PSONEW("NEWCOPAY")
- ..I '$D(PSOANSQD("HNC")),($P(PSOPENIB,"^",5)=0!($P(PSOPENIB,"^",5)=1)) S PSOANSQD("HNC")=$P(PSOPENIB,"^",5)
- K PSONEWFF,PSOSCOTH,PSOSCOTX,PSOMESFI,PSOSCA
- Q
- SET ;Set original answers that were passed from CPRS
- Q:'$G(ORD)
- Q:'$G(PSOFDR)
- I $P($G(^PS(52.41,ORD,0)),"^",16)="SC"!($P($G(^(0)),"^",16)="NSC") D
- . I PSOSCP<50 S PSOANSQ("SC")=$S($P($G(^(0)),"^",16)="SC":1,1:0),PSOANSQD("SC")=PSOANSQ("SC") S:PSOANSQ("SC")'="" PSOIBQS(PSODFN,"SC")=PSOANSQ("SC")
- . I PSOSCP>49 S PSOANSQ("SC>50")=$S($P($G(^(0)),"^",16)="SC":1,1:0),PSOANSQD("SC>50")=PSOANSQ("SC>50") S:PSOANSQ("SC>50")'="" PSOIBQS(PSODFN,"SC>50")=PSOANSQ("SC>50")
- I $G(PSOPENIB)="" G SET2
- I '$$DT^PSOMLLDT Q
- I $P(PSOPENIB,"^")=0!($P(PSOPENIB,"^")=1) S PSOANSQ("MST")=$P(PSOPENIB,"^")
- I $P(PSOPENIB,"^",2)=0!($P(PSOPENIB,"^",2)=1) S PSOANSQ("VEH")=$P(PSOPENIB,"^",2)
- I $P(PSOPENIB,"^",3)=0!($P(PSOPENIB,"^",3)=1) S PSOANSQ("RAD")=$P(PSOPENIB,"^",3)
- I $P(PSOPENIB,"^",4)=0!($P(PSOPENIB,"^",4)=1) S PSOANSQ("PGW")=$P(PSOPENIB,"^",4)
- I $P(PSOPENIB,"^",5)=0!($P(PSOPENIB,"^",5)=1) S PSOANSQ("HNC")=$P(PSOPENIB,"^",5)
- I $P(PSOPENIB,"^",6)=0!($P(PSOPENIB,"^",6)=1) S PSOANSQ("CV")=$P(PSOPENIB,"^",6)
- I $P(PSOPENIB,"^",7)=0!($P(PSOPENIB,"^",7)=1) S PSOANSQ("SHAD")=$P(PSOPENIB,"^",7)
- ;
- SET2 ;for when patient status is exempt, null IBQ node was set for exempts or SC>50 - data is in ICD node
- N PSOOICD
- I $TR($G(^PS(52.41,+$G(ORD),"IBQ")),"^")="" S PSOOICD=$G(^PS(52.41,ORD,"ICD",1,0)) D SET3:PSOOICD'=""
- ;
- ICD1 ;
- N PSONOCHG S PSONOCHG=0
- I ('$D(PSORXED("ICD"))) S PSONOCHG=1
- I $D(^PS(52.41,ORD,"ICD",0)) D
- . N JJ,ICD,II,FLD,RXN S RXN=ORD
- . S II=0 F S II=$O(^PS(52.41,ORD,"ICD",II)) Q:II=""!(II'?1N.N) D
- .. S ICD=^PS(52.41,ORD,"ICD",II,0),FLD=$P(ICD,U) S:$G(PSONEW("IDFLG")) FLD="" D ICD
- Q
- ;
- SET3 ; called from PSONEWF and PSONEWG; must have PSOOICD. For SC>50, exempt patient status, etc.
- N JJJ
- F JJJ=2:1:9 I $P(PSOOICD,"^",JJJ)=0!($P(PSOOICD,"^",JJJ)=1) D
- . I JJJ=2 S (PSOANSQD("VEH"),PSOANSQ("VEH"))=$P(PSOOICD,"^",JJJ)
- . I JJJ=3 S (PSOANSQD("RAD"),PSOANSQ("RAD"))=$P(PSOOICD,"^",JJJ)
- . I JJJ=4 D
- .. S:PSOSCP<50 (PSOANSQD("SC"),PSOANSQ("SC"))=$P(PSOOICD,"^",JJJ)
- .. S:PSOSCP>49!($P($G(^PS(53,+$G(PSONEW("PATIENT STATUS")),0)),"^",7)=1) (PSOANSQD("SC>50"),PSOANSQ("SC>50"))=$P(PSOOICD,"^",JJJ)
- . I JJJ=5 S (PSOANSQD("PGW"),PSOANSQ("PGW"))=$P(PSOOICD,"^",JJJ)
- . I JJJ=6 S (PSOANSQD("MST"),PSOANSQ("MST"))=$P(PSOOICD,"^",JJJ)
- . I JJJ=7 S (PSOANSQD("HNC"),PSOANSQ("HNC"))=$P(PSOOICD,"^",JJJ)
- . I JJJ=8 S (PSOANSQD("CV"),PSOANSQ("CV"))=$P(PSOOICD,"^",JJJ)
- . I JJJ=9 S (PSOANSQD("SHAD"),PSOANSQ("SHAD"))=$P(PSOOICD,"^",JJJ)
- K PSOOICD
- Q
- MESS ;
- I $G(PSOSCOTX)=1&(PSOSCP<50) W:$G(PSODRUG("DEA"))'["S"&($G(PSODRUG("DEA"))'["I")&($G(PSODRUG("DEA"))'["N") !,"This Rx has been flagged by the provider as: "_$S($G(PSOSCOTH):"NO COPAY",$G(PSORX("SC"))="SC":"NO COPAY",1:"COPAY"),! S PSOSCOTX=2
- Q
- MESSOI ;
- I $G(PSOMESFI)=1 W !!,"The Pharmacy Orderable Item has changed for this order. Please review any",!,"existing SC or Environmental Indicator defaults carefully for appropriateness.",! S PSOMESFI=2
- Q
- ;
- ICD ;called from PSONEWG,PSORENW1 and used by PSONEWF
- I $G(PSOCOPY)&($D(PSORXED("ICD")))&($D(PSONEW("IDFLG"))) Q:'$D(PSORXED("ICD",II))
- I $G(PSOCOPY)&($D(PSORXED("ICD",II))) S PSONEW("ICD",II)=PSORXED("ICD",II) Q
- Q:'$G(PSOCOPY)&('$D(PSORXED("ICD",II)))&('$G(PSONOCHG)) ;don't set deleted ones
- Q:$G(PSONEW("IDFLG"))
- I $D(PSORX("ICD",II)) S PSONEW("ICD",II)=PSORX("ICD",II) Q
- S PSONEW("ICD",II)=FLD
- Q
- ;
- PSONEWF ;BIR/RTR - Copay finish questions ;07/26/96
- +1 ;;7.0;OUTPATIENT PHARMACY;**71,157,143,219,226,239,225,303**;DEC 1997;Build 19
- +2 ;External reference VADPT supported by DBIA 10061
- START ;
- +1 NEW PSOPENIB,PSOSCOTH,PSOSCOTX,PSOMESFI
- +2 SET PSOPENIB=$SELECT($GET(ORD):$GET(^PS(52.41,+$GET(ORD),"IBQ")),1:"")
- +3 ;set PSOSCOTH for display of Provider Copay intent, used with PSORX(SC)
- +4 SET PSOSCOTH=0
- IF $PIECE(PSOPENIB,"^")=1!($PIECE(PSOPENIB,"^",2)=1)!($PIECE(PSOPENIB,"^",3)=1)!($PIECE(PSOPENIB,"^",4)=1)!($PIECE(PSOPENIB,"^",5)=1)!($PIECE(PSOPENIB,"^",6)=1)!($PIECE(PSOPENIB,"^",7)=1)
- SET PSOSCOTH=1
- +5 SET PSOSCOTX=0
- IF $GET(PSOSCOTH)!($GET(PSORX("SC"))="SC")!($GET(PSORX("SC"))="NSC")
- SET PSOSCOTX=1
- +6 ;Check for Orderable Item change to display message
- +7 SET PSOMESFI=0
- IF $GET(OR0)
- IF $GET(PSODRUG("OI"))
- Begin DoDot:1
- +8 IF $GET(PSODRUG("OI"))'=$PIECE($GET(OR0),"^",8)
- SET PSOMESFI=1
- End DoDot:1
- +9 SET PSONEWFF=1
- SET PSOFLAG=1
- +10 ;Copay exemption checks
- +11 DO SCP^PSORN52D
- +12 KILL PSOANSQ
- DO SET
- SET PSOCPZ("DFLG")=0
- SET PSONEW("NEWCOPAY")=0
- +13 IF (PSOSCP<50)&($PIECE($GET(^PS(53,+$GET(PSONEW("PATIENT STATUS")),0)),"^",7)'=1)
- IF $GET(DUZ("AG"))="V"
- DO COPAY^PSOCPB
- WRITE !
- +14 IF $GET(PSOCPZ("DFLG"))
- KILL PSONEW("NEWCOPAY"),PSONEWFF,PSOSCOTH,PSOSCOTX,PSOMESFI
- QUIT
- +15 IF PSOSCA&(PSOSCP>49)!((PSOSCA!(PSOBILL=2))&($PIECE($GET(^PS(53,+$GET(PSONEW("PATIENT STATUS")),0)),"^",7)=1))!(PSOSCP>49&(PSOBILL=2))
- Begin DoDot:1
- +16 IF PSOSCP<50
- DO MESS
- IF PSOSCP<50
- SET PSOANSQD("SC>50")=$GET(PSOANSQD("SC"))
- +17 DO SC^PSOMLLD2
- +18 IF PSOSCP<50&($DATA(PSOANSQD("SC")))
- SET PSOANSQD("SC")=PSOANSQD("SC>50")
- KILL PSOANSQD("SC")
- End DoDot:1
- IF $GET(PSOCPZ("DFLG"))
- KILL PSOANSQ,PSONEW("NEWCOPAY"),PSONEWFF,PSOSCOTH,PSOSCOTX,PSOMESFI
- QUIT
- +19 ;IF MILL BILL, AND COPAY (*******TEST THE COPAY CHECK)
- +20 IF $$DT^PSOMLLDT
- Begin DoDot:1
- +21 ;New prompts Quit after first '^'
- +22 IF $DATA(PSOIBQS(PSODFN,"CV"))
- Begin DoDot:2
- +23 IF '$DATA(PSOANSQD("CV"))
- IF ($PIECE(PSOPENIB,"^",6)=0!($PIECE(PSOPENIB,"^",6)=1))
- SET PSOANSQD("CV")=$PIECE(PSOPENIB,"^",6)
- End DoDot:2
- DO MESSOI
- DO MESS
- DO CV^PSOMLLDT
- IF $GET(PSOCPZ("DFLG"))!($GET(PSOANSQ("CV")))
- KILL PSONEW("NEWCOPAY")
- +24 IF $DATA(PSOIBQS(PSODFN,"VEH"))
- Begin DoDot:2
- +25 IF '$DATA(PSOANSQD("VEH"))
- IF ($PIECE(PSOPENIB,"^",2)=0!($PIECE(PSOPENIB,"^",2)=1))
- SET PSOANSQD("VEH")=$PIECE(PSOPENIB,"^",2)
- End DoDot:2
- DO MESSOI
- DO MESS
- DO VEH^PSOMLLDT
- IF $GET(PSOCPZ("DFLG"))!($GET(PSOANSQ("VEH")))
- KILL PSONEW("NEWCOPAY")
- +26 IF $DATA(PSOIBQS(PSODFN,"RAD"))
- Begin DoDot:2
- +27 IF '$DATA(PSOANSQD("RAD"))
- IF ($PIECE(PSOPENIB,"^",3)=0!($PIECE(PSOPENIB,"^",3)=1))
- SET PSOANSQD("RAD")=$PIECE(PSOPENIB,"^",3)
- End DoDot:2
- DO MESSOI
- DO MESS
- DO RAD^PSOMLLDT
- IF $GET(PSOCPZ("DFLG"))!($GET(PSOANSQ("RAD")))
- KILL PSONEW("NEWCOPAY")
- +28 IF $DATA(PSOIBQS(PSODFN,"PGW"))
- Begin DoDot:2
- +29 IF '$DATA(PSOANSQD("PGW"))
- IF ($PIECE(PSOPENIB,"^",4)=0!($PIECE(PSOPENIB,"^",4)=1))
- SET PSOANSQD("PGW")=$PIECE(PSOPENIB,"^",4)
- End DoDot:2
- DO MESSOI
- DO MESS
- DO PGW^PSOMLLDT
- IF $GET(PSOCPZ("DFLG"))!($GET(PSOANSQ("PGW")))
- KILL PSONEW("NEWCOPAY")
- +30 IF $DATA(PSOIBQS(PSODFN,"SHAD"))
- Begin DoDot:2
- +31 IF '$DATA(PSOANSQD("SHAD"))
- IF ($PIECE(PSOPENIB,"^",7)=0!($PIECE(PSOPENIB,"^",7)=1))
- SET PSOANSQD("SHAD")=$PIECE(PSOPENIB,"^",7)
- End DoDot:2
- DO MESSOI
- DO MESS
- DO SHAD^PSOMLLD2
- IF $GET(PSOCPZ("DFLG"))!($GET(PSOANSQ("SHAD")))
- KILL PSONEW("NEWCOPAY")
- +32 IF $DATA(PSOIBQS(PSODFN,"MST"))
- Begin DoDot:2
- +33 IF '$DATA(PSOANSQD("MST"))
- IF ($PIECE(PSOPENIB,"^")=0!($PIECE(PSOPENIB,"^")=1))
- SET PSOANSQD("MST")=$PIECE(PSOPENIB,"^")
- End DoDot:2
- DO MESSOI
- DO MESS
- DO MST^PSOMLLDT
- IF $GET(PSOCPZ("DFLG"))!($GET(PSOANSQ("MST")))
- KILL PSONEW("NEWCOPAY")
- +34 IF $DATA(PSOIBQS(PSODFN,"HNC"))
- Begin DoDot:2
- +35 IF '$DATA(PSOANSQD("HNC"))
- IF ($PIECE(PSOPENIB,"^",5)=0!($PIECE(PSOPENIB,"^",5)=1))
- SET PSOANSQD("HNC")=$PIECE(PSOPENIB,"^",5)
- End DoDot:2
- DO MESSOI
- DO MESS
- DO HNC^PSOMLLDT
- IF $GET(PSOCPZ("DFLG"))!($GET(PSOANSQ("HNC")))
- KILL PSONEW("NEWCOPAY")
- End DoDot:1
- IF $GET(PSOCPZ("DFLG"))
- KILL PSOANSQ,PSONEW("NEWCOPAY"),PSONEWFF,PSOSCOTH,PSOSCOTX,PSOMESFI
- QUIT
- +36 KILL PSONEWFF,PSOSCOTH,PSOSCOTX,PSOMESFI,PSOSCA
- +37 QUIT
- SET ;Set original answers that were passed from CPRS
- +1 IF '$GET(ORD)
- QUIT
- +2 IF '$GET(PSOFDR)
- QUIT
- +3 IF $PIECE($GET(^PS(52.41,ORD,0)),"^",16)="SC"!($PIECE($GET(^(0)),"^",16)="NSC")
- Begin DoDot:1
- +4 IF PSOSCP<50
- SET PSOANSQ("SC")=$SELECT($PIECE($GET(^(0)),"^",16)="SC":1,1:0)
- SET PSOANSQD("SC")=PSOANSQ("SC")
- IF PSOANSQ("SC")'=""
- SET PSOIBQS(PSODFN,"SC")=PSOANSQ("SC")
- +5 IF PSOSCP>49
- SET PSOANSQ("SC>50")=$SELECT($PIECE($GET(^(0)),"^",16)="SC":1,1:0)
- SET PSOANSQD("SC>50")=PSOANSQ("SC>50")
- IF PSOANSQ("SC>50")'=""
- SET PSOIBQS(PSODFN,"SC>50")=PSOANSQ("SC>50")
- End DoDot:1
- +6 IF $GET(PSOPENIB)=""
- GOTO SET2
- +7 IF '$$DT^PSOMLLDT
- QUIT
- +8 IF $PIECE(PSOPENIB,"^")=0!($PIECE(PSOPENIB,"^")=1)
- SET PSOANSQ("MST")=$PIECE(PSOPENIB,"^")
- +9 IF $PIECE(PSOPENIB,"^",2)=0!($PIECE(PSOPENIB,"^",2)=1)
- SET PSOANSQ("VEH")=$PIECE(PSOPENIB,"^",2)
- +10 IF $PIECE(PSOPENIB,"^",3)=0!($PIECE(PSOPENIB,"^",3)=1)
- SET PSOANSQ("RAD")=$PIECE(PSOPENIB,"^",3)
- +11 IF $PIECE(PSOPENIB,"^",4)=0!($PIECE(PSOPENIB,"^",4)=1)
- SET PSOANSQ("PGW")=$PIECE(PSOPENIB,"^",4)
- +12 IF $PIECE(PSOPENIB,"^",5)=0!($PIECE(PSOPENIB,"^",5)=1)
- SET PSOANSQ("HNC")=$PIECE(PSOPENIB,"^",5)
- +13 IF $PIECE(PSOPENIB,"^",6)=0!($PIECE(PSOPENIB,"^",6)=1)
- SET PSOANSQ("CV")=$PIECE(PSOPENIB,"^",6)
- +14 IF $PIECE(PSOPENIB,"^",7)=0!($PIECE(PSOPENIB,"^",7)=1)
- SET PSOANSQ("SHAD")=$PIECE(PSOPENIB,"^",7)
- +15 ;
- SET2 ;for when patient status is exempt, null IBQ node was set for exempts or SC>50 - data is in ICD node
- +1 NEW PSOOICD
- +2 IF $TRANSLATE($GET(^PS(52.41,+$GET(ORD),"IBQ")),"^")=""
- SET PSOOICD=$GET(^PS(52.41,ORD,"ICD",1,0))
- IF PSOOICD'=""
- DO SET3
- +3 ;
- ICD1 ;
- +1 NEW PSONOCHG
- SET PSONOCHG=0
- +2 IF ('$DATA(PSORXED("ICD")))
- SET PSONOCHG=1
- +3 IF $DATA(^PS(52.41,ORD,"ICD",0))
- Begin DoDot:1
- +4 NEW JJ,ICD,II,FLD,RXN
- SET RXN=ORD
- +5 SET II=0
- FOR
- SET II=$ORDER(^PS(52.41,ORD,"ICD",II))
- IF II=""!(II'?1N.N)
- QUIT
- Begin DoDot:2
- +6 SET ICD=^PS(52.41,ORD,"ICD",II,0)
- SET FLD=$PIECE(ICD,U)
- IF $GET(PSONEW("IDFLG"))
- SET FLD=""
- DO ICD
- End DoDot:2
- End DoDot:1
- +7 QUIT
- +8 ;
- SET3 ; called from PSONEWF and PSONEWG; must have PSOOICD. For SC>50, exempt patient status, etc.
- +1 NEW JJJ
- +2 FOR JJJ=2:1:9
- IF $PIECE(PSOOICD,"^",JJJ)=0!($PIECE(PSOOICD,"^",JJJ)=1)
- Begin DoDot:1
- +3 IF JJJ=2
- SET (PSOANSQD("VEH"),PSOANSQ("VEH"))=$PIECE(PSOOICD,"^",JJJ)
- +4 IF JJJ=3
- SET (PSOANSQD("RAD"),PSOANSQ("RAD"))=$PIECE(PSOOICD,"^",JJJ)
- +5 IF JJJ=4
- Begin DoDot:2
- +6 IF PSOSCP<50
- SET (PSOANSQD("SC"),PSOANSQ("SC"))=$PIECE(PSOOICD,"^",JJJ)
- +7 IF PSOSCP>49!($PIECE($GET(^PS(53,+$GET(PSONEW("PATIENT STATUS")),0)),"^",7)=1)
- SET (PSOANSQD("SC>50"),PSOANSQ("SC>50"))=$PIECE(PSOOICD,"^",JJJ)
- End DoDot:2
- +8 IF JJJ=5
- SET (PSOANSQD("PGW"),PSOANSQ("PGW"))=$PIECE(PSOOICD,"^",JJJ)
- +9 IF JJJ=6
- SET (PSOANSQD("MST"),PSOANSQ("MST"))=$PIECE(PSOOICD,"^",JJJ)
- +10 IF JJJ=7
- SET (PSOANSQD("HNC"),PSOANSQ("HNC"))=$PIECE(PSOOICD,"^",JJJ)
- +11 IF JJJ=8
- SET (PSOANSQD("CV"),PSOANSQ("CV"))=$PIECE(PSOOICD,"^",JJJ)
- +12 IF JJJ=9
- SET (PSOANSQD("SHAD"),PSOANSQ("SHAD"))=$PIECE(PSOOICD,"^",JJJ)
- End DoDot:1
- +13 KILL PSOOICD
- +14 QUIT
- MESS ;
- +1 IF $GET(PSOSCOTX)=1&(PSOSCP<50)
- IF $GET(PSODRUG("DEA"))'["S"&($GET(PSODRUG("DEA"))'["I")&($GET(PSODRUG("DEA"))'["N")
- WRITE !,"This Rx has been flagged by the provider as: "_$SELECT($GET(PSOSCOTH):"NO COPAY",$GET(PSORX("SC"))="SC":"NO COPAY",1:"COPAY"),!
- SET PSOSCOTX=2
- +2 QUIT
- MESSOI ;
- +1 IF $GET(PSOMESFI)=1
- WRITE !!,"The Pharmacy Orderable Item has changed for this order. Please review any",!,"existing SC or Environmental Indicator defaults carefully for appropriateness.",!
- SET PSOMESFI=2
- +2 QUIT
- +3 ;
- ICD ;called from PSONEWG,PSORENW1 and used by PSONEWF
- +1 IF $GET(PSOCOPY)&($DATA(PSORXED("ICD")))&($DATA(PSONEW("IDFLG")))
- IF '$DATA(PSORXED("ICD",II))
- QUIT
- +2 IF $GET(PSOCOPY)&($DATA(PSORXED("ICD",II)))
- SET PSONEW("ICD",II)=PSORXED("ICD",II)
- QUIT
- +3 ;don't set deleted ones
- IF '$GET(PSOCOPY)&('$DATA(PSORXED("ICD",II)))&('$GET(PSONOCHG))
- QUIT
- +4 IF $GET(PSONEW("IDFLG"))
- QUIT
- +5 IF $DATA(PSORX("ICD",II))
- SET PSONEW("ICD",II)=PSORX("ICD",II)
- QUIT
- +6 SET PSONEW("ICD",II)=FLD
- +7 QUIT
- +8 ;
