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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSONEWG 5029 printed Sep 23, 2025@20:07:51 Page 2
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
