PSJH1 ;BIR/CML3,PR-GET UNIT DOSE/IV ORDERS FOR INPATIENT ; 11/15/07 4:21pm
;;5.0; INPATIENT MEDICATIONS ;**35,47,58,85,174,198**;16 DEC 97;Build 7
;
;Reference to ^PS(50.7 is supported by DBIA 2180
;Reference to ^PS(55 is supported by DBIA 2191
;Reference to ^%DTC is supported by DBIA 10000
;Reference to ^%ZOSV is supported by DBIA 10097
;Reference to ^XLFDT is supported by DBIA 10103
;
ECHK ;
S C="A",DRG=$P($G(^PS(55,PSGP,5,+O,.2)),"^") S:PSJOS START=-$P($G(^(2)),"^",2)
S O=O_"U"
G:SD>PSGDT SET S ND=$G(^PS(55,PSGP,5,+O,0)) G:$S($P(ND,"^",9)="":1,1:"DE"'[$P(ND,"^",9)) SET S ND4=$G(^(4)) I ST'="O",SD'<PSGODT,$S($P(ND,"^",9)="E":$P(ND4,"^",16),1:0)
E I ST="O",$P(ND,"^",9)="E",$S('$P(ND4,"^",UDU):1,SD<PSGODT:0,1:$P(ND4,"^",16))
E Q:PSJOL="S" S C="O"
;
SET ;
S DN=$S(DRG="":"NOT FOUND",'$D(^PS(50.7,DRG,0)):"NOT FOUND ("_DRG_")",$P(^(0),"^")]"":$P(^(0),"^"),1:DRG_";PS(50.7,"),NF=$P(DN,"^",9),SUB=$S(PSJOS:START,1:$E(DN,1,50))
S ^TMP("PSJ",$J,C,$S(PSJOS:SUB,1:ST),$S(PSJOS:ST,1:SUB),O)=DN_"^"_NF,PSJOCNT=PSJOCNT+1 Q
;
IVSET ; Set IV data in ^TMP("PSJ",$J,.
N DRG,DRGT,ON55,ORTX,P,STAT,TYP,X,Y,ND
;GMZ;PSJ*5*198;Change date search criteria for IV orders to be consistent with the way unit dose orders work
I ON["V" S ON55=ON,Y=$G(^PS(55,DFN,"IV",+ON,0)) Q:$D(PSJHDATE)&($P(Y,"^",3)<PSJHDATE) F X=2,3,4,9,17 S P(X)=$P(Y,U,X)
I ON'["V" S ND=$G(^PS(53.1,+ON,0)) I 'ND K ^PS(53.1,"AS",SD,PSGP,+ON) Q
I ON'["V",ND S P(17)=$P($G(^PS(53.1,+ON,0)),U,9),Y=$G(^PS(53.1,+ON,2)),P(9)=$P(Y,U),P(2)=$P(Y,U,2),P(3)=$P(Y,U,4),P(4)=$P($G(^PS(53.1,+ON,8)),U)
G:PSJOS IVSET1 I P(4)="H" S ORTX="* TPN *" G IVSET1
I P(4)="A" D @$S(ON["V":"GTDRG^PSIVORFB",1:"GTDRG^PSIVORFA"),GTOT^PSIVUTL(P(4)) I $E(P("OT"))="F" S DRGT=$O(DRG(0)),Y=$O(DRG(DRGT,0)),ORTX=$P(DRG(DRGT,Y),U,2) G IVSET1
S ORTX=$$ENPDN^PSGMI(+$S(ON["V":$G(^PS(55,DFN,"IV",+ON,6)),1:$G(^PS(53.1,+ON,.1))))
;
IVSET1 ;
S TYP=$$ONE^PSJBCMA(DFN,ON,P(9),P(2),P(3)) I TYP'="O" S TYP="C"
S STAT=$S("ED"[P(17):"O",P(17)="P":"NZ",1:"A"),^TMP("PSJ",$J,STAT,$S(PSJOS:-P(2),1:TYP),$S(PSJOS:TYP,1:ORTX),ON)="",PSJOCNT=PSJOCNT+1
Q
;
ENU ; update status field to reflect expired orders, if necessary
W !!,"...a few moments, I have some updating to do..."
ENUNM ;
F Q=+PSJPAD:0 S Q=$O(^PS(55,PSGP,5,"AUS",Q)) Q:'Q!(Q>PSGDT) S UPD=Q F QQ=0:0 S QQ=$O(^PS(55,PSGP,5,"AUS",Q,QQ)) Q:'QQ I $D(^PS(55,PSGP,5,QQ,0)),"DEH"'[$E($P(^(0),"^",9)) S $P(^(0),"^",9)="E"
K UPD Q
;
EN ; enter here
I PSJOL="L",$D(XRTL) D T0^%ZOSV
K ^TMP("PSJ",$J) D NOW^%DTC S PSGDT=+$E(%,1,12),DT=$$DT^XLFDT,PSJOS=$P(PSJSYSP0,"^",11),UDU=$S($P(PSJSYSU,";",3)>1:3,1:1) S:'$D(PSJHDATE) PSJHDATE=0
S PSJOCNT=0 F PSJORD=0:0 S PSJORD=$O(^PS(55,DFN,"IV",PSJORD)) Q:'PSJORD D
.S X=$G(^PS(55,DFN,"IV",+PSJORD,0))
.S Y=$P(X,U,17)
.S ON=+PSJORD_"V" D IVSET
D NOW^%DTC S PSJIVOF=PSJOCNT,PSGDT=%,X1=$P(%,"."),X2=-2 D C^%DTC S PSGODT=X_(PSGDT#1),HDT=$$ENDTC^PSGMI(PSGDT)
F ST="C","O","OC","P","R" F SD=+PSJHDATE:0 S SD=$O(^PS(55,PSGP,5,"AU",ST,SD)) Q:'SD F O=0:0 S O=$O(^PS(55,PSGP,5,"AU",ST,SD,O)) Q:'O D ECHK
Q:$D(PSGONNV)
F SD="I","N" S O=0 F S O=$O(^PS(53.1,"AS",SD,PSGP,O)) Q:'O D NVSET
;I $S(+PSJSYSU=3:1,1:$D(PSGLPF)) S SD="P",O=0 F S O=$O(^PS(53.1,"AS",SD,PSGP,O)) Q:'O S ON=O_"P" D @$S($P($G(^PS(53.1,O,0)),U,4)="F":"IVSET",1:"NVSET")
S SD="P",O=0 F S O=$O(^PS(53.1,"AS",SD,PSGP,O)) Q:'O S ON=O_"P" D @$S($P($G(^PS(53.1,O,0)),U,4)="F":"IVSET",1:"NVSET")
I PSJOL="L",$D(XRT0) S XRTN="PSJO1" D T1^%ZOSV
Q
;
NVSET ; Set up orders from 53.1.
N ND,OSAVE,PORD S ND=$G(^PS(53.1,O,0)) I 'ND D Q
.K ^PS(53.1,"AS",SD,PSGP,O)
S ST=$P($G(^PS(53.1,O,0)),U,7),START=-$P($G(^(2)),U,2),DRG=$P($G(^(.2)),U),C="N"_$TR(SD,"NIP","XYZ") S:ST="" ST="z"
S PORD=$P($G(^PS(53.1,O,.2)),U,8),OSAVE=O,O=$S(PORD:PORD,1:O_"P") D SET S O=+OSAVE
Q
;
KILL ;
K P,STAT,TYP,ORTX,N,JJ
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSJH1 3881 printed Sep 23, 2025@19:42:58 Page 2
PSJH1 ;BIR/CML3,PR-GET UNIT DOSE/IV ORDERS FOR INPATIENT ; 11/15/07 4:21pm
+1 ;;5.0; INPATIENT MEDICATIONS ;**35,47,58,85,174,198**;16 DEC 97;Build 7
+2 ;
+3 ;Reference to ^PS(50.7 is supported by DBIA 2180
+4 ;Reference to ^PS(55 is supported by DBIA 2191
+5 ;Reference to ^%DTC is supported by DBIA 10000
+6 ;Reference to ^%ZOSV is supported by DBIA 10097
+7 ;Reference to ^XLFDT is supported by DBIA 10103
+8 ;
ECHK ;
+1 SET C="A"
SET DRG=$PIECE($GET(^PS(55,PSGP,5,+O,.2)),"^")
if PSJOS
SET START=-$PIECE($GET(^(2)),"^",2)
+2 SET O=O_"U"
+3 if SD>PSGDT
GOTO SET
SET ND=$GET(^PS(55,PSGP,5,+O,0))
if $SELECT($PIECE(ND,"^",9)=""
GOTO SET
SET ND4=$GET(^(4))
IF ST'="O"
IF SD'<PSGODT
IF $SELECT($PIECE(ND,"^",9)="E":$PIECE(ND4,"^",16),1:0)
+4 IF '$TEST
IF ST="O"
IF $PIECE(ND,"^",9)="E"
IF $SELECT('$PIECE(ND4,"^",UDU):1,SD<PSGODT:0,1:$PIECE(ND4,"^",16))
+5 IF '$TEST
if PSJOL="S"
QUIT
SET C="O"
+6 ;
SET ;
+1 SET DN=$SELECT(DRG="":"NOT FOUND",'$DATA(^PS(50.7,DRG,0)):"NOT FOUND ("_DRG_")",$PIECE(^(0),"^")]"":$PIECE(^(0),"^"),1:DRG_";PS(50.7,")
SET NF=$PIECE(DN,"^",9)
SET SUB=$SELECT(PSJOS:START,1:$EXTRACT(DN,1,50))
+2 SET ^TMP("PSJ",$JOB,C,$SELECT(PSJOS:SUB,1:ST),$SELECT(PSJOS:ST,1:SUB),O)=DN_"^"_NF
SET PSJOCNT=PSJOCNT+1
QUIT
+3 ;
IVSET ; Set IV data in ^TMP("PSJ",$J,.
+1 NEW DRG,DRGT,ON55,ORTX,P,STAT,TYP,X,Y,ND
+2 ;GMZ;PSJ*5*198;Change date search criteria for IV orders to be consistent with the way unit dose orders work
+3 IF ON["V"
SET ON55=ON
SET Y=$GET(^PS(55,DFN,"IV",+ON,0))
if $DATA(PSJHDATE)&($PIECE(Y,"^",3)<PSJHDATE)
QUIT
FOR X=2,3,4,9,17
SET P(X)=$PIECE(Y,U,X)
+4 IF ON'["V"
SET ND=$GET(^PS(53.1,+ON,0))
IF 'ND
KILL ^PS(53.1,"AS",SD,PSGP,+ON)
QUIT
+5 IF ON'["V"
IF ND
SET P(17)=$PIECE($GET(^PS(53.1,+ON,0)),U,9)
SET Y=$GET(^PS(53.1,+ON,2))
SET P(9)=$PIECE(Y,U)
SET P(2)=$PIECE(Y,U,2)
SET P(3)=$PIECE(Y,U,4)
SET P(4)=$PIECE($GET(^PS(53.1,+ON,8)),U)
+6 if PSJOS
GOTO IVSET1
IF P(4)="H"
SET ORTX="* TPN *"
GOTO IVSET1
+7 IF P(4)="A"
DO @$SELECT(ON["V":"GTDRG^PSIVORFB",1:"GTDRG^PSIVORFA")
DO GTOT^PSIVUTL(P(4))
IF $EXTRACT(P("OT"))="F"
SET DRGT=$ORDER(DRG(0))
SET Y=$ORDER(DRG(DRGT,0))
SET ORTX=$PIECE(DRG(DRGT,Y),U,2)
GOTO IVSET1
+8 SET ORTX=$$ENPDN^PSGMI(+$SELECT(ON["V":$GET(^PS(55,DFN,"IV",+ON,6)),1:$GET(^PS(53.1,+ON,.1))))
+9 ;
IVSET1 ;
+1 SET TYP=$$ONE^PSJBCMA(DFN,ON,P(9),P(2),P(3))
IF TYP'="O"
SET TYP="C"
+2 SET STAT=$SELECT("ED"[P(17):"O",P(17)="P":"NZ",1:"A")
SET ^TMP("PSJ",$JOB,STAT,$SELECT(PSJOS:-P(2),1:TYP),$SELECT(PSJOS:TYP,1:ORTX),ON)=""
SET PSJOCNT=PSJOCNT+1
+3 QUIT
+4 ;
ENU ; update status field to reflect expired orders, if necessary
+1 WRITE !!,"...a few moments, I have some updating to do..."
ENUNM ;
+1 FOR Q=+PSJPAD:0
SET Q=$ORDER(^PS(55,PSGP,5,"AUS",Q))
if 'Q!(Q>PSGDT)
QUIT
SET UPD=Q
FOR QQ=0:0
SET QQ=$ORDER(^PS(55,PSGP,5,"AUS",Q,QQ))
if 'QQ
QUIT
IF $DATA(^PS(55,PSGP,5,QQ,0))
IF "DEH"'[$EXTRACT($PIECE(^(0),"^",9))
SET $PIECE(^(0),"^",9)="E"
+2 KILL UPD
QUIT
+3 ;
EN ; enter here
+1 IF PSJOL="L"
IF $DATA(XRTL)
DO T0^%ZOSV
+2 KILL ^TMP("PSJ",$JOB)
DO NOW^%DTC
SET PSGDT=+$EXTRACT(%,1,12)
SET DT=$$DT^XLFDT
SET PSJOS=$PIECE(PSJSYSP0,"^",11)
SET UDU=$SELECT($PIECE(PSJSYSU,";",3)>1:3,1:1)
if '$DATA(PSJHDATE)
SET PSJHDATE=0
+3 SET PSJOCNT=0
FOR PSJORD=0:0
SET PSJORD=$ORDER(^PS(55,DFN,"IV",PSJORD))
if 'PSJORD
QUIT
Begin DoDot:1
+4 SET X=$GET(^PS(55,DFN,"IV",+PSJORD,0))
+5 SET Y=$PIECE(X,U,17)
+6 SET ON=+PSJORD_"V"
DO IVSET
End DoDot:1
+7 DO NOW^%DTC
SET PSJIVOF=PSJOCNT
SET PSGDT=%
SET X1=$PIECE(%,".")
SET X2=-2
DO C^%DTC
SET PSGODT=X_(PSGDT#1)
SET HDT=$$ENDTC^PSGMI(PSGDT)
+8 FOR ST="C","O","OC","P","R"
FOR SD=+PSJHDATE:0
SET SD=$ORDER(^PS(55,PSGP,5,"AU",ST,SD))
if 'SD
QUIT
FOR O=0:0
SET O=$ORDER(^PS(55,PSGP,5,"AU",ST,SD,O))
if 'O
QUIT
DO ECHK
+9 if $DATA(PSGONNV)
QUIT
+10 FOR SD="I","N"
SET O=0
FOR
SET O=$ORDER(^PS(53.1,"AS",SD,PSGP,O))
if 'O
QUIT
DO NVSET
+11 ;I $S(+PSJSYSU=3:1,1:$D(PSGLPF)) S SD="P",O=0 F S O=$O(^PS(53.1,"AS",SD,PSGP,O)) Q:'O S ON=O_"P" D @$S($P($G(^PS(53.1,O,0)),U,4)="F":"IVSET",1:"NVSET")
+12 SET SD="P"
SET O=0
FOR
SET O=$ORDER(^PS(53.1,"AS",SD,PSGP,O))
if 'O
QUIT
SET ON=O_"P"
DO @$SELECT($PIECE($GET(^PS(53.1,O,0)),U,4)="F":"IVSET",1:"NVSET")
+13 IF PSJOL="L"
IF $DATA(XRT0)
SET XRTN="PSJO1"
DO T1^%ZOSV
+14 QUIT
+15 ;
NVSET ; Set up orders from 53.1.
+1 NEW ND,OSAVE,PORD
SET ND=$GET(^PS(53.1,O,0))
IF 'ND
Begin DoDot:1
+2 KILL ^PS(53.1,"AS",SD,PSGP,O)
End DoDot:1
QUIT
+3 SET ST=$PIECE($GET(^PS(53.1,O,0)),U,7)
SET START=-$PIECE($GET(^(2)),U,2)
SET DRG=$PIECE($GET(^(.2)),U)
SET C="N"_$TRANSLATE(SD,"NIP","XYZ")
if ST=""
SET ST="z"
+4 SET PORD=$PIECE($GET(^PS(53.1,O,.2)),U,8)
SET OSAVE=O
SET O=$SELECT(PORD:PORD,1:O_"P")
DO SET
SET O=+OSAVE
+5 QUIT
+6 ;
KILL ;
+1 KILL P,STAT,TYP,ORTX,N,JJ
+2 QUIT
