PSIVORFA ;BIR/MLM - FILE/RETRIEVE ORDERS IN 53.1 ;Jun 17, 2020@15:41:25
;;5.0;INPATIENT MEDICATIONS;**4,7,18,28,50,71,58,91,80,110,111,134,225,267,275,279,259,399**;16 DEC 97;Build 64
;
; Reference to ^PS(51.1 supported by DBIA 2177.
; Reference to ^PS(51.2 supported by DBIA 2178.
; Reference to ^PS(52.7 supported by DBIA 2173.
; Reference to ^PS(52.6 supported by DBIA 1231.
;
GT531(DFN,ON,PSJAPI) ; Retrieve order data from 53.1 and place into local array
;
; PSJAPI - If being called from background job, PSJAPI=1.
NEW PSGOES S PSGOES=1
F X="CUM","LF","LFA","LF","PRNTON" S P(X)=""
S Y=$G(^PS(53.1,+ON,0)),P(17)=$P(Y,U,9),P("LOG")=$P(Y,U,16),(P(21),P("21FLG"),PSJORIFN)=$P(Y,U,21)
S P("RES")=$P(Y,U,24),P("OLDON")=$P(Y,U,25),P("NEWON")=$P(Y,U,26),P("FRES")=$P(Y,U,27)
S P("MR")=$P(Y,U,3),P(6)=+$P(Y,U,2),Y=$G(^VA(200,+P(6),0)),$P(P(6),U,2)=$P(Y,U),Y=$G(^PS(51.2,+P("MR"),0)),$P(P("MR"),U,2)=$S($P(Y,U,3)]"":$P(Y,U,3),1:$P(Y,U))
S Y=$G(^PS(53.1,+ON,.2)),P("PD")=$S(+Y:$P(Y,U)_U_$$OIDF^PSJLMUT1(+Y),1:""),P("DO")=$P(Y,U,2),P("NAT")=$P(Y,U,3),P("PRY")=$P(Y,U,4),(PSJCOM,P("PRNTON"))=$P(Y,U,8)
S P("INS")=$G(^PS(53.1,+ON,.3)),P("IND")=$G(^PS(53.1,+ON,18)) ;*399-IND
I $G(^PS(53.1,+ON,4))]"" S P("NINIT")=$P(^(4),U),P("NINITDT")=$P(^(4),U,2)
NEW NAME S NAME=""
I $D(^PS(53.1,+ON,1,1)) D DD^PSJLMUT1("^PS(53.1,+ON,",.NAME)
S:$P(^PS(53.1,+ON,0),U,4)="U" P("INS")=P("INS")_$S(P("INS")]"":" of ",1:"")_NAME ;Only display instructions for unit dose orders
S P("APPT")=$G(^PS(53.1,+ON,"DSS")),P("CLIN")=$P(P("APPT"),"^"),P("APPT")=$P(P("APPT"),"^",2)
S Y=$G(^PS(53.1,+ON,2)),P(9)=$P(Y,U),P(11)=$P(Y,U,5),P(15)=$S($P(Y,U,6)'="":$P(Y,U,6),$G(PSGS0XT)'="":PSGS0XT,$P($G(ZZND),"^",3)'="":$P(ZZND,"^",3),1:""),P(2)=$P(Y,U,2),P(3)=$P(Y,U,4)
S Y=$G(^PS(53.1,+ON,4)),P("CLRK")=$P(Y,U,7)_U_$P($G(^VA(200,+$P(Y,U,7),0)),U),P("REN")=$P(Y,U,9),X=P(9)
I $P($G(^PS(53.1,+ON,0)),U,7)="P",(P(9)'["PRN") S P(9)=P(9)_" PRN"
K PSGST,XT
;PSJ*5*225 remove 1440 default
I P(9)]"",P(9)'["PRN",(P(11)="") D S P(15)=$S($G(XT)]""&'+$G(XT):XT,+$G(XT)>0:XT,$G(PSGS0XT):PSGS0XT,1:1440),P(11)=Y
. I $O(^PS(51.1,"APPSJ",P(9),0)) D DIC^PSGORS0 Q
. I '$O(^PS(51.1,"APPSJ",P(9),0)) N NOECH,PSGSCH S NOECH=1 D EN^PSIVSP
S Y=$G(^PS(53.1,+ON,8)),P(4)=$P(Y,U),P(23)=$P(Y,U,2),P("SYRS")=$P(Y,U,3),P(5)=$P(Y,U,4),P(8)=$P(Y,U,5),P(7)=$P(Y,U,7),P("IVRM")=$P(Y,U,8)
I ($G(^PS(53.1,+ON,17))?1.N) S P("NUMLBL")=$G(^(17))
I '$G(P("NUMLBL")) S P("NUMLBL")=$P($G(P(8)),"@",2)
N PSJABBIN S PSJABBIN=$P(P(8),"@") I PSJABBIN]"" D
.Q:(P(8)?1"INFUSE OVER "1.N1" MINUTES")
.D EXPINF^PSIVEDT1(.PSJABBIN,1) S P(8)=PSJABBIN_$S($G(P("NUMLBL"))?1.N:"@"_P("NUMLBL"),1:"")
S P(4)=$S(P(4)'="":P(4),$G(PSIVTYPE):PSIVTYPE,1:"")
S:'P("IVRM")&($D(PSIVSN)) P("IVRM")=+PSIVSN S Y=$G(^PS(59.5,+P("IVRM"),0)),$P(P("IVRM"),U,2)=$P(Y,U),Y=$G(^PS(53.1,+ON,9)),P("REM")=$P(Y,U),P("OPI")=$P(Y,U,2,3)
S P("DTYP")=$S(P(4)="":0,P(4)="P"!(P(23)="P")!(P(5)):1,P(4)="H":2,1:3)
S P("PACT")=$G(^PS(53.1,+ON,"A",1,0))
D GTDRG,GTOT^PSIVUTL(P(4)) D:'$D(PSJLABEL) GTPC(ON)
N ND2P5 S ND2P5=$G(^PS(53.1,+ON,2.5)) D
.S P("DUR")=$P(ND2P5,"^",2)
.S P("LIMIT")=$P(ND2P5,"^",4)
.S P("IVCAT")=$P(ND2P5,"^",5)
N LONGOPI S LONGOPI=$$GETOPI^PSJBCMA5(DFN,ON,$S($G(PSJAPI):1,1:""))
Q
GTDRG ;
K DRG F X="AD","SOL" S FIL=$S(X="AD":52.6,1:52.7) F Y=0:0 S Y=$O(^PS(53.1,+ON,X,Y)) Q:'Y D
.S (DRGI,DRG(X,0))=$G(DRG(X,0))+1,DRG=$G(^PS(53.1,+ON,X,Y,0)),ND=$G(^PS(FIL,+DRG,0)),DRGN=$P(ND,U),DRG(X,+DRGI)=+DRG_U_$P(ND,U)_U_$P(DRG,U,2)_U_$P(DRG,U,3)_U_$P(ND,U,13)_U_$P(ND,U,11)
Q
;
GTPC(ON) ; Retrieve Provider Comments and create "scratch" fields to edit
Q
;
PUT531 ; Move data in local variables to 53.1
S:'$D(P(9)) P(9)=$G(PSGSCH)
S ND(0)=+ON_U_+P(6)_U_$S(+P("MR"):+P("MR"),1:"")_U_$P(P("OT"),U)_U_U_U_"C",$P(ND(0),U,9)=P(17),$P(ND(0),U,21)=$G(P(21))
S $P(ND(0),U,14,16)=P("LOG")_U_DFN_U_P("LOG"),$P(ND(0),U,24,26)=$G(P("RES"))_U_$G(P("OLDON"))_U_$G(P("NEWON"))
S ND(2)=P(9)_U_P(2)_U_U_P(3)_U_P(11)_U_$S($G(P(15))'="":P(15),$G(PSGS0XT)'="":PSGS0XT,$P($G(ZZND),"^",3)'="":$P(ZZND,"^",3),1:""),$P(ND(4),U,7,9)=+P("CLRK")_U_U_P("REN")
S ND(8)=P(4)_U_P(23)_U_P("SYRS")_U_P(5)_U_P(8)_"^^"_P(7)_"^"_+P("IVRM"),ND(9)=$S($L(P("REM")_P("OPI")):P("REM")_U_P("OPI"),1:"") S $P(ND(4),U,1,2)=$G(P("NINIT"))_U_$G(P("NINITDT"))
S:+$G(P("CLIN")) $P(^PS(53.1,+ON,"DSS"),"^")=P("CLIN")
S:+$G(P("APPT")) $P(^PS(53.1,+ON,"DSS"),"^",2)=P("APPT")
S:$G(P("LIMIT"))]"" $P(^PS(53.1,+ON,2.5),"^",4)=P("LIMIT")
I $G(PSJORD)["V"!($G(PSJORD)["P") I $G(^PS(53.1,+ON,2.5))="" N DUR S DUR=$$GETDUR^PSJLIVMD(DFN,+PSJORD,$S((PSJORD["P"):"P",1:"IV"),1) I DUR]"" D
.I $G(IVLIMIT) S $P(^PS(53.1,+ON,2.5),"^",4)=DUR K IVLIMIT Q
.S $P(^PS(53.1,+ON,2.5),"^",2)=DUR
F X=0,2,4,8,9 S ^PS(53.1,+ON,X)=ND(X)
I $G(P("NUMLBL"))?1.N!($G(P("NUMLBL"))="") S $P(^PS(53.1,+ON,17),"^")=$G(P("NUMLBL"))
S PSIVCAT=$$IVCAT^PSJHLU(DFN,ON,.P) S:PSIVCAT]"" $P(^PS(53.1,+ON,2.5),"^",5)=PSIVCAT K PSIVCAT
S:'+$G(^PS(53.1,+ON,.2)) $P(^(.2),U,1,3)=+P("PD")_U_P("DO")_U_$G(P("NAT"))
F DRGT="AD","SOL" D:$D(DRG(DRGT)) PTD531
K DA,DIK S PSGS0Y=P(11),PSGS0XT=P(15),DA=+ON,DIK="^PS(53.1," D IX^DIK K DA,DIK,PSGS0Y,PSGS0XT,ND,^PS(53.1,"AS","P",DFN,+ON)
K:P(17)="A" ^PS(53.1,"AS","N",DFN,+ON)
S:P(15)="D" $P(^PS(53.1,+ON,2),U,6)="D"
S:$D(P("IND")) ^PS(53.1,+ON,18)=P("IND") ;*399-IND
I $G(PSJINFIN) K PSJINFIN I $D(^PS(53.45,+$G(PSJSYSP),6)),'$D(^PS(53.1,+ON,"A")),'$D(^PS(53.1,+ON,16)) S PSJINFIN=2
I $G(PSJSYSP) D
.I '$D(^PS(53.45,+PSJSYSP,6)) I $G(PSJORD)["V"!($G(PSJORD)["P") I '$D(^PS(53.1,+ON,16)) N I S I=$$GETOPI^PSJBCMA5(DFN,PSJORD)
.I $D(^PS(53.45,+PSJSYSP,6)) D FILEOPI^PSJBCMA5(DFN,ON)
Q
;
UPD100 ; Update order data in file 100
D:'$D(PSJIVORF) ORPARM^PSIVOREN Q:'PSJIVORF
S PSJORL=$$ENORL^PSJUTL($G(VAIN(4))) D SET^PSIVORFE
Q
;
PTD531 ; Move drug data from local array into 53.1
K ^PS(53.1,+ON,DRGT) S ^PS(53.1,+ON,DRGT,0)=$S(DRGT="AD":"^53.157^0^0",1:"^53.158^0^0")
F X=0:0 S X=$O(DRG(DRGT,X)) Q:'X D
.S X1=$P(DRG(DRGT,X),U),Y=^PS(53.1,+ON,DRGT,0),$P(Y,U,3)=$P(Y,U,3)+1,DRG=$P(Y,U,3),$P(Y,U,4)=$P(Y,U,4)+1
.S ^PS(53.1,+ON,DRGT,0)=Y,Y=+X1_U_$P(DRG(DRGT,X),U,3) S:DRGT="AD" $P(Y,U,3)=$P(DRG(DRGT,X),U,4) S ^PS(53.1,+ON,DRGT,+DRG,0)=Y
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSIVORFA 6249 printed Sep 23, 2025@19:40:49 Page 2
PSIVORFA ;BIR/MLM - FILE/RETRIEVE ORDERS IN 53.1 ;Jun 17, 2020@15:41:25
+1 ;;5.0;INPATIENT MEDICATIONS;**4,7,18,28,50,71,58,91,80,110,111,134,225,267,275,279,259,399**;16 DEC 97;Build 64
+2 ;
+3 ; Reference to ^PS(51.1 supported by DBIA 2177.
+4 ; Reference to ^PS(51.2 supported by DBIA 2178.
+5 ; Reference to ^PS(52.7 supported by DBIA 2173.
+6 ; Reference to ^PS(52.6 supported by DBIA 1231.
+7 ;
GT531(DFN,ON,PSJAPI) ; Retrieve order data from 53.1 and place into local array
+1 ;
+2 ; PSJAPI - If being called from background job, PSJAPI=1.
+3 NEW PSGOES
SET PSGOES=1
+4 FOR X="CUM","LF","LFA","LF","PRNTON"
SET P(X)=""
+5 SET Y=$GET(^PS(53.1,+ON,0))
SET P(17)=$PIECE(Y,U,9)
SET P("LOG")=$PIECE(Y,U,16)
SET (P(21),P("21FLG"),PSJORIFN)=$PIECE(Y,U,21)
+6 SET P("RES")=$PIECE(Y,U,24)
SET P("OLDON")=$PIECE(Y,U,25)
SET P("NEWON")=$PIECE(Y,U,26)
SET P("FRES")=$PIECE(Y,U,27)
+7 SET P("MR")=$PIECE(Y,U,3)
SET P(6)=+$PIECE(Y,U,2)
SET Y=$GET(^VA(200,+P(6),0))
SET $PIECE(P(6),U,2)=$PIECE(Y,U)
SET Y=$GET(^PS(51.2,+P("MR"),0))
SET $PIECE(P("MR"),U,2)=$SELECT($PIECE(Y,U,3)]"":$PIECE(Y,U,3),1:$PIECE(Y,U))
+8 SET Y=$GET(^PS(53.1,+ON,.2))
SET P("PD")=$SELECT(+Y:$PIECE(Y,U)_U_$$OIDF^PSJLMUT1(+Y),1:"")
SET P("DO")=$PIECE(Y,U,2)
SET P("NAT")=$PIECE(Y,U,3)
SET P("PRY")=$PIECE(Y,U,4)
SET (PSJCOM,P("PRNTON"))=$PIECE(Y,U,8)
+9 ;*399-IND
SET P("INS")=$GET(^PS(53.1,+ON,.3))
SET P("IND")=$GET(^PS(53.1,+ON,18))
+10 IF $GET(^PS(53.1,+ON,4))]""
SET P("NINIT")=$PIECE(^(4),U)
SET P("NINITDT")=$PIECE(^(4),U,2)
+11 NEW NAME
SET NAME=""
+12 IF $DATA(^PS(53.1,+ON,1,1))
DO DD^PSJLMUT1("^PS(53.1,+ON,",.NAME)
+13 ;Only display instructions for unit dose orders
if $PIECE(^PS(53.1,+ON,0),U,4)="U"
SET P("INS")=P("INS")_$SELECT(P("INS")]"":" of ",1:"")_NAME
+14 SET P("APPT")=$GET(^PS(53.1,+ON,"DSS"))
SET P("CLIN")=$PIECE(P("APPT"),"^")
SET P("APPT")=$PIECE(P("APPT"),"^",2)
+15 SET Y=$GET(^PS(53.1,+ON,2))
SET P(9)=$PIECE(Y,U)
SET P(11)=$PIECE(Y,U,5)
SET P(15)=$SELECT($PIECE(Y,U,6)'="":$PIECE(Y,U,6),$GET(PSGS0XT)'="":PSGS0XT,$PIECE($GET(ZZND),"^",3)'="":$PIECE(ZZND,"^",3),1:"")
SET P(2)=$PIECE(Y,U,2)
SET P(3)=$PIECE(Y,U,4)
+16 SET Y=$GET(^PS(53.1,+ON,4))
SET P("CLRK")=$PIECE(Y,U,7)_U_$PIECE($GET(^VA(200,+$PIECE(Y,U,7),0)),U)
SET P("REN")=$PIECE(Y,U,9)
SET X=P(9)
+17 IF $PIECE($GET(^PS(53.1,+ON,0)),U,7)="P"
IF (P(9)'["PRN")
SET P(9)=P(9)_" PRN"
+18 KILL PSGST,XT
+19 ;PSJ*5*225 remove 1440 default
+20 IF P(9)]""
IF P(9)'["PRN"
IF (P(11)="")
Begin DoDot:1
+21 IF $ORDER(^PS(51.1,"APPSJ",P(9),0))
DO DIC^PSGORS0
QUIT
+22 IF '$ORDER(^PS(51.1,"APPSJ",P(9),0))
NEW NOECH,PSGSCH
SET NOECH=1
DO EN^PSIVSP
End DoDot:1
SET P(15)=$SELECT($GET(XT)]""&'+$GET(XT):XT,+$GET(XT)>0:XT,$GET(PSGS0XT):PSGS0XT,1:1440)
SET P(11)=Y
+23 SET Y=$GET(^PS(53.1,+ON,8))
SET P(4)=$PIECE(Y,U)
SET P(23)=$PIECE(Y,U,2)
SET P("SYRS")=$PIECE(Y,U,3)
SET P(5)=$PIECE(Y,U,4)
SET P(8)=$PIECE(Y,U,5)
SET P(7)=$PIECE(Y,U,7)
SET P("IVRM")=$PIECE(Y,U,8)
+24 IF ($GET(^PS(53.1,+ON,17))?1.N)
SET P("NUMLBL")=$GET(^(17))
+25 IF '$GET(P("NUMLBL"))
SET P("NUMLBL")=$PIECE($GET(P(8)),"@",2)
+26 NEW PSJABBIN
SET PSJABBIN=$PIECE(P(8),"@")
IF PSJABBIN]""
Begin DoDot:1
+27 if (P(8)?1"INFUSE OVER "1.N1" MINUTES")
QUIT
+28 DO EXPINF^PSIVEDT1(.PSJABBIN,1)
SET P(8)=PSJABBIN_$SELECT($GET(P("NUMLBL"))?1.N:"@"_P("NUMLBL"),1:"")
End DoDot:1
+29 SET P(4)=$SELECT(P(4)'="":P(4),$GET(PSIVTYPE):PSIVTYPE,1:"")
+30 if 'P("IVRM")&($DATA(PSIVSN))
SET P("IVRM")=+PSIVSN
SET Y=$GET(^PS(59.5,+P("IVRM"),0))
SET $PIECE(P("IVRM"),U,2)=$PIECE(Y,U)
SET Y=$GET(^PS(53.1,+ON,9))
SET P("REM")=$PIECE(Y,U)
SET P("OPI")=$PIECE(Y,U,2,3)
+31 SET P("DTYP")=$SELECT(P(4)="":0,P(4)="P"!(P(23)="P")!(P(5)):1,P(4)="H":2,1:3)
+32 SET P("PACT")=$GET(^PS(53.1,+ON,"A",1,0))
+33 DO GTDRG
DO GTOT^PSIVUTL(P(4))
if '$DATA(PSJLABEL)
DO GTPC(ON)
+34 NEW ND2P5
SET ND2P5=$GET(^PS(53.1,+ON,2.5))
Begin DoDot:1
+35 SET P("DUR")=$PIECE(ND2P5,"^",2)
+36 SET P("LIMIT")=$PIECE(ND2P5,"^",4)
+37 SET P("IVCAT")=$PIECE(ND2P5,"^",5)
End DoDot:1
+38 NEW LONGOPI
SET LONGOPI=$$GETOPI^PSJBCMA5(DFN,ON,$SELECT($GET(PSJAPI):1,1:""))
+39 QUIT
GTDRG ;
+1 KILL DRG
FOR X="AD","SOL"
SET FIL=$SELECT(X="AD":52.6,1:52.7)
FOR Y=0:0
SET Y=$ORDER(^PS(53.1,+ON,X,Y))
if 'Y
QUIT
Begin DoDot:1
+2 SET (DRGI,DRG(X,0))=$GET(DRG(X,0))+1
SET DRG=$GET(^PS(53.1,+ON,X,Y,0))
SET ND=$GET(^PS(FIL,+DRG,0))
SET DRGN=$PIECE(ND,U)
SET DRG(X,+DRGI)=+DRG_U_$PIECE(ND,U)_U_$PIECE(DRG,U,2)_U_$PIECE(DRG,U,3)_U_$PIECE(ND,U,13)_U_$PIECE(ND,U,11)
End DoDot:1
+3 QUIT
+4 ;
GTPC(ON) ; Retrieve Provider Comments and create "scratch" fields to edit
+1 QUIT
+2 ;
PUT531 ; Move data in local variables to 53.1
+1 if '$DATA(P(9))
SET P(9)=$GET(PSGSCH)
+2 SET ND(0)=+ON_U_+P(6)_U_$SELECT(+P("MR"):+P("MR"),1:"")_U_$PIECE(P("OT"),U)_U_U_U_"C"
SET $PIECE(ND(0),U,9)=P(17)
SET $PIECE(ND(0),U,21)=$GET(P(21))
+3 SET $PIECE(ND(0),U,14,16)=P("LOG")_U_DFN_U_P("LOG")
SET $PIECE(ND(0),U,24,26)=$GET(P("RES"))_U_$GET(P("OLDON"))_U_$GET(P("NEWON"))
+4 SET ND(2)=P(9)_U_P(2)_U_U_P(3)_U_P(11)_U_$SELECT($GET(P(15))'="":P(15),$GET(PSGS0XT)'="":PSGS0XT,$PIECE($GET(ZZND),"^",3)'="":$PIECE(ZZND,"^",3),1:"")
SET $PIECE(ND(4),U,7,9)=+P("CLRK")_U_U_P("REN")
+5 SET ND(8)=P(4)_U_P(23)_U_P("SYRS")_U_P(5)_U_P(8)_"^^"_P(7)_"^"_+P("IVRM")
SET ND(9)=$SELECT($LENGTH(P("REM")_P("OPI")):P("REM")_U_P("OPI"),1:"")
SET $PIECE(ND(4),U,1,2)=$GET(P("NINIT"))_U_$GET(P("NINITDT"))
+6 if +$GET(P("CLIN"))
SET $PIECE(^PS(53.1,+ON,"DSS"),"^")=P("CLIN")
+7 if +$GET(P("APPT"))
SET $PIECE(^PS(53.1,+ON,"DSS"),"^",2)=P("APPT")
+8 if $GET(P("LIMIT"))]""
SET $PIECE(^PS(53.1,+ON,2.5),"^",4)=P("LIMIT")
+9 IF $GET(PSJORD)["V"!($GET(PSJORD)["P")
IF $GET(^PS(53.1,+ON,2.5))=""
NEW DUR
SET DUR=$$GETDUR^PSJLIVMD(DFN,+PSJORD,$SELECT((PSJORD["P"):"P",1:"IV"),1)
IF DUR]""
Begin DoDot:1
+10 IF $GET(IVLIMIT)
SET $PIECE(^PS(53.1,+ON,2.5),"^",4)=DUR
KILL IVLIMIT
QUIT
+11 SET $PIECE(^PS(53.1,+ON,2.5),"^",2)=DUR
End DoDot:1
+12 FOR X=0,2,4,8,9
SET ^PS(53.1,+ON,X)=ND(X)
+13 IF $GET(P("NUMLBL"))?1.N!($GET(P("NUMLBL"))="")
SET $PIECE(^PS(53.1,+ON,17),"^")=$GET(P("NUMLBL"))
+14 SET PSIVCAT=$$IVCAT^PSJHLU(DFN,ON,.P)
if PSIVCAT]""
SET $PIECE(^PS(53.1,+ON,2.5),"^",5)=PSIVCAT
KILL PSIVCAT
+15 if '+$GET(^PS(53.1,+ON,.2))
SET $PIECE(^(.2),U,1,3)=+P("PD")_U_P("DO")_U_$GET(P("NAT"))
+16 FOR DRGT="AD","SOL"
if $DATA(DRG(DRGT))
DO PTD531
+17 KILL DA,DIK
SET PSGS0Y=P(11)
SET PSGS0XT=P(15)
SET DA=+ON
SET DIK="^PS(53.1,"
DO IX^DIK
KILL DA,DIK,PSGS0Y,PSGS0XT,ND,^PS(53.1,"AS","P",DFN,+ON)
+18 if P(17)="A"
KILL ^PS(53.1,"AS","N",DFN,+ON)
+19 if P(15)="D"
SET $PIECE(^PS(53.1,+ON,2),U,6)="D"
+20 ;*399-IND
if $DATA(P("IND"))
SET ^PS(53.1,+ON,18)=P("IND")
+21 IF $GET(PSJINFIN)
KILL PSJINFIN
IF $DATA(^PS(53.45,+$GET(PSJSYSP),6))
IF '$DATA(^PS(53.1,+ON,"A"))
IF '$DATA(^PS(53.1,+ON,16))
SET PSJINFIN=2
+22 IF $GET(PSJSYSP)
Begin DoDot:1
+23 IF '$DATA(^PS(53.45,+PSJSYSP,6))
IF $GET(PSJORD)["V"!($GET(PSJORD)["P")
IF '$DATA(^PS(53.1,+ON,16))
NEW I
SET I=$$GETOPI^PSJBCMA5(DFN,PSJORD)
+24 IF $DATA(^PS(53.45,+PSJSYSP,6))
DO FILEOPI^PSJBCMA5(DFN,ON)
End DoDot:1
+25 QUIT
+26 ;
UPD100 ; Update order data in file 100
+1 if '$DATA(PSJIVORF)
DO ORPARM^PSIVOREN
if 'PSJIVORF
QUIT
+2 SET PSJORL=$$ENORL^PSJUTL($GET(VAIN(4)))
DO SET^PSIVORFE
+3 QUIT
+4 ;
PTD531 ; Move drug data from local array into 53.1
+1 KILL ^PS(53.1,+ON,DRGT)
SET ^PS(53.1,+ON,DRGT,0)=$SELECT(DRGT="AD":"^53.157^0^0",1:"^53.158^0^0")
+2 FOR X=0:0
SET X=$ORDER(DRG(DRGT,X))
if 'X
QUIT
Begin DoDot:1
+3 SET X1=$PIECE(DRG(DRGT,X),U)
SET Y=^PS(53.1,+ON,DRGT,0)
SET $PIECE(Y,U,3)=$PIECE(Y,U,3)+1
SET DRG=$PIECE(Y,U,3)
SET $PIECE(Y,U,4)=$PIECE(Y,U,4)+1
+4 SET ^PS(53.1,+ON,DRGT,0)=Y
SET Y=+X1_U_$PIECE(DRG(DRGT,X),U,3)
if DRGT="AD"
SET $PIECE(Y,U,3)=$PIECE(DRG(DRGT,X),U,4)
SET ^PS(53.1,+ON,DRGT,+DRG,0)=Y
End DoDot:1
+5 QUIT
