- PSONEWG ;BIR/RTR - Copay copy and edit questions ;07/26/96
- ;;7.0;OUTPATIENT PHARMACY;**71,157,143,219,226,239,225**;DEC 1997;Build 29
- ;External reference ^PSDRUG( supported by DBIA 221
- ;External reference VADPT supported by DBIA 10061
- START ;
- N PSOPENIB,PSOMESOI
- S PSOPENIB="" I $G(PSORXED)!($G(PSOCOPY)) I $G(PSORXED("IRXN")) S PSOPENIB=$G(^PSRX(PSORXED("IRXN"),"IBQ"))
- S PSOMESOI=0 I $G(PSORXED) D
- .I $G(PSODRUG("OI")),$P($G(PSORXED("RX0")),"^",6) D
- ..I $G(PSODRUG("OI"))'=$P($G(^PSDRUG(+$P($G(PSORXED("RX0")),"^",6),2)),"^") S PSOMESOI=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 D COPAY^PSOCPB W !
- .;I $G(PSOANSQD("SC"))=0!($G(PSOANSQD("SC"))=1) Q
- .I $G(PSOANSQ("SC"))=0!($G(PSOANSQ("SC"))=1) S PSOANSQD("SC")=$G(PSOANSQ("SC"))
- I PSOSCA&(PSOSCP>49)!((PSOSCA!(PSOBILL=2))&($P($G(^PS(53,+$G(PSONEW("PATIENT STATUS")),0)),"^",7)=1))!(PSOSCP>49&(PSOBILL=2)) D SC^PSOMLLD2 I $G(PSOCPZ("DFLG")) K PSOANSQ,PSONEW("NEWCOPAY"),PSONEWFF,PSOMESOI Q
- I $G(PSOCPZ("DFLG")) K PSONEW("NEWCOPAY"),PSONEWFF,PSOMESOI Q
- ;IF MILL BILL, AND COPAY (*******TEST THE COPAY CHECK)
- I $$DT^PSOMLLDT D I $G(PSOCPZ("DFLG")) K PSOANSQ,PSONEW("NEWCOPAY"),PSONEWFF,PSOMESOI Q
- .;New prompts Quit after first '^'
- .I $D(PSOIBQS(PSODFN,"CV")) D D MESS D CV^PSOMLLDT I $G(PSOCPZ("DFLG"))!($G(PSOANSQ("CV"))) K PSONEW("NEWCOPAY")
- ..I '$D(PSOANSQD("CV")),($P(PSOPENIB,"^",7)=0!($P(PSOPENIB,"^",7)=1)) S PSOANSQD("CV")=$P(PSOPENIB,"^",7)
- .I $D(PSOIBQS(PSODFN,"VEH")) D D MESS D VEH^PSOMLLDT I $G(PSOCPZ("DFLG"))!($G(PSOANSQ("VEH"))) K PSONEW("NEWCOPAY")
- ..I '$D(PSOANSQD("VEH")),($P(PSOPENIB,"^",3)=0!($P(PSOPENIB,"^",3)=1)) S PSOANSQD("VEH")=$P(PSOPENIB,"^",3)
- .I $D(PSOIBQS(PSODFN,"RAD")) D D MESS D RAD^PSOMLLDT I $G(PSOCPZ("DFLG"))!($G(PSOANSQ("RAD"))) K PSONEW("NEWCOPAY")
- ..I '$D(PSOANSQD("RAD")),($P(PSOPENIB,"^",4)=0!($P(PSOPENIB,"^",4)=1)) S PSOANSQD("RAD")=$P(PSOPENIB,"^",4)
- .I $D(PSOIBQS(PSODFN,"PGW")) D D MESS D PGW^PSOMLLDT I $G(PSOCPZ("DFLG"))!($G(PSOANSQ("PGW"))) K PSONEW("NEWCOPAY")
- ..I '$D(PSOANSQD("PGW")),($P(PSOPENIB,"^",5)=0!($P(PSOPENIB,"^",5)=1)) S PSOANSQD("PGW")=$P(PSOPENIB,"^",5)
- .I $D(PSOIBQS(PSODFN,"SHAD")) D D MESS D SHAD^PSOMLLD2 I $G(PSOCPZ("DFLG"))!($G(PSOANSQ("SHAD"))) K PSONEW("NEWCOPAY")
- ..I '$D(PSOANSQD("SHAD")),($P(PSOPENIB,"^",8)=0!($P(PSOPENIB,"^",8)=1)) S PSOANSQD("SHAD")=$P(PSOPENIB,"^",8)
- .I $D(PSOIBQS(PSODFN,"MST")) D D MESS D MST^PSOMLLDT I $G(PSOCPZ("DFLG"))!($G(PSOANSQ("MST"))) K PSONEW("NEWCOPAY")
- ..I '$D(PSOANSQD("MST")),($P(PSOPENIB,"^",2)=0!($P(PSOPENIB,"^",2)=1)) S PSOANSQD("MST")=$P(PSOPENIB,"^",2)
- .I $D(PSOIBQS(PSODFN,"HNC")) D D MESS D HNC^PSOMLLDT I $G(PSOCPZ("DFLG"))!($G(PSOANSQ("HNC"))) K PSONEW("NEWCOPAY")
- ..I '$D(PSOANSQD("HNC")),($P(PSOPENIB,"^",6)=0!($P(PSOPENIB,"^",6)=1)) S PSOANSQD("HNC")=$P(PSOPENIB,"^",6)
- K PSONEWFF,PSOMESOI,PSOSCA
- Q
- SET ;Set original answers that were passed from CPRS
- Q:'$G(PSORXED("IRXN"))
- S PSOANSQ("SC")=$S($P($G(^PSRX(PSORXED("IRXN"),"IBQ")),"^")'="":$P($G(^("IBQ")),"^"),$P($G(^PSRX(PSORXED("IRXN"),"IB")),"^"):0,1:"")
- I $G(PSOANSQ("SC"))="" K PSOANSQ("SC")
- I $G(PSOPENIB)="" G SET2
- I '$$DT^PSOMLLDT Q
- I $P(PSOPENIB,"^",2)=0!($P(PSOPENIB,"^",2)=1) S PSOANSQ("MST")=$P(PSOPENIB,"^",2)
- I $P(PSOPENIB,"^",3)=0!($P(PSOPENIB,"^",3)=1) S PSOANSQ("VEH")=$P(PSOPENIB,"^",3)
- I $P(PSOPENIB,"^",4)=0!($P(PSOPENIB,"^",4)=1) S PSOANSQ("RAD")=$P(PSOPENIB,"^",4)
- I $P(PSOPENIB,"^",5)=0!($P(PSOPENIB,"^",5)=1) S PSOANSQ("PGW")=$P(PSOPENIB,"^",5)
- I $P(PSOPENIB,"^",6)=0!($P(PSOPENIB,"^",6)=1) S PSOANSQ("HNC")=$P(PSOPENIB,"^",6)
- I $P(PSOPENIB,"^",7)=0!($P(PSOPENIB,"^",7)=1) S PSOANSQ("CV")=$P(PSOPENIB,"^",7)
- I $P(PSOPENIB,"^",8)=0!($P(PSOPENIB,"^",8)=1) S PSOANSQ("SHAD")=$P(PSOPENIB,"^",8)
- ;
- SET2 ;for when patient status is exempt, null IBQ node was set for exempts or SC>50 - data is in ICD node
- N PSOOICD,JJJ
- I $TR($G(^PSRX(PSODFN,"IBQ")),"^")="" S PSOOICD=$G(^PSRX(PSORXED("IRXN"),"ICD",1,0)) D SET3^PSONEWF:PSOOICD'=""
- ;
- ICD ;
- N JJ,ICD,II,FLD,RXN,TNEW,PSONOCHG S PSONOCHG=0
- S RXN=PSORXED("IRXN")
- I '$D(PSONEW("ICD"))&('$D(PSORXED("ICD"))) S PSONOCHG=1
- I $D(^PSRX(RXN,"ICD",0)) D
- . S II=0 F S II=$O(^PSRX(RXN,"ICD",II)) Q:II=""!(II'?1N.N)!($G(PSOCOPY)&(II>1)&('PSONOCHG)) D
- .. S ICD=^PSRX(RXN,"ICD",II,0),FLD=$P(ICD,U) S:$G(PSONEW("IDFLG")) FLD="" D ICD^PSONEWF
- E I $G(PSONEW("IDFLG")) K ^PSRX(RXN,"ICD","B") S $P(^PSRX(RXN,"ICD",1,0),"^",1)="",TNEW=2 D
- . F TNEW=TNEW:1:8 Q:'$D(^PSRX(RXN,"ICD",TNEW,0)) S DIK="^PSRX("_RXN_","_$C(34)_"ICD"_$C(34)_",",DA=TNEW,DA(1)=RXN D ^DIK K DA,DIK ;user deleted all
- K PSONEW("IDFLG"),PSORXED("IDFLG")
- Q
- MESS ;
- I $G(PSOMESOI)=1,$G(PSORXED) W !!,"The Pharmacy Orderable Item has changed for this order. Please review any",!,"existing SC or Environmental Indicator defaults carefully for appropriateness.",! S PSOMESOI=2
- Q
- PSONEWG ;BIR/RTR - Copay copy and edit questions ;07/26/96
- +1 ;;7.0;OUTPATIENT PHARMACY;**71,157,143,219,226,239,225**;DEC 1997;Build 29
- +2 ;External reference ^PSDRUG( supported by DBIA 221
- +3 ;External reference VADPT supported by DBIA 10061
- START ;
- +1 NEW PSOPENIB,PSOMESOI
- +2 SET PSOPENIB=""
- IF $GET(PSORXED)!($GET(PSOCOPY))
- IF $GET(PSORXED("IRXN"))
- SET PSOPENIB=$GET(^PSRX(PSORXED("IRXN"),"IBQ"))
- +3 SET PSOMESOI=0
- IF $GET(PSORXED)
- Begin DoDot:1
- +4 IF $GET(PSODRUG("OI"))
- IF $PIECE($GET(PSORXED("RX0")),"^",6)
- Begin DoDot:2
- +5 IF $GET(PSODRUG("OI"))'=$PIECE($GET(^PSDRUG(+$PIECE($GET(PSORXED("RX0")),"^",6),2)),"^")
- SET PSOMESOI=1
- End DoDot:2
- End DoDot:1
- +6 SET PSONEWFF=1
- SET PSOFLAG=1
- +7 ;Copay exemption checks
- +8 DO SCP^PSORN52D
- +9 KILL PSOANSQ
- DO SET
- SET PSOCPZ("DFLG")=0
- SET PSONEW("NEWCOPAY")=0
- +10 IF PSOSCP<50&($PIECE($GET(^PS(53,+$GET(PSONEW("PATIENT STATUS")),0)),"^",7)'=1)
- IF $GET(DUZ("AG"))="V"
- Begin DoDot:1
- +11 ;I $G(PSOANSQD("SC"))=0!($G(PSOANSQD("SC"))=1) Q
- +12 IF $GET(PSOANSQ("SC"))=0!($GET(PSOANSQ("SC"))=1)
- SET PSOANSQD("SC")=$GET(PSOANSQ("SC"))
- End DoDot:1
- DO COPAY^PSOCPB
- WRITE !
- +13 IF PSOSCA&(PSOSCP>49)!((PSOSCA!(PSOBILL=2))&($PIECE($GET(^PS(53,+$GET(PSONEW("PATIENT STATUS")),0)),"^",7)=1))!(PSOSCP>49&(PSOBILL=2))
- DO SC^PSOMLLD2
- IF $GET(PSOCPZ("DFLG"))
- KILL PSOANSQ,PSONEW("NEWCOPAY"),PSONEWFF,PSOMESOI
- QUIT
- +14 IF $GET(PSOCPZ("DFLG"))
- KILL PSONEW("NEWCOPAY"),PSONEWFF,PSOMESOI
- QUIT
- +15 ;IF MILL BILL, AND COPAY (*******TEST THE COPAY CHECK)
- +16 IF $$DT^PSOMLLDT
- Begin DoDot:1
- +17 ;New prompts Quit after first '^'
- +18 IF $DATA(PSOIBQS(PSODFN,"CV"))
- Begin DoDot:2
- +19 IF '$DATA(PSOANSQD("CV"))
- IF ($PIECE(PSOPENIB,"^",7)=0!($PIECE(PSOPENIB,"^",7)=1))
- SET PSOANSQD("CV")=$PIECE(PSOPENIB,"^",7)
- End DoDot:2
- DO MESS
- DO CV^PSOMLLDT
- IF $GET(PSOCPZ("DFLG"))!($GET(PSOANSQ("CV")))
- KILL PSONEW("NEWCOPAY")
- +20 IF $DATA(PSOIBQS(PSODFN,"VEH"))
- Begin DoDot:2
- +21 IF '$DATA(PSOANSQD("VEH"))
- IF ($PIECE(PSOPENIB,"^",3)=0!($PIECE(PSOPENIB,"^",3)=1))
- SET PSOANSQD("VEH")=$PIECE(PSOPENIB,"^",3)
- End DoDot:2
- DO MESS
- DO VEH^PSOMLLDT
- IF $GET(PSOCPZ("DFLG"))!($GET(PSOANSQ("VEH")))
- KILL PSONEW("NEWCOPAY")
- +22 IF $DATA(PSOIBQS(PSODFN,"RAD"))
- Begin DoDot:2
- +23 IF '$DATA(PSOANSQD("RAD"))
- IF ($PIECE(PSOPENIB,"^",4)=0!($PIECE(PSOPENIB,"^",4)=1))
- SET PSOANSQD("RAD")=$PIECE(PSOPENIB,"^",4)
- End DoDot:2
- DO MESS
- DO RAD^PSOMLLDT
- IF $GET(PSOCPZ("DFLG"))!($GET(PSOANSQ("RAD")))
- KILL PSONEW("NEWCOPAY")
- +24 IF $DATA(PSOIBQS(PSODFN,"PGW"))
- Begin DoDot:2
- +25 IF '$DATA(PSOANSQD("PGW"))
- IF ($PIECE(PSOPENIB,"^",5)=0!($PIECE(PSOPENIB,"^",5)=1))
- SET PSOANSQD("PGW")=$PIECE(PSOPENIB,"^",5)
- End DoDot:2
- DO MESS
- DO PGW^PSOMLLDT
- IF $GET(PSOCPZ("DFLG"))!($GET(PSOANSQ("PGW")))
- KILL PSONEW("NEWCOPAY")
- +26 IF $DATA(PSOIBQS(PSODFN,"SHAD"))
- Begin DoDot:2
- +27 IF '$DATA(PSOANSQD("SHAD"))
- IF ($PIECE(PSOPENIB,"^",8)=0!($PIECE(PSOPENIB,"^",8)=1))
- SET PSOANSQD("SHAD")=$PIECE(PSOPENIB,"^",8)
- End DoDot:2
- DO MESS
- DO SHAD^PSOMLLD2
- IF $GET(PSOCPZ("DFLG"))!($GET(PSOANSQ("SHAD")))
- KILL PSONEW("NEWCOPAY")
- +28 IF $DATA(PSOIBQS(PSODFN,"MST"))
- Begin DoDot:2
- +29 IF '$DATA(PSOANSQD("MST"))
- IF ($PIECE(PSOPENIB,"^",2)=0!($PIECE(PSOPENIB,"^",2)=1))
- SET PSOANSQD("MST")=$PIECE(PSOPENIB,"^",2)
- End DoDot:2
- DO MESS
- DO MST^PSOMLLDT
- IF $GET(PSOCPZ("DFLG"))!($GET(PSOANSQ("MST")))
- KILL PSONEW("NEWCOPAY")
- +30 IF $DATA(PSOIBQS(PSODFN,"HNC"))
- Begin DoDot:2
- +31 IF '$DATA(PSOANSQD("HNC"))
- IF ($PIECE(PSOPENIB,"^",6)=0!($PIECE(PSOPENIB,"^",6)=1))
- SET PSOANSQD("HNC")=$PIECE(PSOPENIB,"^",6)
- End DoDot:2
- 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,PSOMESOI
- QUIT
- +32 KILL PSONEWFF,PSOMESOI,PSOSCA
- +33 QUIT
- SET ;Set original answers that were passed from CPRS
- +1 IF '$GET(PSORXED("IRXN"))
- QUIT
- +2 SET PSOANSQ("SC")=$SELECT($PIECE($GET(^PSRX(PSORXED("IRXN"),"IBQ")),"^")'="":$PIECE($GET(^("IBQ")),"^"),$PIECE($GET(^PSRX(PSORXED("IRXN"),"IB")),"^"):0,1:"")
- +3 IF $GET(PSOANSQ("SC"))=""
- KILL PSOANSQ("SC")
- +4 IF $GET(PSOPENIB)=""
- GOTO SET2
- +5 IF '$$DT^PSOMLLDT
- QUIT
- +6 IF $PIECE(PSOPENIB,"^",2)=0!($PIECE(PSOPENIB,"^",2)=1)
- SET PSOANSQ("MST")=$PIECE(PSOPENIB,"^",2)
- +7 IF $PIECE(PSOPENIB,"^",3)=0!($PIECE(PSOPENIB,"^",3)=1)
- SET PSOANSQ("VEH")=$PIECE(PSOPENIB,"^",3)
- +8 IF $PIECE(PSOPENIB,"^",4)=0!($PIECE(PSOPENIB,"^",4)=1)
- SET PSOANSQ("RAD")=$PIECE(PSOPENIB,"^",4)
- +9 IF $PIECE(PSOPENIB,"^",5)=0!($PIECE(PSOPENIB,"^",5)=1)
- SET PSOANSQ("PGW")=$PIECE(PSOPENIB,"^",5)
- +10 IF $PIECE(PSOPENIB,"^",6)=0!($PIECE(PSOPENIB,"^",6)=1)
- SET PSOANSQ("HNC")=$PIECE(PSOPENIB,"^",6)
- +11 IF $PIECE(PSOPENIB,"^",7)=0!($PIECE(PSOPENIB,"^",7)=1)
- SET PSOANSQ("CV")=$PIECE(PSOPENIB,"^",7)
- +12 IF $PIECE(PSOPENIB,"^",8)=0!($PIECE(PSOPENIB,"^",8)=1)
- SET PSOANSQ("SHAD")=$PIECE(PSOPENIB,"^",8)
- +13 ;
- 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,JJJ
- +2 IF $TRANSLATE($GET(^PSRX(PSODFN,"IBQ")),"^")=""
- SET PSOOICD=$GET(^PSRX(PSORXED("IRXN"),"ICD",1,0))
- IF PSOOICD'=""
- DO SET3^PSONEWF
- +3 ;
- ICD ;
- +1 NEW JJ,ICD,II,FLD,RXN,TNEW,PSONOCHG
- SET PSONOCHG=0
- +2 SET RXN=PSORXED("IRXN")
- +3 IF '$DATA(PSONEW("ICD"))&('$DATA(PSORXED("ICD")))
- SET PSONOCHG=1
- +4 IF $DATA(^PSRX(RXN,"ICD",0))
- Begin DoDot:1
- +5 SET II=0
- FOR
- SET II=$ORDER(^PSRX(RXN,"ICD",II))
- IF II=""!(II'?1N.N)!($GET(PSOCOPY)&(II>1)&('PSONOCHG))
- QUIT
- Begin DoDot:2
- +6 SET ICD=^PSRX(RXN,"ICD",II,0)
- SET FLD=$PIECE(ICD,U)
- IF $GET(PSONEW("IDFLG"))
- SET FLD=""
- DO ICD^PSONEWF
- End DoDot:2
- End DoDot:1
- +7 IF '$TEST
- IF $GET(PSONEW("IDFLG"))
- KILL ^PSRX(RXN,"ICD","B")
- SET $PIECE(^PSRX(RXN,"ICD",1,0),"^",1)=""
- SET TNEW=2
- Begin DoDot:1
- +8 ;user deleted all
- FOR TNEW=TNEW:1:8
- IF '$DATA(^PSRX(RXN,"ICD",TNEW,0))
- QUIT
- SET DIK="^PSRX("_RXN_","_$CHAR(34)_"ICD"_$CHAR(34)_","
- SET DA=TNEW
- SET DA(1)=RXN
- DO ^DIK
- KILL DA,DIK
- End DoDot:1
- +9 KILL PSONEW("IDFLG"),PSORXED("IDFLG")
- +10 QUIT
- MESS ;
- +1 IF $GET(PSOMESOI)=1
- IF $GET(PSORXED)
- WRITE !!,"The Pharmacy Orderable Item has changed for this order. Please review any",!,"existing SC or Environmental Indicator defaults carefully for appropriateness.",!
- SET PSOMESOI=2
- +2 QUIT
