PSJHLV ;BIR/CML3-VERIFY (MAKE ACTIVE) ORDERS ;4/8/99 08:16
;;5.0;INPATIENT MEDICATIONS;**39,42,78,92,127,133,268,257**;16 DEC 97;Build 105
;
; Reference to ^PS(50.7 is supported by DBIA# 2180.
; Reference to ^PS(55 is supported by DBIA# 2191.
; Reference to ^PSDRUG is supported by DBIA# 2192.
; Reference to ^PSSLOCK is supported by DBIA# 2789.
;
EN(PSJHLDFN,PSGORD) ;
VFY ; change status, move to 55, and change label record
N PSJPWD,VAIP,DFN,PSGP,PSGORDP S (DFN,PSGP)=PSJHLDFN D IN5^VADPT S:VAIP(5)]"" PSJPWD=+VAIP(5) G:VAIP(5)']"" DONE
I $P($G(^PS(53.1,+PSGORD,0)),U,4)'="U" D IV Q
N PSJSYSP S PSJSYSP=+NURSEACK
N PSGDT D NOW^%DTC S PSGDT=%
S CHK=0 D DDCHK G:CHK DONE
D CHK($G(^PS(53.1,+PSGORD,0)),$G(^(.2)),$G(^(2)))
G:CHK DONE
S PSGORDP=PSGORD
;
N PSJRPND0 S PSJRPND0=^PS(53.1,+PSGORD,0) I $P(PSJRPND0,U,24)="R" D
.N PSGORDR,PSJPRIO,PSJSCHED,FILE55N0
.S PSGORDR=$P(PSJRPND0,U,25)
.Q:'$$LS^PSSLOCK(PSGP,PSGORDR)
.N OEORD,OOEORD,FILE55,FILE55N0,FILE55N2 S FILE55="^PS(55,"_PSJHLDFN_$S($P(PSJRPND0,U,4)="U":",5,",1:",""IV"","),FILE55N0=FILE55_+PSGORDR_",0)",FILE55N2=FILE55_+PSGORDR_",2)"
.S OEORD=$P(PSJRPND0,U,21) I PSGORDR S OOEORD=$P(@FILE55N0,"^",21) I OEORD'=OOEORD N PSGSD S PSGSD=$P(@FILE55N2,"^",2) D
..D EXPOE^PSGOER(PSJHLDFN,PSGORD,+$$LASTREN^PSJLMPRI(PSJHLDFN,PSGORD))
.K DA,DR,DIE S PSGORDP=PSGORD,DIE="^PS(53.1,",DA=+PSGORD,DR="28////A;104////@" W "." D ^DIE
.D START^PSGOTR(PSGORD,+PSGORDR) I OEORD D
..K DA,DR,DIE S DA(1)=PSJHLDFN,DA=+PSGORDR,DIE=FILE55,DR=$S(DIE["IV":110,1:66)_"////"_+OEORD D ^DIE S DIE=FILE55_+PSGORDR_",0)",$P(@DIE,U,21)=OEORD
..D EN1^PSJHL2(PSJHLDFN,"SC",PSGORDR),UNL^PSSLOCK(PSGP,PSGORDR)
..S PSGORD=PSGORDR
;
S DIE="^PS(53.1,",DA=+PSGORD,DR="28////A" D ^DIE I $P(PSJRPND0,U,24)'="R" D ^PSGOT
D CIMOU^PSJIMO1(PSJHLDFN,+PSGORD,"",PSGORDP)
S DA=+PSGORD,DA(1)=PSJHLDFN,PSGAL("C")=22010
D ^PSGAL5 S VND4=$G(^PS(55,PSJHLDFN,5,DA,4)) I $P(PSJRPND0,U,24)="R",$P(VND4,U,4) D
.K DA,DIE,DR I $P(VND4,U,4)<$$LASTREN^PSJLMPRI(PSJHLDFN,PSGORDP) S DIE="^PS(55,"_PSJHLDFN_",5,",DA(1)=PSJHLDFN,DA=+PSGORD,DR="18////@;19////@" D ^DIE
.S $P(VND4,U,3,4)=""
S $P(VND4,"^",10)=1
S:$P(VND4,"^",15)&'$P(VND4,"^",16) $P(VND4,"^",15)="" S:$P(VND4,"^",18)&'$P(VND4,"^",19) $P(VND4,"^",18)="" S:$P(VND4,"^",22)&'$P(VND4,"^",23) $P(VND4,"^",22)="" S $P(VND4,"^",1,2)=+NURSEACK_"^"_PSGDT,^PS(55,PSJHLDFN,5,+PSGORD,4)=VND4
I '$P(VND4,U,9) S ^PS(55,"APV",PSJHLDFN,+PSGORD)=""
I '$P(VND4,U,10) S ^PS(55,"ANV",PSJHLDFN,+PSGORD)=""
I $P(VND4,U,10) K ^PS(55,"ANV",PSJHLDFN,+PSGORD)
D:$D(PSGORDP) ACTLOG^PSGOEV(PSGORDP,PSJHLDFN,PSGORD)
D EN1^PSJHL2(PSJHLDFN,"SC",+PSGORD_"U")
; ** This is where the Automated Dispensing Machine hook is called. Do NOT DELETE or change this location **
D NEWJ^PSJADM
; ** END of Inferface Hook **
Q
;
IV ;
NEW DRG,DRGI,DRGN,DRGT,FIL,ON,ON55,P,PSJORD,VADM,VAIN
S ON=PSGORD,PSIVCHG=0,PSJSYSU=1
D INP^VADPT
D GT531^PSIVORFA(PSJHLDFN,PSGORD),ACTIVE^PSIVORC2
K PSIVCHG,PSJIVORF,PSJORF,PSJORIFN,PSJORL,PSJORNP,PSJPINIT,PSJSYSL,PSJSYSU,PSJSYSW,PSJSYSW0
Q
DONE ;
K CHK,DA,DIE,DRGF,DP,DR,ND,PSGAL,PSGODA,PSGPD,VND4 Q
;
CHK(ND,DRG,ND2) ; checks for data in required fields
; Input: ND - ^(PS(53.1,PSGORD,0)
; DRG - ^(.2)
; ND2 - ^(2)
S CHK="" I DRG,$D(^PS(50.7,+DRG,0))
E S CHK=1
I ND="" S CHK=CHK_23
E S CHK=CHK_$S($P(ND,"^",3):"",1:2)_$S($P(ND,"^",7)]"":"",1:3)
;The naked reference on the line below refers to the variable ND
;which is ^PS(53.1,PSGORD,0).
I ND2="" S CHK=CHK_$S('$D(^(0)):4,$P(^(0),"^",7)="OC":"",1:4)_56
E S CHK=CHK_$S($P(ND2,"^")]"":"",ND="":4,$P(ND,"^",7)="OC":"",1:4)_$S($P(ND2,"^",2):"",1:5)_$S($P(ND2,"^",4):"",1:6)
I $$CHECK^PSGOE8(PSJSYSP),$P(DRG,U,2)="" S CHK=CHK_8
K PSGDFLG,PSGPFLG S PSGDI=0
S:'$$OIOK^PSGOE2(+DRG) PSGPFLG=1
Q
;
DDCHK ; dispense drug check
S DRGF="^PS("_$S(PSGORD["P":"53.1,"_+PSGORD,1:"55,"_PSJHLDFN_",5,"_+PSGORD)_",",CHK=$S('$O(@(DRGF_"1,0)")):7,1:0)
S PSGPD=$G(@(DRGF_".2)"))
S CHK=$S('$$DDOK(DRGF_"1,",PSGPD):7,1:0)
Q
;
DDOK(PSJF,OI) ;Check to be sure all dispense drugs that are active in the
;order are valid.
; Input: PSJF - File root of the order including all but the IEN of
; the drug. (EX "^PS(53.1,X,1,")
; OI - IEN of the order's orderable item
; Output: 1 - all active DD's in the order are valid
; 0 - no DD's active DD's or at least one active is invalid
N DDCNT,ND,PSJ,X S (X,DDCNT)=0
I '$O(@(PSJF_"0)")) Q 1
F PSJ=0:0 S PSJ=$O(@(PSJF_PSJ_")")) Q:'PSJ!X S ND=$G(@(PSJF_PSJ_",0)")) D
.I $P(ND,U,3),($P(ND,U,3)'>PSGDT) Q
.S DDCNT=DDCNT+1
.S X=$S('$D(^PSDRUG(+ND,0)):1,$P($G(^(2)),U,3)'["U":1,+$G(^(2))'=+OI:1,$G(^("I"))="":0,1:^("I")'>PSGDT)
Q $S('DDCNT:0,X=1:0,1:1)
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSJHLV 4815 printed Sep 23, 2025@19:43:13 Page 2
PSJHLV ;BIR/CML3-VERIFY (MAKE ACTIVE) ORDERS ;4/8/99 08:16
+1 ;;5.0;INPATIENT MEDICATIONS;**39,42,78,92,127,133,268,257**;16 DEC 97;Build 105
+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 ^PSDRUG is supported by DBIA# 2192.
+6 ; Reference to ^PSSLOCK is supported by DBIA# 2789.
+7 ;
EN(PSJHLDFN,PSGORD) ;
VFY ; change status, move to 55, and change label record
+1 NEW PSJPWD,VAIP,DFN,PSGP,PSGORDP
SET (DFN,PSGP)=PSJHLDFN
DO IN5^VADPT
if VAIP(5)]""
SET PSJPWD=+VAIP(5)
if VAIP(5)']""
GOTO DONE
+2 IF $PIECE($GET(^PS(53.1,+PSGORD,0)),U,4)'="U"
DO IV
QUIT
+3 NEW PSJSYSP
SET PSJSYSP=+NURSEACK
+4 NEW PSGDT
DO NOW^%DTC
SET PSGDT=%
+5 SET CHK=0
DO DDCHK
if CHK
GOTO DONE
+6 DO CHK($GET(^PS(53.1,+PSGORD,0)),$GET(^(.2)),$GET(^(2)))
+7 if CHK
GOTO DONE
+8 SET PSGORDP=PSGORD
+9 ;
+10 NEW PSJRPND0
SET PSJRPND0=^PS(53.1,+PSGORD,0)
IF $PIECE(PSJRPND0,U,24)="R"
Begin DoDot:1
+11 NEW PSGORDR,PSJPRIO,PSJSCHED,FILE55N0
+12 SET PSGORDR=$PIECE(PSJRPND0,U,25)
+13 if '$$LS^PSSLOCK(PSGP,PSGORDR)
QUIT
+14 NEW OEORD,OOEORD,FILE55,FILE55N0,FILE55N2
SET FILE55="^PS(55,"_PSJHLDFN_$SELECT($PIECE(PSJRPND0,U,4)="U":",5,",1:",""IV"",")
SET FILE55N0=FILE55_+PSGORDR_",0)"
SET FILE55N2=FILE55_+PSGORDR_",2)"
+15 SET OEORD=$PIECE(PSJRPND0,U,21)
IF PSGORDR
SET OOEORD=$PIECE(@FILE55N0,"^",21)
IF OEORD'=OOEORD
NEW PSGSD
SET PSGSD=$PIECE(@FILE55N2,"^",2)
Begin DoDot:2
+16 DO EXPOE^PSGOER(PSJHLDFN,PSGORD,+$$LASTREN^PSJLMPRI(PSJHLDFN,PSGORD))
End DoDot:2
+17 KILL DA,DR,DIE
SET PSGORDP=PSGORD
SET DIE="^PS(53.1,"
SET DA=+PSGORD
SET DR="28////A;104////@"
WRITE "."
DO ^DIE
+18 DO START^PSGOTR(PSGORD,+PSGORDR)
IF OEORD
Begin DoDot:2
+19 KILL DA,DR,DIE
SET DA(1)=PSJHLDFN
SET DA=+PSGORDR
SET DIE=FILE55
SET DR=$SELECT(DIE["IV":110,1:66)_"////"_+OEORD
DO ^DIE
SET DIE=FILE55_+PSGORDR_",0)"
SET $PIECE(@DIE,U,21)=OEORD
+20 DO EN1^PSJHL2(PSJHLDFN,"SC",PSGORDR)
DO UNL^PSSLOCK(PSGP,PSGORDR)
+21 SET PSGORD=PSGORDR
End DoDot:2
End DoDot:1
+22 ;
+23 SET DIE="^PS(53.1,"
SET DA=+PSGORD
SET DR="28////A"
DO ^DIE
IF $PIECE(PSJRPND0,U,24)'="R"
DO ^PSGOT
+24 DO CIMOU^PSJIMO1(PSJHLDFN,+PSGORD,"",PSGORDP)
+25 SET DA=+PSGORD
SET DA(1)=PSJHLDFN
SET PSGAL("C")=22010
+26 DO ^PSGAL5
SET VND4=$GET(^PS(55,PSJHLDFN,5,DA,4))
IF $PIECE(PSJRPND0,U,24)="R"
IF $PIECE(VND4,U,4)
Begin DoDot:1
+27 KILL DA,DIE,DR
IF $PIECE(VND4,U,4)<$$LASTREN^PSJLMPRI(PSJHLDFN,PSGORDP)
SET DIE="^PS(55,"_PSJHLDFN_",5,"
SET DA(1)=PSJHLDFN
SET DA=+PSGORD
SET DR="18////@;19////@"
DO ^DIE
+28 SET $PIECE(VND4,U,3,4)=""
End DoDot:1
+29 SET $PIECE(VND4,"^",10)=1
+30 if $PIECE(VND4,"^",15)&'$PIECE(VND4,"^",16)
SET $PIECE(VND4,"^",15)=""
if $PIECE(VND4,"^",18)&'$PIECE(VND4,"^",19)
SET $PIECE(VND4,"^",18)=""
if $PIECE(VND4,"^",22)&'$PIECE(VND4,"^",23)
SET $PIECE(VND4,"^",22)=""
SET $PIECE(VND4,"^",1,2)=+NURSEACK_"^"_PSGDT
SET ^PS(55,PSJHLDFN,5,+PSGORD,4)=VND4
+31 IF '$PIECE(VND4,U,9)
SET ^PS(55,"APV",PSJHLDFN,+PSGORD)=""
+32 IF '$PIECE(VND4,U,10)
SET ^PS(55,"ANV",PSJHLDFN,+PSGORD)=""
+33 IF $PIECE(VND4,U,10)
KILL ^PS(55,"ANV",PSJHLDFN,+PSGORD)
+34 if $DATA(PSGORDP)
DO ACTLOG^PSGOEV(PSGORDP,PSJHLDFN,PSGORD)
+35 DO EN1^PSJHL2(PSJHLDFN,"SC",+PSGORD_"U")
+36 ; ** This is where the Automated Dispensing Machine hook is called. Do NOT DELETE or change this location **
+37 DO NEWJ^PSJADM
+38 ; ** END of Inferface Hook **
+39 QUIT
+40 ;
IV ;
+1 NEW DRG,DRGI,DRGN,DRGT,FIL,ON,ON55,P,PSJORD,VADM,VAIN
+2 SET ON=PSGORD
SET PSIVCHG=0
SET PSJSYSU=1
+3 DO INP^VADPT
+4 DO GT531^PSIVORFA(PSJHLDFN,PSGORD)
DO ACTIVE^PSIVORC2
+5 KILL PSIVCHG,PSJIVORF,PSJORF,PSJORIFN,PSJORL,PSJORNP,PSJPINIT,PSJSYSL,PSJSYSU,PSJSYSW,PSJSYSW0
+6 QUIT
DONE ;
+1 KILL CHK,DA,DIE,DRGF,DP,DR,ND,PSGAL,PSGODA,PSGPD,VND4
QUIT
+2 ;
CHK(ND,DRG,ND2) ; checks for data in required fields
+1 ; Input: ND - ^(PS(53.1,PSGORD,0)
+2 ; DRG - ^(.2)
+3 ; ND2 - ^(2)
+4 SET CHK=""
IF DRG
IF $DATA(^PS(50.7,+DRG,0))
+5 IF '$TEST
SET CHK=1
+6 IF ND=""
SET CHK=CHK_23
+7 IF '$TEST
SET CHK=CHK_$SELECT($PIECE(ND,"^",3):"",1:2)_$SELECT($PIECE(ND,"^",7)]"":"",1:3)
+8 ;The naked reference on the line below refers to the variable ND
+9 ;which is ^PS(53.1,PSGORD,0).
+10 IF ND2=""
SET CHK=CHK_$SELECT('$DATA(^(0)):4,$PIECE(^(0),"^",7)="OC":"",1:4)_56
+11 IF '$TEST
SET CHK=CHK_$SELECT($PIECE(ND2,"^")]"":"",ND="":4,$PIECE(ND,"^",7)="OC":"",1:4)_$SELECT($PIECE(ND2,"^",2):"",1:5)_$SELECT($PIECE(ND2,"^",4):"",1:6)
+12 IF $$CHECK^PSGOE8(PSJSYSP)
IF $PIECE(DRG,U,2)=""
SET CHK=CHK_8
+13 KILL PSGDFLG,PSGPFLG
SET PSGDI=0
+14 if '$$OIOK^PSGOE2(+DRG)
SET PSGPFLG=1
+15 QUIT
+16 ;
DDCHK ; dispense drug check
+1 SET DRGF="^PS("_$SELECT(PSGORD["P":"53.1,"_+PSGORD,1:"55,"_PSJHLDFN_",5,"_+PSGORD)_","
SET CHK=$SELECT('$ORDER(@(DRGF_"1,0)")):7,1:0)
+2 SET PSGPD=$GET(@(DRGF_".2)"))
+3 SET CHK=$SELECT('$$DDOK(DRGF_"1,",PSGPD):7,1:0)
+4 QUIT
+5 ;
DDOK(PSJF,OI) ;Check to be sure all dispense drugs that are active in the
+1 ;order are valid.
+2 ; Input: PSJF - File root of the order including all but the IEN of
+3 ; the drug. (EX "^PS(53.1,X,1,")
+4 ; OI - IEN of the order's orderable item
+5 ; Output: 1 - all active DD's in the order are valid
+6 ; 0 - no DD's active DD's or at least one active is invalid
+7 NEW DDCNT,ND,PSJ,X
SET (X,DDCNT)=0
+8 IF '$ORDER(@(PSJF_"0)"))
QUIT 1
+9 FOR PSJ=0:0
SET PSJ=$ORDER(@(PSJF_PSJ_")"))
if 'PSJ!X
QUIT
SET ND=$GET(@(PSJF_PSJ_",0)"))
Begin DoDot:1
+10 IF $PIECE(ND,U,3)
IF ($PIECE(ND,U,3)'>PSGDT)
QUIT
+11 SET DDCNT=DDCNT+1
+12 SET X=$SELECT('$DATA(^PSDRUG(+ND,0)):1,$PIECE($GET(^(2)),U,3)'["U":1,+$GET(^(2))'=+OI:1,$GET(^("I"))="":0,1:^("I")'>PSGDT)
End DoDot:1
+13 QUIT $SELECT('DDCNT:0,X=1:0,1:1)
+14 ;
