PSORN52D ;BIR/LE - files new and renewal entries con't ;02/27/04
;;7.0;OUTPATIENT PHARMACY;**143,219,239,225**;DEC 1997;Build 29
;External reference VADPT supported by DBIA 10061
Q
GET ;must have FILE and PSORENW variables to pull default data for ICD and SC/EI for SC>50% Rx's from file 52
N ARRAY,ERR,SUBF,RXN,II,JJ,ORXN,SUBFLD,PENDSC,PSOPATST,PSOIBQF
I FILE=52 S SUBF=52.052311,SUBFLD=52311,RXN=PSORENW("IRXN"),(SRXN,ORXN)=PSORENW("OIRXN") S:($TR($G(^PSRX(SRXN,"IBQ")),"^")'="") PSOIBQF=1
;$TR checks for when patient status is exempt, null IBQ node was set for exempts, or SC>50 - data is in ICD node
I FILE=52.41 S SUBF=52.41311,SUBFLD=311,(SRXN,RXN)=ORD,ORXN=PSORENW("OIRXN") S:($TR($G(^PS(52.41,SRXN,"IBQ")),"^")'="") PSOIBQF=1
D GETS^DIQ(FILE,SRXN,SUBFLD_"*","I","ARRAY","ERR")
K PSORX("ICD"),PSOX("ICD")
Q:'$D(ARRAY)
I FILE=52.41 S PENDSC=$$GET1^DIQ(52.41,ORD,"17"),PENDSC=$S(PENDSC="SC":1,PENDSC="NSC":0,1:"")
S PSOPATST=$$GET1^DIQ(52,RXN_",",3,"I")
;
G1 ;get ICD, if no IBQ node get SC/EI's
F II=1:1:8 Q:'$D(ARRAY(SUBF,(II_","_SRXN_","))) D
. S PSORX("ICD",II)=ARRAY(SUBF,(II_","_SRXN_","),.01,"I") S:FILE=52.41 PSONEW("ICD",II)=PSORX("ICD",II)
. Q:II>1!($G(PSOIBQF)) ;only need ei's from 1st node; all nodes same for SC/EI
. F JJ=1:1:8 I ARRAY(SUBF,(II_","_SRXN_","),JJ,"I")=1!(ARRAY(SUBF,(II_","_SRXN_","),JJ,"I")=0) D
.. I JJ=1 S (PSOANSQ(RXN,"VEH"),PSORX(ORXN,"VEH"))=ARRAY(SUBF,(II_","_SRXN_","),JJ,"I") Q
.. I JJ=2 S (PSOANSQ(RXN,"RAD"),PSORX(ORXN,"RAD"))=ARRAY(SUBF,(II_","_SRXN_","),JJ,"I") Q
.. I JJ=4 S (PSOANSQ(RXN,"PGW"),PSORX(ORXN,"PGW"))=ARRAY(SUBF,(II_","_SRXN_","),JJ,"I") Q
.. I JJ=5 S (PSOANSQ(RXN,"MST"),PSORX(ORXN,"MST"))=ARRAY(SUBF,(II_","_SRXN_","),JJ,"I") Q
.. I JJ=6 S (PSOANSQ(RXN,"HNC"),PSORX(ORXN,"HNC"))=ARRAY(SUBF,(II_","_SRXN_","),JJ,"I") Q
.. I JJ=7 S (PSOANSQ(RXN,"CV"),PSORX(ORXN,"CV"))=ARRAY(SUBF,(II_","_SRXN_","),JJ,"I") Q
.. I JJ=8 S (PSOANSQ(RXN,"SHAD"),PSORX(ORXN,"SHAD"))=ARRAY(SUBF,(II_","_SRXN_","),JJ,"I") Q
I '$G(PSOIBQF) S II=1,JJ=3 D
. I PSOSCP>49&(FILE=52.41) S (PSOANSQ(RXN,"SC>50"),PSORX(ORXN,"SC>50"),PSOANSQ("SC>50"))=PENDSC Q
. I PSOSCP>49&(FILE'=52.41) S:$D(ARRAY(SUBF,(II_","_SRXN_","),JJ,"I")) (PSOANSQ(RXN,"SC>50"),PSOANSQ("SC>50"),PSORX(ORXN,"SC>50"))=ARRAY(SUBF,(II_","_SRXN_","),JJ,"I") Q
. ; when patient status is exempt use SC>50 variable to differenciate regular SC<50 and exempt SC<50
. I PSOSCP<50&($P($G(^PS(53,+$G(PSOPATST),0)),"^",7)=1) D
.. I FILE=52.41 S (PSOANSQ(RXN,"SC>50"),PSORX(ORXN,"SC>50"),PSOANSQ("SC>50"))=PENDSC Q
.. S:$G(ARRAY(SUBF,(II_","_SRXN_","),JJ,"I")) (PSOANSQ(RXN,"SC>50"),PSORX(ORXN,"SC>50"),PSOANSQ("SC>50"))=ARRAY(SUBF,(II_","_SRXN_","),JJ,"I")
. I PSOSCP<50&($P($G(^PS(53,+$G(PSOPATST),0)),"^",7)'=1) D
.. I FILE=52.41 S (PSOANSQ(RXN,"SC"),PSORX(ORXN,"SC"),PSOANSQ("SC"))=PENDSC Q
.. S:$D(ARRAY(SUBF,(II_","_SRXN_","),JJ,"I")) (PSOANSQ(RXN,"SC"),PSORX(ORXN,"SC"),PSOANSQ("SC"))=ARRAY(SUBF,(II_","_SRXN_","),JJ,"I")
Q
;
FILE ;
Q:'$D(^PSRX(PSOX("OIRXN"),"ICD"))
N II F II=1:1:8 Q:$G(^PSRX(PSOX("OIRXN"),"ICD",II,0))="" D
. S ^PSRX(PSOX("IRXN"),"ICD",II,0)=$G(^PSRX(PSOX("OIRXN"),"ICD",II,0))
. S:$P(^PSRX(PSOX("IRXN"),"ICD",II,0),"^",1)'="" ^PSRX(PSOX("IRXN"),"ICD","B",$P(^PSRX(PSOX("IRXN"),"ICD",II,0),"^",1),II)=""
I II>1 S ^PSRX(PSOX("IRXN"),"ICD",0)="^52.052311^"_(II-1)_"^"_(II-1)
Q
FILE2 ;file ICD's on existing node or build new nodes
;note: variable PSOSCP2 is only available from CPRS Edit API and MISS
; sub-routine below.
N D,RXN,II,TYPE,DATA,DATA1,PSOPATST
I $G(PSOX("IRXN")) S PSOPATST=$$GET1^DIQ(52,PSOX("IRXN")_",",3,"I")
;I '$G(PSONEW("PATIENT STATUS")) I $G(PSOX("IRXN")) S PSONEW("PATIENT STATUS")=$$GET1^DIQ(52,PSOX("IRXN")_",",3,"I")
I $G(PSOSCP2)!($G(PSOFDR)&($G(ORD))) D
.;if RX edited in CPRS delete all but what is sent from CPRS
. K ^PSRX(PSOX("IRXN"),"ICD"),^PSRX(PSOX("IRXN"),"IBQ")
S DATA="^^^^^^^^",(DATA1,TYPE)=""
S $P(DATA,U,4)=$S(PSOSCP>49:$G(PSOANSQ("SC>50")),PSOSCP<50&($P($G(^PS(53,+$G(PSOPATST),0)),"^",7)=1):$G(PSOANSQ("SC>50")),PSOSCP<50&(PSOSCP'=""):$G(PSOANSQ("SC")),1:"")
F S TYPE=$O(PSOANSQ(PSOX("IRXN"),TYPE)) Q:TYPE="" D
. I TYPE="VEH" S $P(DATA,U,2)=PSOANSQ(PSOX("IRXN"),"VEH")
. I TYPE="RAD" S $P(DATA,U,3)=PSOANSQ(PSOX("IRXN"),"RAD")
. I TYPE="PGW" S $P(DATA,U,5)=PSOANSQ(PSOX("IRXN"),"PGW")
. I TYPE="MST" S $P(DATA,U,6)=PSOANSQ(PSOX("IRXN"),"MST")
. I TYPE="HNC" S $P(DATA,U,7)=PSOANSQ(PSOX("IRXN"),"HNC")
. I TYPE="CV" S $P(DATA,U,8)=PSOANSQ(PSOX("IRXN"),"CV")
. I TYPE="SHAD" S $P(DATA,U,9)=PSOANSQ(PSOX("IRXN"),"SHAD")
I $O(PSORX("ICD","")) F D=1:1:8 Q:'$D(PSORX("ICD",D)) S $P(DATA,"^")=PSORX("ICD",D) D
. S ^PSRX(PSOX("IRXN"),"ICD",D,0)=DATA,$P(DATA,"^")="",^PSRX(PSOX("IRXN"),"ICD",0)="^52.052311P^"_D_"^"_D
. S:PSORX("ICD",D)'="" ^PSRX(PSOX("IRXN"),"ICD","B",PSORX("ICD",D),D)=""
E S ^PSRX(PSOX("IRXN"),"ICD",0)="^52.052311P^1^1",^PSRX(PSOX("IRXN"),"ICD",1,0)=$G(DATA)
I PSOSCP<50&(($TR(DATA,"^")'=""))&(($P($G(^PS(53,+$G(PSOPATST),0)),"^",7)'=1)) D
.S DATA1=$G(PSOANSQ("SC"))_"^"_$G(PSOANSQ(PSOX("IRXN"),"MST"))_"^"_$G(PSOANSQ(PSOX("IRXN"),"VEH"))_"^"_$G(PSOANSQ(PSOX("IRXN"),"RAD"))
.S DATA1=DATA1_"^"_$G(PSOANSQ(PSOX("IRXN"),"PGW"))_"^"_$G(PSOANSQ(PSOX("IRXN"),"HNC"))_"^"_$G(PSOANSQ(PSOX("IRXN"),"CV"))_"^"_$G(PSOANSQ(PSOX("IRXN"),"SHAD"))
.S:($TR(DATA1,"^")'="") ^PSRX(PSOX("IRXN"),"IBQ")=DATA1
K PSORX("ICD")
Q
;
RESET ;called from reset copay status PSOCPC
;Must be available at this point: PSODA, PSOIBQ=SC^MST^AO^IR^EC^HNC^CV^SHAD
Q:'$D(PSODA)!('$D(PSOIBQ))
Q:'$D(^PSRX(PSODA))
;Q:'$D(^PSRX(PSODA,"ICD")) ;if old Rx and no ICD's defined; don't set
N I,DATA,PSOICD
S:$D(^PSRX(PSODA,"ICD")) PSOICD=1
I '$G(DFN) S DFN=$$GET1^DIQ(52,PSODA_",",2,"I")
S DATA="^^^^^^^^"
F I=1:1:8 D
. I I=1 S $P(DATA,"^",4)=$P(PSOIBQ,"^",I)
. I I=2 S $P(DATA,"^",6)=$P(PSOIBQ,"^",I)
. I I=3 S $P(DATA,"^",2)=$P(PSOIBQ,"^",I)
. I I=4 S $P(DATA,"^",3)=$P(PSOIBQ,"^",I)
. I I=5 S $P(DATA,"^",5)=$P(PSOIBQ,"^",I)
. I I=6 S $P(DATA,"^",7)=$P(PSOIBQ,"^",I)
. I I=7 S $P(DATA,"^",8)=$P(PSOIBQ,"^",I)
. I I=8 S $P(DATA,"^",9)=$P(PSOIBQ,"^",I)
I $G(PSOICD) S I=0 F S I=$O(^PSRX(PSODA,"ICD",I)) Q:I=""!(I'?1N.NN) D
. Q:'$D(^PSRX(PSODA,"ICD",I,0))
. S $P(^PSRX(PSODA,"ICD",I,0),"^",2,9)=$P(DATA,"^",2,9)
; for pre-cidc RX
I '$G(PSOICD) S ^PSRX(PSODA,"ICD",1,0)="^"_$P(DATA,"^",2,9),^PSRX(PSODA,"ICD",0)="^52.052311P^1^1"
Q
;
SCP ;Called from multiple routines - DFN or PSODFN variable must be available to call this subroutine.
I '$G(DFN) S DFN=+$G(PSODFN)
D ELIG^VADPT S PSOANSQ("SC>50")="",(PSOSCA,PSOSCP)="",PSOSCP=$P(VAEL(3),U,2)
S:PSOSCP=""&($P(VAEL(3),U)=1) PSOSCP=0
S PSOSCA=$$SC^SDCO22(DFN)
K VAEL
Q
SHAD ;
N XX
I $P($G(PSOPIBQ),U,8)]"" S XX=$P(PSOPIBQ,U,8) I XX=0!(XX=1) S PSOANSQ(PSOX("IRXN"),"SHAD")=XX Q
I $P($G(^PSRX(RXN,"ICD",1,0)),U,9)]"" S XX=$P($G(^PSRX(PSOX("IRXN"),"ICD",1,0)),U,9) S:XX=0!(XX=1) PSOANSQ(PSOX("IRXN"),"SHAD")=XX
Q
;
SET3 ;for when patient status is exempt or SC>50
N PSOPATST S PSOPATST=PSORX("PATIENT STATUS")
I PSORX("PATIENT STATUS")'?1N.N S PSOPATST="",PSOPATST=$O(^PS(53,"B",PSORX("PATIENT STATUS"),PSOPATST))
F JJJ=2:1:9 I $P(PSOOICD,"^",JJJ)=0!($P(PSOOICD,"^",JJJ)=1) D
. I JJJ=2 S PSORX(PSOIBOLD,"VEH")=$P(PSOOICD,"^",JJJ)
. I JJJ=3 S PSORX(PSOIBOLD,"RAD")=$P(PSOOICD,"^",JJJ)
. I JJJ=4 D
.. S:PSOSCP<50 PSORX(PSOIBOLD,"SC")=$P(PSOOICD,"^",JJJ)
.. S:PSOSCP>49!($P($G(^PS(53,+$G(PSOPATST),0)),"^",7)=1) PSORX(PSOIBOLD,"SC>50")=$P(PSOOICD,"^",JJJ)
. I JJJ=5 S PSORX(PSOIBOLD,"PGW")=$P(PSOOICD,"^",JJJ)
. I JJJ=6 S PSORX(PSOIBOLD,"MST")=$P(PSOOICD,"^",JJJ)
. I JJJ=7 S PSORX(PSOIBOLD,"HNC")=$P(PSOOICD,"^",JJJ)
. I JJJ=8 S PSORX(PSOIBOLD,"CV")=$P(PSOOICD,"^",JJJ)
. I JJJ=9 S PSORX(PSOIBOLD,"SHAD")=$P(PSOOICD,"^",JJJ)
K JJJ,PSOOICD
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSORN52D 7878 printed Sep 23, 2025@20:10:35 Page 2
PSORN52D ;BIR/LE - files new and renewal entries con't ;02/27/04
+1 ;;7.0;OUTPATIENT PHARMACY;**143,219,239,225**;DEC 1997;Build 29
+2 ;External reference VADPT supported by DBIA 10061
+3 QUIT
GET ;must have FILE and PSORENW variables to pull default data for ICD and SC/EI for SC>50% Rx's from file 52
+1 NEW ARRAY,ERR,SUBF,RXN,II,JJ,ORXN,SUBFLD,PENDSC,PSOPATST,PSOIBQF
+2 IF FILE=52
SET SUBF=52.052311
SET SUBFLD=52311
SET RXN=PSORENW("IRXN")
SET (SRXN,ORXN)=PSORENW("OIRXN")
if ($TRANSLATE($GET(^PSRX(SRXN,"IBQ")),"^")'="")
SET PSOIBQF=1
+3 ;$TR checks for when patient status is exempt, null IBQ node was set for exempts, or SC>50 - data is in ICD node
+4 IF FILE=52.41
SET SUBF=52.41311
SET SUBFLD=311
SET (SRXN,RXN)=ORD
SET ORXN=PSORENW("OIRXN")
if ($TRANSLATE($GET(^PS(52.41,SRXN,"IBQ")),"^")'="")
SET PSOIBQF=1
+5 DO GETS^DIQ(FILE,SRXN,SUBFLD_"*","I","ARRAY","ERR")
+6 KILL PSORX("ICD"),PSOX("ICD")
+7 if '$DATA(ARRAY)
QUIT
+8 IF FILE=52.41
SET PENDSC=$$GET1^DIQ(52.41,ORD,"17")
SET PENDSC=$SELECT(PENDSC="SC":1,PENDSC="NSC":0,1:"")
+9 SET PSOPATST=$$GET1^DIQ(52,RXN_",",3,"I")
+10 ;
G1 ;get ICD, if no IBQ node get SC/EI's
+1 FOR II=1:1:8
if '$DATA(ARRAY(SUBF,(II_","_SRXN_",")))
QUIT
Begin DoDot:1
+2 SET PSORX("ICD",II)=ARRAY(SUBF,(II_","_SRXN_","),.01,"I")
if FILE=52.41
SET PSONEW("ICD",II)=PSORX("ICD",II)
+3 ;only need ei's from 1st node; all nodes same for SC/EI
if II>1!($GET(PSOIBQF))
QUIT
+4 FOR JJ=1:1:8
IF ARRAY(SUBF,(II_","_SRXN_","),JJ,"I")=1!(ARRAY(SUBF,(II_","_SRXN_","),JJ,"I")=0)
Begin DoDot:2
+5 IF JJ=1
SET (PSOANSQ(RXN,"VEH"),PSORX(ORXN,"VEH"))=ARRAY(SUBF,(II_","_SRXN_","),JJ,"I")
QUIT
+6 IF JJ=2
SET (PSOANSQ(RXN,"RAD"),PSORX(ORXN,"RAD"))=ARRAY(SUBF,(II_","_SRXN_","),JJ,"I")
QUIT
+7 IF JJ=4
SET (PSOANSQ(RXN,"PGW"),PSORX(ORXN,"PGW"))=ARRAY(SUBF,(II_","_SRXN_","),JJ,"I")
QUIT
+8 IF JJ=5
SET (PSOANSQ(RXN,"MST"),PSORX(ORXN,"MST"))=ARRAY(SUBF,(II_","_SRXN_","),JJ,"I")
QUIT
+9 IF JJ=6
SET (PSOANSQ(RXN,"HNC"),PSORX(ORXN,"HNC"))=ARRAY(SUBF,(II_","_SRXN_","),JJ,"I")
QUIT
+10 IF JJ=7
SET (PSOANSQ(RXN,"CV"),PSORX(ORXN,"CV"))=ARRAY(SUBF,(II_","_SRXN_","),JJ,"I")
QUIT
+11 IF JJ=8
SET (PSOANSQ(RXN,"SHAD"),PSORX(ORXN,"SHAD"))=ARRAY(SUBF,(II_","_SRXN_","),JJ,"I")
QUIT
End DoDot:2
End DoDot:1
+12 IF '$GET(PSOIBQF)
SET II=1
SET JJ=3
Begin DoDot:1
+13 IF PSOSCP>49&(FILE=52.41)
SET (PSOANSQ(RXN,"SC>50"),PSORX(ORXN,"SC>50"),PSOANSQ("SC>50"))=PENDSC
QUIT
+14 IF PSOSCP>49&(FILE'=52.41)
if $DATA(ARRAY(SUBF,(II_","_SRXN_","),JJ,"I"))
SET (PSOANSQ(RXN,"SC>50"),PSOANSQ("SC>50"),PSORX(ORXN,"SC>50"))=ARRAY(SUBF,(II_","_SRXN_","),JJ,"I")
QUIT
+15 ; when patient status is exempt use SC>50 variable to differenciate regular SC<50 and exempt SC<50
+16 IF PSOSCP<50&($PIECE($GET(^PS(53,+$GET(PSOPATST),0)),"^",7)=1)
Begin DoDot:2
+17 IF FILE=52.41
SET (PSOANSQ(RXN,"SC>50"),PSORX(ORXN,"SC>50"),PSOANSQ("SC>50"))=PENDSC
QUIT
+18 if $GET(ARRAY(SUBF,(II_","_SRXN_","),JJ,"I"))
SET (PSOANSQ(RXN,"SC>50"),PSORX(ORXN,"SC>50"),PSOANSQ("SC>50"))=ARRAY(SUBF,(II_","_SRXN_","),JJ,"I")
End DoDot:2
+19 IF PSOSCP<50&($PIECE($GET(^PS(53,+$GET(PSOPATST),0)),"^",7)'=1)
Begin DoDot:2
+20 IF FILE=52.41
SET (PSOANSQ(RXN,"SC"),PSORX(ORXN,"SC"),PSOANSQ("SC"))=PENDSC
QUIT
+21 if $DATA(ARRAY(SUBF,(II_","_SRXN_","),JJ,"I"))
SET (PSOANSQ(RXN,"SC"),PSORX(ORXN,"SC"),PSOANSQ("SC"))=ARRAY(SUBF,(II_","_SRXN_","),JJ,"I")
End DoDot:2
End DoDot:1
+22 QUIT
+23 ;
FILE ;
+1 if '$DATA(^PSRX(PSOX("OIRXN"),"ICD"))
QUIT
+2 NEW II
FOR II=1:1:8
if $GET(^PSRX(PSOX("OIRXN"),"ICD",II,0))=""
QUIT
Begin DoDot:1
+3 SET ^PSRX(PSOX("IRXN"),"ICD",II,0)=$GET(^PSRX(PSOX("OIRXN"),"ICD",II,0))
+4 if $PIECE(^PSRX(PSOX("IRXN"),"ICD",II,0),"^",1)'=""
SET ^PSRX(PSOX("IRXN"),"ICD","B",$PIECE(^PSRX(PSOX("IRXN"),"ICD",II,0),"^",1),II)=""
End DoDot:1
+5 IF II>1
SET ^PSRX(PSOX("IRXN"),"ICD",0)="^52.052311^"_(II-1)_"^"_(II-1)
+6 QUIT
FILE2 ;file ICD's on existing node or build new nodes
+1 ;note: variable PSOSCP2 is only available from CPRS Edit API and MISS
+2 ; sub-routine below.
+3 NEW D,RXN,II,TYPE,DATA,DATA1,PSOPATST
+4 IF $GET(PSOX("IRXN"))
SET PSOPATST=$$GET1^DIQ(52,PSOX("IRXN")_",",3,"I")
+5 ;I '$G(PSONEW("PATIENT STATUS")) I $G(PSOX("IRXN")) S PSONEW("PATIENT STATUS")=$$GET1^DIQ(52,PSOX("IRXN")_",",3,"I")
+6 IF $GET(PSOSCP2)!($GET(PSOFDR)&($GET(ORD)))
Begin DoDot:1
+7 ;if RX edited in CPRS delete all but what is sent from CPRS
+8 KILL ^PSRX(PSOX("IRXN"),"ICD"),^PSRX(PSOX("IRXN"),"IBQ")
End DoDot:1
+9 SET DATA="^^^^^^^^"
SET (DATA1,TYPE)=""
+10 SET $PIECE(DATA,U,4)=$SELECT(PSOSCP>49:$GET(PSOANSQ("SC>50")),PSOSCP<50&($PIECE($GET(^PS(53,+$GET(PSOPATST),0)),"^",7)=1):$GET(PSOANSQ("SC>50")),PSOSCP<50&(PSOSCP'=""):$GET(PSOANSQ("SC")),1:"")
+11 FOR
SET TYPE=$ORDER(PSOANSQ(PSOX("IRXN"),TYPE))
if TYPE=""
QUIT
Begin DoDot:1
+12 IF TYPE="VEH"
SET $PIECE(DATA,U,2)=PSOANSQ(PSOX("IRXN"),"VEH")
+13 IF TYPE="RAD"
SET $PIECE(DATA,U,3)=PSOANSQ(PSOX("IRXN"),"RAD")
+14 IF TYPE="PGW"
SET $PIECE(DATA,U,5)=PSOANSQ(PSOX("IRXN"),"PGW")
+15 IF TYPE="MST"
SET $PIECE(DATA,U,6)=PSOANSQ(PSOX("IRXN"),"MST")
+16 IF TYPE="HNC"
SET $PIECE(DATA,U,7)=PSOANSQ(PSOX("IRXN"),"HNC")
+17 IF TYPE="CV"
SET $PIECE(DATA,U,8)=PSOANSQ(PSOX("IRXN"),"CV")
+18 IF TYPE="SHAD"
SET $PIECE(DATA,U,9)=PSOANSQ(PSOX("IRXN"),"SHAD")
End DoDot:1
+19 IF $ORDER(PSORX("ICD",""))
FOR D=1:1:8
if '$DATA(PSORX("ICD",D))
QUIT
SET $PIECE(DATA,"^")=PSORX("ICD",D)
Begin DoDot:1
+20 SET ^PSRX(PSOX("IRXN"),"ICD",D,0)=DATA
SET $PIECE(DATA,"^")=""
SET ^PSRX(PSOX("IRXN"),"ICD",0)="^52.052311P^"_D_"^"_D
+21 if PSORX("ICD",D)'=""
SET ^PSRX(PSOX("IRXN"),"ICD","B",PSORX("ICD",D),D)=""
End DoDot:1
+22 IF '$TEST
SET ^PSRX(PSOX("IRXN"),"ICD",0)="^52.052311P^1^1"
SET ^PSRX(PSOX("IRXN"),"ICD",1,0)=$GET(DATA)
+23 IF PSOSCP<50&(($TRANSLATE(DATA,"^")'=""))&(($PIECE($GET(^PS(53,+$GET(PSOPATST),0)),"^",7)'=1))
Begin DoDot:1
+24 SET DATA1=$GET(PSOANSQ("SC"))_"^"_$GET(PSOANSQ(PSOX("IRXN"),"MST"))_"^"_$GET(PSOANSQ(PSOX("IRXN"),"VEH"))_"^"_$GET(PSOANSQ(PSOX("IRXN"),"RAD"))
+25 SET DATA1=DATA1_"^"_$GET(PSOANSQ(PSOX("IRXN"),"PGW"))_"^"_$GET(PSOANSQ(PSOX("IRXN"),"HNC"))_"^"_$GET(PSOANSQ(PSOX("IRXN"),"CV"))_"^"_$GET(PSOANSQ(PSOX("IRXN"),"SHAD"))
+26 if ($TRANSLATE(DATA1,"^")'="")
SET ^PSRX(PSOX("IRXN"),"IBQ")=DATA1
End DoDot:1
+27 KILL PSORX("ICD")
+28 QUIT
+29 ;
RESET ;called from reset copay status PSOCPC
+1 ;Must be available at this point: PSODA, PSOIBQ=SC^MST^AO^IR^EC^HNC^CV^SHAD
+2 if '$DATA(PSODA)!('$DATA(PSOIBQ))
QUIT
+3 if '$DATA(^PSRX(PSODA))
QUIT
+4 ;Q:'$D(^PSRX(PSODA,"ICD")) ;if old Rx and no ICD's defined; don't set
+5 NEW I,DATA,PSOICD
+6 if $DATA(^PSRX(PSODA,"ICD"))
SET PSOICD=1
+7 IF '$GET(DFN)
SET DFN=$$GET1^DIQ(52,PSODA_",",2,"I")
+8 SET DATA="^^^^^^^^"
+9 FOR I=1:1:8
Begin DoDot:1
+10 IF I=1
SET $PIECE(DATA,"^",4)=$PIECE(PSOIBQ,"^",I)
+11 IF I=2
SET $PIECE(DATA,"^",6)=$PIECE(PSOIBQ,"^",I)
+12 IF I=3
SET $PIECE(DATA,"^",2)=$PIECE(PSOIBQ,"^",I)
+13 IF I=4
SET $PIECE(DATA,"^",3)=$PIECE(PSOIBQ,"^",I)
+14 IF I=5
SET $PIECE(DATA,"^",5)=$PIECE(PSOIBQ,"^",I)
+15 IF I=6
SET $PIECE(DATA,"^",7)=$PIECE(PSOIBQ,"^",I)
+16 IF I=7
SET $PIECE(DATA,"^",8)=$PIECE(PSOIBQ,"^",I)
+17 IF I=8
SET $PIECE(DATA,"^",9)=$PIECE(PSOIBQ,"^",I)
End DoDot:1
+18 IF $GET(PSOICD)
SET I=0
FOR
SET I=$ORDER(^PSRX(PSODA,"ICD",I))
if I=""!(I'?1N.NN)
QUIT
Begin DoDot:1
+19 if '$DATA(^PSRX(PSODA,"ICD",I,0))
QUIT
+20 SET $PIECE(^PSRX(PSODA,"ICD",I,0),"^",2,9)=$PIECE(DATA,"^",2,9)
End DoDot:1
+21 ; for pre-cidc RX
+22 IF '$GET(PSOICD)
SET ^PSRX(PSODA,"ICD",1,0)="^"_$PIECE(DATA,"^",2,9)
SET ^PSRX(PSODA,"ICD",0)="^52.052311P^1^1"
+23 QUIT
+24 ;
SCP ;Called from multiple routines - DFN or PSODFN variable must be available to call this subroutine.
+1 IF '$GET(DFN)
SET DFN=+$GET(PSODFN)
+2 DO ELIG^VADPT
SET PSOANSQ("SC>50")=""
SET (PSOSCA,PSOSCP)=""
SET PSOSCP=$PIECE(VAEL(3),U,2)
+3 if PSOSCP=""&($PIECE(VAEL(3),U)=1)
SET PSOSCP=0
+4 SET PSOSCA=$$SC^SDCO22(DFN)
+5 KILL VAEL
+6 QUIT
SHAD ;
+1 NEW XX
+2 IF $PIECE($GET(PSOPIBQ),U,8)]""
SET XX=$PIECE(PSOPIBQ,U,8)
IF XX=0!(XX=1)
SET PSOANSQ(PSOX("IRXN"),"SHAD")=XX
QUIT
+3 IF $PIECE($GET(^PSRX(RXN,"ICD",1,0)),U,9)]""
SET XX=$PIECE($GET(^PSRX(PSOX("IRXN"),"ICD",1,0)),U,9)
if XX=0!(XX=1)
SET PSOANSQ(PSOX("IRXN"),"SHAD")=XX
+4 QUIT
+5 ;
SET3 ;for when patient status is exempt or SC>50
+1 NEW PSOPATST
SET PSOPATST=PSORX("PATIENT STATUS")
+2 IF PSORX("PATIENT STATUS")'?1N.N
SET PSOPATST=""
SET PSOPATST=$ORDER(^PS(53,"B",PSORX("PATIENT STATUS"),PSOPATST))
+3 FOR JJJ=2:1:9
IF $PIECE(PSOOICD,"^",JJJ)=0!($PIECE(PSOOICD,"^",JJJ)=1)
Begin DoDot:1
+4 IF JJJ=2
SET PSORX(PSOIBOLD,"VEH")=$PIECE(PSOOICD,"^",JJJ)
+5 IF JJJ=3
SET PSORX(PSOIBOLD,"RAD")=$PIECE(PSOOICD,"^",JJJ)
+6 IF JJJ=4
Begin DoDot:2
+7 if PSOSCP<50
SET PSORX(PSOIBOLD,"SC")=$PIECE(PSOOICD,"^",JJJ)
+8 if PSOSCP>49!($PIECE($GET(^PS(53,+$GET(PSOPATST),0)),"^",7)=1)
SET PSORX(PSOIBOLD,"SC>50")=$PIECE(PSOOICD,"^",JJJ)
End DoDot:2
+9 IF JJJ=5
SET PSORX(PSOIBOLD,"PGW")=$PIECE(PSOOICD,"^",JJJ)
+10 IF JJJ=6
SET PSORX(PSOIBOLD,"MST")=$PIECE(PSOOICD,"^",JJJ)
+11 IF JJJ=7
SET PSORX(PSOIBOLD,"HNC")=$PIECE(PSOOICD,"^",JJJ)
+12 IF JJJ=8
SET PSORX(PSOIBOLD,"CV")=$PIECE(PSOOICD,"^",JJJ)
+13 IF JJJ=9
SET PSORX(PSOIBOLD,"SHAD")=$PIECE(PSOOICD,"^",JJJ)
End DoDot:1
+14 KILL JJJ,PSOOICD
+15 QUIT
