PSGOEV ;BIR/CML3-VERIFY (MAKE ACTIVE) ORDERS ;29-May-2012 14:31;PLS
;;5.0; INPATIENT MEDICATIONS ;**5,7,15,28,33,50,64,58,77,78,80,1004,110,111,133,171,207,1015**;16 DEC 97;Build 62
;
; Reference to ^ORD(101 supported by DBIA #872.
; Reference to ^PS(50.7 supported by DBIA #2180.
; Reference to ^PS(55 supported by DBIA #2191.
; Reference to ^PSSLOCK supported by DBIA #2789.
; Reference to MAIN^TIUEDIT is supported by DBIA #2410.
;
; Modified - IHS/CIA/PLS - 10/14/05 - Line VFY+39
; 03/08/06 - VFY+17
;
EN(PSGORD) ;
ENSF ; This entry point is used by Speed finish only.
; Send SN update to CPRS if auto-verify off and from Order Set entry
S:'$D(PSGOEAV) PSGOEAV=$P($G(PSJSYSP0),"^",9)&$G(PSJSYSU)
I $D(PSGOES),'PSGOEAV,PSGORD["P",$P($G(^PS(53.1,+PSGORD,0)),"^",21)']"" D ORSET^PSGOETO1
D FULL^VALM1 I 'PSJSYSU W $C(7),$C(7),!!," THIS FUNCTION NOT AVAILABLE TO WARD STAFF." Q
S CHK=0 I PSGORD["P" S X=$P($G(^PS(53.1,+PSGORD,0)),"^",19) I X,$D(^PS(55,PSGP,5,$P(^(0),"^",19))) S CHK=+PSGORD,PSGORD=X_"U" L -^PS(53.1,CHK) L +^PS(55,PSGP,5,+PSGORD):1 E W !!,"Another terminal is editing this order." G DONE
I +PSJSYSU=3 D DDCHK G:CHK DONE
I PSGORD["P" D CHK($G(^PS(53.1,+PSGORD,0)),$G(^(.2)),$G(^(2)))
I $G(PSGSCH)]"" D
.N X,Y,PSGS0Y,PSGS0XT,PSGOES S PSGOES=1 S X=PSGSCH D ENOS^PSGS0 I $G(X)="" S CHK=4
I $G(CHK) Q:$D(PSJSPEED) D EN^VALM("PSJU LM ACCEPT") G:'$G(PSJACEPT) DONE ;G VFY
I PSGORD["U" G:'$D(^PS(55,PSGP,5,+PSGORD,4)) VFY I +PSJSYSU=3,$P(^(4),"^",3) W $C(7),!!,"THIS ORDER HAS ALREADY BEEN VERIFIED BY A PHARMACIST." S PSGACT=$P(PSGACT,"V")_$P(PSGACT,"V",2) G DONE
I PSGORD["U" I +PSJSYSU=1,+^PS(55,PSGP,5,+PSGORD,4) W $C(7),!!,"THIS ORDER HAS ALREADY BEEN VERIFIED BY A NURSE." S PSGACT=$P(PSGACT,"V")_$P(PSGACT,"V",2) G DONE
;
VFY ; change status, move to 55, and change label record
I PSGORD["P" S PSJCOM=+$P($G(^PS(53.1,+PSGORD,.2)),"^",8) I PSJCOM D VFY^PSJCOM Q
NEW PSJDOSE,PSJDSFLG
D DOSECHK^PSJDOSE
I +$G(PSJDSFLG) D SETVAR^PSJDOSE W !!,PSJDOSE("WARN"),!,PSJDOSE("WARN1") I '$$CONT() W !,"...order was not verified..." D PAUSE^VALM1 D Q:'$G(PSJACEPT)
. S PSGOEEF(109)=1
. S PSJACEPT=0
. ;D EN^VALM("PSJU LM ACCEPT")
D DDCHK G:CHK DONE
I $G(PSGSCH)]"",((",P,R,")'[(","_PSGST_",")) D I CHK G DONE
.N SWD,SDW,XABB,X,QX S X=$G(PSGSCH) D DW^PSGS0 Q:($G(X)="") I $G(PSGS0XT)="" S PSGS0XT="D"
.I $G(PSGS0XT)="D",$G(PSGAT)="" S CHK=1 W !!,"This is a 'DAY OF WEEK' schedule and MUST have admin times.",! D PAUSE^VALM1
I $G(PSGSCH)]"" D I CHK G DONE
.N X,Y,PSGS0XT,PSGS0Y,PSGOES S PSGOES=2,X=PSGSCH D ENOS^PSGS0 I $G(X)="" S CHK=4
W !,"...a few moments, please..."
I PSGORD["P" D
. N PND0,PSGORDR,PSJPRIO,PSJSCHED S PND0=^PS(53.1,+PSGORD,0) I $P(PND0,U,24)="R" S PSGORDR=$P(PND0,U,25) D Q
.. N OEORD,OOEORD,FILE55,FILE55N0 S FILE55="^PS(55,"_DFN_$S($P(PND0,U,4)="U":",5,",1:",""IV"","),FILE55N0=FILE55_+PSGORDR_",0)"
.. S OEORD=$P(PND0,U,21) I PSGORDR S OOEORD=$P(@FILE55N0,"^",21) I OEORD'=OOEORD D EXPOE^PSGOER(DFN,PSGORD,+$$LASTREN^PSJLMPRI(DFN,PSGORD))
.. 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)=DFN,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(DFN,"SC",PSGORDR),EN^PSGPEN(PSGORDR),UNL^PSSLOCK(PSGP,PSGORDR)
. S PSGORDP=PSGORD ;Used in ACTLOG to update activity log in 55
. D REQDT^PSJLIVMD(PSGORD)
. S DIE="^PS(53.1,",DA=+PSGORD,DR="28////A" W "." D ^DIE,^PSGOT
. S PSJPRIO=$S(PSGORD["P":$P($G(^PS(53.1,+PSGORD,.2)),"^",4),PSGORD["U":$P($G(^PS(55,DFN,5,+PSGORD,.2)),"^",4),1:$P($G(^PS(55,PSJHLDFN,"IV",+PSGORD,.2)),"^",4))
. S PSJSCHED=$S(PSGORD["P":$P($G(^PS(53.1,+PSGORD,2)),"^"),PSGORD["U":$P($G(^PS(55,DFN,5,+PSGORD,2)),"^"),1:$P($G(^PS(55,PSJHLDFN,"IV",+PSGORD,0)),"^",15))
. I (",S,A,")[(","_$G(PSJPRIO)_",")!($G(PSJSCHED)="NOW")!($G(PSJSCHED)["STAT") D NOTIFY^PSJHL4(PSGORD,DFN,$G(PSJPRIO),$G(PSJSCHED))
. I $G(PSGRDTX)="" S PSGRDTX=$G(^PS(53.1,+PSGORDP,2.5))
S DA=+PSGORD,DA(1)=PSGP,PSGAL("C")=PSJSYSU*10+22000 D ^PSGAL5 W "." S VND4=$G(^PS(55,PSGP,5,DA,4))
D:$$PATCH^XPDUTL("BOP*1.0*1") ^BOPSD ;IHS/CIA/PLS -03/08/2006 - ADS SUPPORT
I $G(PSGRDTX) D NEWUDAL^PSGAL5(PSGP,PSGORD,6090,"Requested Start Date",+$G(PSGRDTX))
I $P($G(PSGRDTX),U,3) D NEWUDAL^PSGAL5(PSGP,PSGORD,6090,"Requested Stop Date",+$P($G(PSGRDTX),U,3))
N DUR,DURON S DURON=$S($G(PSGORD):$G(PSGORD),1:"") I DURON D
. S DUR=$S($P($G(PSGRDTX),U,2)]"":$P($G(PSGRDTX),U,2),1:$$GETDUR^PSJLIVMD(PSGP,+DURON,$S($G(DURON)["P":"P",1:5),1),1:"")
I $G(DUR)]"" S $P(^PS(55,PSGP,5,+PSGORD,2.5),"^",2)=DUR
D:$D(PSGORDP) ACTLOG(PSGORDP,PSGP,PSGORD)
K PSGRSD,PSGRFD,PSGALFN
NEW X S X=0 I $G(PSGONF),(+$G(PSGODDD(1))'<+$G(PSGONF)) S X=1
I +PSJSYSU=3,PSGORD'["O",$S(X:0,'$P(VND4,"^",9):1,1:$P(VND4,"^",15)) D EN^PSGPEN(+PSGORD)
S $P(VND4,"^",+PSJSYSU=1+9)=1 S:'$P(VND4,U,+PSJSYSU=3+9) $P(VND4,U,+PSJSYSU=3+9)=+$P(VND4,U,+PSJSYSU=3+9)
;S $P(VND4,"^",+PSJSYSU=1+9)=1,$P(VND4,U,+PSJSYSU=3+9)=0
I PSJSYSL>1 S $P(^PS(55,PSGP,5,+PSGORD,7),U)=PSGDT S:$P(^(7),U,2)="" $P(^(7),U,2)="N"_$S($P(^PS(55,PSGP,5,+PSGORD,0),"^",24)="E":"E",1:"") S PSGTOL=2,PSGUOW=DUZ,PSGTOO=1,DA=+PSGORD D ENL^PSGVDS
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,"^",PSJSYSU,PSJSYSU+1)=DUZ_"^"_PSGDT,^PS(55,PSGP,5,+PSGORD,4)=VND4
I '$P(VND4,U,9) S ^PS(55,"APV",PSGP,+PSGORD)=""
I '$P(VND4,U,10) S ^PS(55,"ANV",PSGP,+PSGORD)=""
I $P(VND4,U,9) K ^PS(55,"APV",PSGP,+PSGORD)
I $P(VND4,U,10) K ^PS(55,"ANV",PSGP,+PSGORD)
W:'$D(PSJSPEED) ! W !,"ORDER VERIFIED.",!
I '$D(PSJSPEED) K DIR S DIR(0)="E" D ^DIR K DIR
S:+PSJSYSU=3 ^PS(55,"AUE",PSGP,+PSGORD)="" S PSGACT="C"_$S('$D(^PS(55,PSGP,5,+PSGORD,4)):"E",$P(^(4),"^",16):"",1:"E")_"RS",PSGCANFL=2
S VALMBCK="Q" D EN1^PSJHL2(PSGP,$S(+PSJSYSU=3:"SC",+PSJSYSU=1:"SC",1:"XX"),+PSGORD_"U") ; allow status change to be sent for pharmacists & nurses
D CALLBOP ;IHS/CIA/PLS - 10/14/05 - Call to Automated Dispensing System
D:+PSJSYSU=1 EN1^PSJHL2(PSGP,"ZV",+PSGORD_"U")
DONE ;
W:CHK !!,"...order NOT verified..."
I '$D(PSJSPEED),'CHK,+PSJSYSU=3,$G(PSJPRI)="D" D
.N DIR W ! S DIR(0)="S^Y:Yes;N:No",DIR("A")="Do you want to enter a Progress Note",DIR("B")="No" D ^DIR
.Q:Y="N"
.D MAIN^TIUEDIT(3,.TIUDA,PSGP,"","","","",1)
S VALMBCK="Q" K CHK,DA,DIE,F,DP,DR,ND,PSGAL,PSGODA,PSJDOSE,PSJVAR,VND4,X Q
;
LBL ;
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:'$$DDOK^PSGOE2("^PS(53.45,"_PSJSYSP_",2,",+DRG) CHK=CHK_7,(PSGDFLG,PSGDI)=1
S:'$$OIOK^PSGOE2(+DRG) PSGPFLG=1
I 'CHK,$G(PSGSCH)]"" D
.N X,Y,PSGS0Y,PSGS0XT,PSGOES S PSGOES=2,X=PSGSCH D ENOS^PSGS0 I $G(X)="" S CHK=4
Q:'CHK
W $C(7)
;
CHKM ;
D FULL^VALM1
; changed to remove ^DD ref
W !!,"THE FOLLOWING ",$S($L(CHK)>1:"ARE",1:"IS")," EITHER INVALID OR MISSING FROM THIS ORDER:" F X=1:1:7 W:CHK[X !?5,$P("ORDERABLE ITEM^MED ROUTE^SCHEDULE TYPE^SCHEDULE^START DATE/TIME^STOP DATE/TIME^DISPENSE DRUG","^",X)
I CHK=7 W !,"Orders with no dispense drugs or multiple dispense drugs",!,"require dosage ordered"
W:CHK]"" !!,$S($L(CHK)>1:"THESE FIELDS ARE",1:"THIS FIELD IS")," NECESSARY FOR VERIFICATION."
N DIR S DIR(0)="E" D ^DIR I $D(DUOUT)!$D(DTOUT) S CHK=1 Q
Q
;
CONT() ;
NEW DIR,DIRUT,Y
W ! K DIR,DIRUT
S DIR(0)="Y",DIR("A")="Would you like to continue verifying the order",DIR("B")="Yes"
D ^DIR
Q Y
;
DDCHK ; dispense drug check
S DRGF="^PS("_$S(PSGORD["P":"53.1,"_+PSGORD,1:"55,"_PSGP_",5,"_+PSGORD)_",",CHK=$S('$O(@(DRGF_"1,0)")):7,1:0)
S PSGPD=$G(@(DRGF_".2)"))
S CHK=$S('$$DDOK^PSGOE2(DRGF_"1,",PSGPD):7,1:0)
Q:CHK=0
W $C(7),!!,"This order must have at least one valid, active dispense drug to be verified."
;
DDEDIT ;
;*** Remove all dispense drug for this order
K @(DRGF_"1)")
; The naked reference below refers to the indirect full reference in DRGF_"1,"_Q_")", which is either ^PS(53.1,+PSGORD,Q) or ^PS(55,DFN,5,+PSGORD,Q)
K ^PS(53.45,PSJSYSP,2) S (X,Q)=0 F S Q=$O(@(DRGF_"1,"_Q_")")) Q:'Q S Y=$G(^(Q,0)),X=Q S ^PS(53.45,PSJSYSP,2,Q,0)=Y I Y S ^PS(53.45,PSJSYSP,2,"B",+Y,Q)=""
I X S ^PS(53.45,PSJSYSP,2,0)="^53.4502P^"_X_"^"_X
D ENDRG^PSGOEF1(PSGPD,X)
I 'CHK S %X="^PS(53.45,"_PSJSYSP_",2,",%Y=DRGF_"1," D %XY^%RCR S $P(@(DRGF_"1,0)"),"^",2)=$S(DRGF[53.1:"53.11P",1:"55.07P")
K DRG,DRGF Q
;
AESCREEN() ;
; Output: 0 - Required fields missing and DON'T allow accept
; 1 - Required fields found.
Q:'$G(CHK) 1
S Y=$P($G(^ORD(101,+$G(^ORD(101,DA(1),10,DA,0)),0)),U) I Y="" Q 0
I Y="PSJU LM ACCEPT EDIT" Q 1
Q 0
ACTLOG(PSGORDP,DFN,PSGORD) ;Store 53.1 activity log in local array to be moved to 55
;PSGORDP: IEN from 53.1
;PSGORD : IEN from 55
NEW PSGX,PSGXDA,PSGAL531,Q,QQ
F PSGX=0:0 S PSGX=$O(^PS(53.1,+PSGORDP,"A",PSGX)) Q:'PSGX D
. S PSGAL531=$G(^PS(53.1,+PSGORDP,"A",PSGX,0))
. S QQ=$G(^PS(55,DFN,5,+PSGORD,9,0)) S:QQ="" QQ="^55.09D" F Q=$P(QQ,U,3)+1:1 I '$D(^(Q)) S $P(QQ,U,3,4)=Q_U_Q,^(0)=QQ,PSGXDA=Q Q
. S ^PS(55,DFN,5,+PSGORD,9,PSGXDA,0)=PSGAL531
Q
; Call Automated Dispensing System if present
CALLBOP ;
D:$$PATCH^XPDUTL("BOP*1.0*1") NEW^BOPCAP
Q
PSGOEV ;BIR/CML3-VERIFY (MAKE ACTIVE) ORDERS ;29-May-2012 14:31;PLS
+1 ;;5.0; INPATIENT MEDICATIONS ;**5,7,15,28,33,50,64,58,77,78,80,1004,110,111,133,171,207,1015**;16 DEC 97;Build 62
+2 ;
+3 ; Reference to ^ORD(101 supported by DBIA #872.
+4 ; Reference to ^PS(50.7 supported by DBIA #2180.
+5 ; Reference to ^PS(55 supported by DBIA #2191.
+6 ; Reference to ^PSSLOCK supported by DBIA #2789.
+7 ; Reference to MAIN^TIUEDIT is supported by DBIA #2410.
+8 ;
+9 ; Modified - IHS/CIA/PLS - 10/14/05 - Line VFY+39
+10 ; 03/08/06 - VFY+17
+11 ;
EN(PSGORD) ;
ENSF ; This entry point is used by Speed finish only.
+1 ; Send SN update to CPRS if auto-verify off and from Order Set entry
+2 IF '$DATA(PSGOEAV)
SET PSGOEAV=$PIECE($GET(PSJSYSP0),"^",9)&$GET(PSJSYSU)
+3 IF $DATA(PSGOES)
IF 'PSGOEAV
IF PSGORD["P"
IF $PIECE($GET(^PS(53.1,+PSGORD,0)),"^",21)']""
DO ORSET^PSGOETO1
+4 DO FULL^VALM1
IF 'PSJSYSU
WRITE $CHAR(7),$CHAR(7),!!," THIS FUNCTION NOT AVAILABLE TO WARD STAFF."
QUIT
+5 SET CHK=0
IF PSGORD["P"
SET X=$PIECE($GET(^PS(53.1,+PSGORD,0)),"^",19)
IF X
IF $DATA(^PS(55,PSGP,5,$PIECE(^(0),"^",19)))
SET CHK=+PSGORD
SET PSGORD=X_"U"
LOCK -^PS(53.1,CHK)
LOCK +^PS(55,PSGP,5,+PSGORD):1
IF '$TEST
WRITE !!,"Another terminal is editing this order."
GOTO DONE
+6 IF +PSJSYSU=3
DO DDCHK
IF CHK
GOTO DONE
+7 IF PSGORD["P"
DO CHK($GET(^PS(53.1,+PSGORD,0)),$GET(^(.2)),$GET(^(2)))
+8 IF $GET(PSGSCH)]""
Begin DoDot:1
+9 NEW X,Y,PSGS0Y,PSGS0XT,PSGOES
SET PSGOES=1
SET X=PSGSCH
DO ENOS^PSGS0
IF $GET(X)=""
SET CHK=4
End DoDot:1
+10 ;G VFY
IF $GET(CHK)
IF $DATA(PSJSPEED)
QUIT
DO EN^VALM("PSJU LM ACCEPT")
IF '$GET(PSJACEPT)
GOTO DONE
+11 IF PSGORD["U"
IF '$DATA(^PS(55,PSGP,5,+PSGORD,4))
GOTO VFY
IF +PSJSYSU=3
IF $PIECE(^(4),"^",3)
WRITE $CHAR(7),!!,"THIS ORDER HAS ALREADY BEEN VERIFIED BY A PHARMACIST."
SET PSGACT=$PIECE(PSGACT,"V")_$PIECE(PSGACT,"V",2)
GOTO DONE
+12 IF PSGORD["U"
IF +PSJSYSU=1
IF +^PS(55,PSGP,5,+PSGORD,4)
WRITE $CHAR(7),!!,"THIS ORDER HAS ALREADY BEEN VERIFIED BY A NURSE."
SET PSGACT=$PIECE(PSGACT,"V")_$PIECE(PSGACT,"V",2)
GOTO DONE
+13 ;
VFY ; change status, move to 55, and change label record
+1 IF PSGORD["P"
SET PSJCOM=+$PIECE($GET(^PS(53.1,+PSGORD,.2)),"^",8)
IF PSJCOM
DO VFY^PSJCOM
QUIT
+2 NEW PSJDOSE,PSJDSFLG
+3 DO DOSECHK^PSJDOSE
+4 IF +$GET(PSJDSFLG)
DO SETVAR^PSJDOSE
WRITE !!,PSJDOSE("WARN"),!,PSJDOSE("WARN1")
IF '$$CONT()
WRITE !,"...order was not verified..."
DO PAUSE^VALM1
Begin DoDot:1
+5 SET PSGOEEF(109)=1
+6 SET PSJACEPT=0
+7 ;D EN^VALM("PSJU LM ACCEPT")
End DoDot:1
IF '$GET(PSJACEPT)
QUIT
+8 DO DDCHK
IF CHK
GOTO DONE
+9 IF $GET(PSGSCH)]""
IF ((",P,R,")'[(","_PSGST_","))
Begin DoDot:1
+10 NEW SWD,SDW,XABB,X,QX
SET X=$GET(PSGSCH)
DO DW^PSGS0
IF ($GET(X)="")
QUIT
IF $GET(PSGS0XT)=""
SET PSGS0XT="D"
+11 IF $GET(PSGS0XT)="D"
IF $GET(PSGAT)=""
SET CHK=1
WRITE !!,"This is a 'DAY OF WEEK' schedule and MUST have admin times.",!
DO PAUSE^VALM1
End DoDot:1
IF CHK
GOTO DONE
+12 IF $GET(PSGSCH)]""
Begin DoDot:1
+13 NEW X,Y,PSGS0XT,PSGS0Y,PSGOES
SET PSGOES=2
SET X=PSGSCH
DO ENOS^PSGS0
IF $GET(X)=""
SET CHK=4
End DoDot:1
IF CHK
GOTO DONE
+14 WRITE !,"...a few moments, please..."
+15 IF PSGORD["P"
Begin DoDot:1
+16 NEW PND0,PSGORDR,PSJPRIO,PSJSCHED
SET PND0=^PS(53.1,+PSGORD,0)
IF $PIECE(PND0,U,24)="R"
SET PSGORDR=$PIECE(PND0,U,25)
Begin DoDot:2
+17 NEW OEORD,OOEORD,FILE55,FILE55N0
SET FILE55="^PS(55,"_DFN_$SELECT($PIECE(PND0,U,4)="U":",5,",1:",""IV"",")
SET FILE55N0=FILE55_+PSGORDR_",0)"
+18 SET OEORD=$PIECE(PND0,U,21)
IF PSGORDR
SET OOEORD=$PIECE(@FILE55N0,"^",21)
IF OEORD'=OOEORD
DO EXPOE^PSGOER(DFN,PSGORD,+$$LASTREN^PSJLMPRI(DFN,PSGORD))
+19 SET PSGORDP=PSGORD
SET DIE="^PS(53.1,"
SET DA=+PSGORD
SET DR="28////A;104////@"
WRITE "."
DO ^DIE
+20 DO START^PSGOTR(PSGORD,+PSGORDR)
IF OEORD
Begin DoDot:3
+21 KILL DA,DR,DIE
SET DA(1)=DFN
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
+22 DO EN1^PSJHL2(DFN,"SC",PSGORDR)
DO EN^PSGPEN(PSGORDR)
DO UNL^PSSLOCK(PSGP,PSGORDR)
End DoDot:3
End DoDot:2
QUIT
+23 ;Used in ACTLOG to update activity log in 55
SET PSGORDP=PSGORD
+24 DO REQDT^PSJLIVMD(PSGORD)
+25 SET DIE="^PS(53.1,"
SET DA=+PSGORD
SET DR="28////A"
WRITE "."
DO ^DIE
DO ^PSGOT
+26 SET PSJPRIO=$SELECT(PSGORD["P":$PIECE($GET(^PS(53.1,+PSGORD,.2)),"^",4),PSGORD["U":$PIECE($GET(^PS(55,DFN,5,+PSGORD,.2)),"^",4),1:$PIECE($GET(^PS(55,PSJHLDFN,"IV",+PSGORD,.2)),"^",4))
+27 SET PSJSCHED=$SELECT(PSGORD["P":$PIECE($GET(^PS(53.1,+PSGORD,2)),"^"),PSGORD["U":$PIECE($GET(^PS(55,DFN,5,+PSGORD,2)),"^"),1:$PIECE($GET(^PS(55,PSJHLDFN,"IV",+PSGORD,0)),"^",15))
+28 IF (",S,A,")[(","_$GET(PSJPRIO)_",")!($GET(PSJSCHED)="NOW")!($GET(PSJSCHED)["STAT")
DO NOTIFY^PSJHL4(PSGORD,DFN,$GET(PSJPRIO),$GET(PSJSCHED))
+29 IF $GET(PSGRDTX)=""
SET PSGRDTX=$GET(^PS(53.1,+PSGORDP,2.5))
End DoDot:1
+30 SET DA=+PSGORD
SET DA(1)=PSGP
SET PSGAL("C")=PSJSYSU*10+22000
DO ^PSGAL5
WRITE "."
SET VND4=$GET(^PS(55,PSGP,5,DA,4))
+31 ;IHS/CIA/PLS -03/08/2006 - ADS SUPPORT
IF $$PATCH^XPDUTL("BOP*1.0*1")
DO ^BOPSD
+32 IF $GET(PSGRDTX)
DO NEWUDAL^PSGAL5(PSGP,PSGORD,6090,"Requested Start Date",+$GET(PSGRDTX))
+33 IF $PIECE($GET(PSGRDTX),U,3)
DO NEWUDAL^PSGAL5(PSGP,PSGORD,6090,"Requested Stop Date",+$PIECE($GET(PSGRDTX),U,3))
+34 NEW DUR,DURON
SET DURON=$SELECT($GET(PSGORD):$GET(PSGORD),1:"")
IF DURON
Begin DoDot:1
+35 SET DUR=$SELECT($PIECE($GET(PSGRDTX),U,2)]"":$PIECE($GET(PSGRDTX),U,2),1:$$GETDUR^PSJLIVMD(PSGP,+DURON,$SELECT($GET(DURON)["P":"P",1:5),1),1:"")
End DoDot:1
+36 IF $GET(DUR)]""
SET $PIECE(^PS(55,PSGP,5,+PSGORD,2.5),"^",2)=DUR
+37 IF $DATA(PSGORDP)
DO ACTLOG(PSGORDP,PSGP,PSGORD)
+38 KILL PSGRSD,PSGRFD,PSGALFN
+39 NEW X
SET X=0
IF $GET(PSGONF)
IF (+$GET(PSGODDD(1))'<+$GET(PSGONF))
SET X=1
+40 IF +PSJSYSU=3
IF PSGORD'["O"
IF $SELECT(X:0,'$PIECE(VND4,"^",9):1,1:$PIECE(VND4,"^",15))
DO EN^PSGPEN(+PSGORD)
+41 SET $PIECE(VND4,"^",+PSJSYSU=1+9)=1
IF '$PIECE(VND4,U,+PSJSYSU=3+9)
SET $PIECE(VND4,U,+PSJSYSU=3+9)=+$PIECE(VND4,U,+PSJSYSU=3+9)
+42 ;S $P(VND4,"^",+PSJSYSU=1+9)=1,$P(VND4,U,+PSJSYSU=3+9)=0
+43 IF PSJSYSL>1
SET $PIECE(^PS(55,PSGP,5,+PSGORD,7),U)=PSGDT
IF $PIECE(^(7),U,2)=""
SET $PIECE(^(7),U,2)="N"_$SELECT($PIECE(^PS(55,PSGP,5,+PSGORD,0),"^",24)="E":"E",1:"")
SET PSGTOL=2
SET PSGUOW=DUZ
SET PSGTOO=1
SET DA=+PSGORD
DO ENL^PSGVDS
+44 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,"^",PSJSYSU,PSJSYSU+1)=DUZ_"^"_PSGDT
SET ^PS(55,PSGP,5,+PSGORD,4)=VND4
+45 IF '$PIECE(VND4,U,9)
SET ^PS(55,"APV",PSGP,+PSGORD)=""
+46 IF '$PIECE(VND4,U,10)
SET ^PS(55,"ANV",PSGP,+PSGORD)=""
+47 IF $PIECE(VND4,U,9)
KILL ^PS(55,"APV",PSGP,+PSGORD)
+48 IF $PIECE(VND4,U,10)
KILL ^PS(55,"ANV",PSGP,+PSGORD)
+49 IF '$DATA(PSJSPEED)
WRITE !
WRITE !,"ORDER VERIFIED.",!
+50 IF '$DATA(PSJSPEED)
KILL DIR
SET DIR(0)="E"
DO ^DIR
KILL DIR
+51 IF +PSJSYSU=3
SET ^PS(55,"AUE",PSGP,+PSGORD)=""
SET PSGACT="C"_$SELECT('$DATA(^PS(55,PSGP,5,+PSGORD,4)):"E",$PIECE(^(4),"^",16):"",1:"E")_"RS"
SET PSGCANFL=2
+52 ; allow status change to be sent for pharmacists & nurses
SET VALMBCK="Q"
DO EN1^PSJHL2(PSGP,$SELECT(+PSJSYSU=3:"SC",+PSJSYSU=1:"SC",1:"XX"),+PSGORD_"U")
+53 ;IHS/CIA/PLS - 10/14/05 - Call to Automated Dispensing System
DO CALLBOP
+54 IF +PSJSYSU=1
DO EN1^PSJHL2(PSGP,"ZV",+PSGORD_"U")
DONE ;
+1 IF CHK
WRITE !!,"...order NOT verified..."
+2 IF '$DATA(PSJSPEED)
IF 'CHK
IF +PSJSYSU=3
IF $GET(PSJPRI)="D"
Begin DoDot:1
+3 NEW DIR
WRITE !
SET DIR(0)="S^Y:Yes;N:No"
SET DIR("A")="Do you want to enter a Progress Note"
SET DIR("B")="No"
DO ^DIR
+4 IF Y="N"
QUIT
+5 DO MAIN^TIUEDIT(3,.TIUDA,PSGP,"","","","",1)
End DoDot:1
+6 SET VALMBCK="Q"
KILL CHK,DA,DIE,F,DP,DR,ND,PSGAL,PSGODA,PSJDOSE,PSJVAR,VND4,X
QUIT
+7 ;
LBL ;
+1 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 which is ^PS(53.1,PSGORD,0).
+9 IF ND2=""
SET CHK=CHK_$SELECT('$DATA(^(0)):4,$PIECE(^(0),"^",7)="OC":"",1:4)_56
+10 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)
+11 IF $$CHECK^PSGOE8(PSJSYSP)
IF $PIECE(DRG,U,2)=""
SET CHK=CHK_8
+12 KILL PSGDFLG,PSGPFLG
SET PSGDI=0
+13 IF '$$DDOK^PSGOE2("^PS(53.45,"_PSJSYSP_",2,",+DRG)
SET CHK=CHK_7
SET (PSGDFLG,PSGDI)=1
+14 IF '$$OIOK^PSGOE2(+DRG)
SET PSGPFLG=1
+15 IF 'CHK
IF $GET(PSGSCH)]""
Begin DoDot:1
+16 NEW X,Y,PSGS0Y,PSGS0XT,PSGOES
SET PSGOES=2
SET X=PSGSCH
DO ENOS^PSGS0
IF $GET(X)=""
SET CHK=4
End DoDot:1
+17 IF 'CHK
QUIT
+18 WRITE $CHAR(7)
+19 ;
CHKM ;
+1 DO FULL^VALM1
+2 ; changed to remove ^DD ref
+3 WRITE !!,"THE FOLLOWING ",$SELECT($LENGTH(CHK)>1:"ARE",1:"IS")," EITHER INVALID OR MISSING FROM THIS ORDER:"
FOR X=1:1:7
IF CHK[X
WRITE !?5,$PIECE("ORDERABLE ITEM^MED ROUTE^SCHEDULE TYPE^SCHEDULE^START DATE/TIME^STOP DATE/TIME^DISPENSE DRUG","^",X)
+4 IF CHK=7
WRITE !,"Orders with no dispense drugs or multiple dispense drugs",!,"require dosage ordered"
+5 IF CHK]""
WRITE !!,$SELECT($LENGTH(CHK)>1:"THESE FIELDS ARE",1:"THIS FIELD IS")," NECESSARY FOR VERIFICATION."
+6 NEW DIR
SET DIR(0)="E"
DO ^DIR
IF $DATA(DUOUT)!$DATA(DTOUT)
SET CHK=1
QUIT
+7 QUIT
+8 ;
CONT() ;
+1 NEW DIR,DIRUT,Y
+2 WRITE !
KILL DIR,DIRUT
+3 SET DIR(0)="Y"
SET DIR("A")="Would you like to continue verifying the order"
SET DIR("B")="Yes"
+4 DO ^DIR
+5 QUIT Y
+6 ;
DDCHK ; dispense drug check
+1 SET DRGF="^PS("_$SELECT(PSGORD["P":"53.1,"_+PSGORD,1:"55,"_PSGP_",5,"_+PSGORD)_","
SET CHK=$SELECT('$ORDER(@(DRGF_"1,0)")):7,1:0)
+2 SET PSGPD=$GET(@(DRGF_".2)"))
+3 SET CHK=$SELECT('$$DDOK^PSGOE2(DRGF_"1,",PSGPD):7,1:0)
+4 IF CHK=0
QUIT
+5 WRITE $CHAR(7),!!,"This order must have at least one valid, active dispense drug to be verified."
+6 ;
DDEDIT ;
+1 ;*** Remove all dispense drug for this order
+2 KILL @(DRGF_"1)")
+3 ; The naked reference below refers to the indirect full reference in DRGF_"1,"_Q_")", which is either ^PS(53.1,+PSGORD,Q) or ^PS(55,DFN,5,+PSGORD,Q)
+4 KILL ^PS(53.45,PSJSYSP,2)
SET (X,Q)=0
FOR
SET Q=$ORDER(@(DRGF_"1,"_Q_")"))
IF 'Q
QUIT
SET Y=$GET(^(Q,0))
SET X=Q
SET ^PS(53.45,PSJSYSP,2,Q,0)=Y
IF Y
SET ^PS(53.45,PSJSYSP,2,"B",+Y,Q)=""
+5 IF X
SET ^PS(53.45,PSJSYSP,2,0)="^53.4502P^"_X_"^"_X
+6 DO ENDRG^PSGOEF1(PSGPD,X)
+7 IF 'CHK
SET %X="^PS(53.45,"_PSJSYSP_",2,"
SET %Y=DRGF_"1,"
DO %XY^%RCR
SET $PIECE(@(DRGF_"1,0)"),"^",2)=$SELECT(DRGF[53.1:"53.11P",1:"55.07P")
+8 KILL DRG,DRGF
QUIT
+9 ;
AESCREEN() ;
+1 ; Output: 0 - Required fields missing and DON'T allow accept
+2 ; 1 - Required fields found.
+3 IF '$GET(CHK)
QUIT 1
+4 SET Y=$PIECE($GET(^ORD(101,+$GET(^ORD(101,DA(1),10,DA,0)),0)),U)
IF Y=""
QUIT 0
+5 IF Y="PSJU LM ACCEPT EDIT"
QUIT 1
+6 QUIT 0
ACTLOG(PSGORDP,DFN,PSGORD) ;Store 53.1 activity log in local array to be moved to 55
+1 ;PSGORDP: IEN from 53.1
+2 ;PSGORD : IEN from 55
+3 NEW PSGX,PSGXDA,PSGAL531,Q,QQ
+4 FOR PSGX=0:0
SET PSGX=$ORDER(^PS(53.1,+PSGORDP,"A",PSGX))
IF 'PSGX
QUIT
Begin DoDot:1
+5 SET PSGAL531=$GET(^PS(53.1,+PSGORDP,"A",PSGX,0))
+6 SET QQ=$GET(^PS(55,DFN,5,+PSGORD,9,0))
IF QQ=""
SET QQ="^55.09D"
FOR Q=$PIECE(QQ,U,3)+1:1
IF '$DATA(^(Q))
SET $PIECE(QQ,U,3,4)=Q_U_Q
SET ^(0)=QQ
SET PSGXDA=Q
QUIT
+7 SET ^PS(55,DFN,5,+PSGORD,9,PSGXDA,0)=PSGAL531
End DoDot:1
+8 QUIT
+9 ; Call Automated Dispensing System if present
CALLBOP ;
+1 IF $$PATCH^XPDUTL("BOP*1.0*1")
DO NEW^BOPCAP
+2 QUIT
