PSGOEV ;BIR/CML - VERIFY (MAKE ACTIVE) ORDERS ;Dec 9, 2018@04:26:42
;;5.0;INPATIENT MEDICATIONS;**5,7,15,28,33,50,64,58,77,78,80,110,111,133,171,207,241,267,268,260,288,199,281,256,347,327,414,449**;16 DEC 97;Build 18
;
; 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 ^PSDRUG( supported by DBIA# 2192.
; Reference to MAIN^TIUEDIT is supported by DBIA #2410.
; Reference to ^TMP("PSODAOC",$J supported by DBIA 6071
;
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
NEW PSJOLDNM,PSJOLDX
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
;PSJ*5*256 - inform user of old schedule name and quit
I $S((PSGORD["P"):$P($G(^PS(53.1,+PSGORD,0)),U,24)="R",(PSGORD["U"):$P($G(^PS(55,+PSGP,5,+PSGORD,0)),U,24)="R",1:0) S PSJOLDX="R"
S PSJOLDNM("ORD_SCHD")=$G(PSGSCH)
I $$CHKSCHD^PSJMISC2(.PSJOLDNM,$S($G(PSJOLDX)="R":"R",1:"V")) S CHK=1 G 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 **ENHANCEMENTS MADE IN PSJ*5.0*260 **CCR 6214 **CCR 6244
I PSGORD["P" S PSJCOM=+$P($G(^PS(53.1,+PSGORD,.2)),"^",8) I PSJCOM D VFY^PSJCOM Q
N PSJACEPT,PSJDOSE,PSJDSFLG,PSJDIS,PSGORQF,PSJCNT,PSJCNT1,PSJCNT2,LIST,PSJFLG,PSGDN SET PSJDIS="",PSJCNT=0,PSJCNT1="",PSJCNT2="",LIST="PSGPRE",PSJFLG="",PSGDN=""
D DOSECHK^PSJDOSE
S PSJFLG=+$G(PSGORD)
F S PSJCNT=$O(^PS(53.1,PSJFLG,1,PSJCNT)) Q:'+PSJCNT D
.I $D(^PS(53.1,PSJFLG,1,PSJCNT,0)) S PSGDN=$P($G(^PS(53.1,PSJFLG,1,PSJCNT,0)),U,1)
.I +$G(PSGDN),($$GET1^DIQ(50,PSGDN,3)'["S")&($E($$GET1^DIQ(50,PSGDN,2),1,2)'="XA") D
..D PROFILE^PSJBLDOC($G(DFN),LIST,"I;"_$G(PSGORD))
..F S PSJCNT1=$O(^TMP($J,LIST,"IN","PROFILE",PSJCNT1)) Q:(PSJCNT1="")!(PSJDIS'="") D
...S PSJCNT2=$P(PSJCNT1,";",2)
...I PSJCNT2=$G(PSGORD) SET PSJDIS=$P(^TMP($J,LIST,"IN","PROFILE",PSJCNT1),U,3)
..;**Do order checks if PSJDIS (Dispense drug IEN) has a value
..;IF $G(PSJNEWOE)=0,'$G(PSJLMFIN),'$G(PSJSTARI),'$G(PSGCOPY),$G(PSJDIS),'$G(PSJSPEED) D
..I '+$G(PSJNEWOE),'$G(PSJLMFIN),'$G(PSJSTARI),'$G(PSGCOPY),$G(PSJDIS),'$G(PSJSPEED) D
...D ALLERGY($G(PSJORD),.PSJALLGY),ENDDC^PSGSICHK($G(PSGP),PSJDIS) D:('$G(PSGORQF)&'$G(PSJDSVFY)&'$G(PSJSTARI)) IN^PSJOCDS($G(PSGORD),"UD",PSJDIS) IF $G(PSGORQF) K ^TMP($J,LIST) D:$G(PSJORD)]"" EN^VALM("PSJ LM UD ACTION") QUIT
I $G(PSGORQF) QUIT
D FULL^VALM1 ;PSJ*5*241
;;PSJ*5*449 Display 0 unit Per Dose warning
I +$G(PSJDSFLG0) D SETVAR0^PSJDOSE,DSPWARN0^PSJDOSE
I +$G(PSJDSFLG) D SETVAR^PSJDOSE W !!,PSJDOSE("WARN"),!,PSJDOSE("WARN1")
;PSJ*5*449 Add conditions
I +$G(PSJDSFLG)!+$G(PSJDSFLG0) D Q:'$G(PSJACEPT)
. S PSJACEPT=1
. I '$$CONT() W !,"...order was not verified..." D PAUSE^VALM1 D
. . 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))
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)
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)
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
;; START NCC REMEDIATION >> 327*RJS
N CLOZFLG S CLOZFLG=$$ISCLOZ^PSJCLOZ(,,PSGP,+PSGORD)
I CLOZFLG,'$$GET1^DIQ(55.06,+PSGORD_","_PSGP,301),$G(^TMP($J,"PSGCLOZ",PSGP,+PSJORD,"SAND")) D
.N DIE,DA,DR S DIE="^PS(55,"_PSGP_",5,",DA=+PSGORD,DA(1)=PSGP
.S DR="301////"_^TMP($J,"PSGCLOZ",PSGP,+PSGORD,"SAND") D ^DIE
.K ^TMP($J,"PSGCLOZ",PSGP,+$G(PSJORD),"SAND")
;; END NCC REMEDIATION >> 327*RJS
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
S ^TMP("PSODAOC",$J,"IP IEN")=$G(PSJORD),^TMP("PSODAOC",$J,"IP NEW IEN")=$G(PSGORD)
W:'$D(PSJSPEED) ! W !,"ORDER VERIFIED.",! ;@414 moved these 2 lines from VFY+61,62 to here
I '$D(PSJSPEED) K DIR S DIR(0)="E" D ^DIR K DIR
; -- RTC 198753 - clean-up variable - K PSJAGYSV
D SETOC^PSJNEWOC(PSGORD) K PSJAGYSV
; **This is where the Automated Dispensing Machine hook is called. Do NOT DELETE or change this location **
;; START NCC REMEDIATION >> 327*RJS - next line
D NEWJ^PSJADM I CLOZFLG D CLOZSND^PSJOE
; **END of Interface hook **
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,PSGTOL,PSGTOO,PSGUOW,PSJDOSE,PSJVAR,VND4,X,ZZND Q
;
LBL ;
Q
;
ALLERGY(PSGORD,PSJALLGY) ;setup PSJALLGY when non-vf was selected to verify
N PSGDDI,PSJDD,PSJX,ARR
I '+$G(PSGORD),($G(PSGORD)'["P") Q
D LIST^DIC(53.11,","_+PSGORD_",",,"I",,,,,,,"ARR")
F I=1:1 Q:'$D(ARR("DILIST",2,I)) S PSGDDI=ARR("DILIST",2,I) D
. S PSJDD=+$$GET1^DIQ(53.11,PSGDDI_","_+PSGORD,.01,"I")
. S PSJX=$S('$L($$GET1^DIQ(50,+PSJDD,.01)):1,$$GET1^DIQ(50,+PSJDD,63,"I")'["U":1,$$GET1^DIQ(50,+PSJDD,100)="":0,1:$$GET1^DIQ(50,+PSJDD,100,"I")'>$G(DT))
. Q:PSJX
. S PSJALLGY(PSJDD)=""
Q
CHK(ND,DRG,ND2) ; checks for data in required fields
; Input: ND - ^(PS(53.1,PSGORD,0)
; DRG - ^(.2)
; ND2 - ^(2)
S Y=$G(Y)
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 K:CHK Y
; changed to remove ^DD ref
; PSJ*5*267 VMP Add the 8th condition
W !!,"THE FOLLOWING ",$S($L(CHK)>1:"ARE",1:"IS")," EITHER INVALID OR MISSING FROM THIS ORDER:" F X=1:1:8 W:CHK[X !?5,$P("ORDERABLE ITEM^MED ROUTE^SCHEDULE TYPE^SCHEDULE^START DATE/TIME^STOP DATE/TIME^DISPENSE DRUG^DOSAGE ORDERED","^",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,DUOUT,DTOUT 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")="No"
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,%X,%Y,PSGPD 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
. N TXTLN S TXTLN="" F S TXTLN=$O(^PS(53.1,+PSGORDP,"A",PSGX,1,TXTLN)) Q:TXTLN="" D
.. I TXTLN=0 S ^PS(55,DFN,5,+PSGORD,9,PSGXDA,1,TXTLN)=^PS(53.1,+PSGORDP,"A",PSGX,1,TXTLN) Q
.. S ^PS(55,DFN,5,+PSGORD,9,PSGXDA,1,TXTLN,0)=^PS(53.1,+PSGORDP,"A",PSGX,1,TXTLN,0)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSGOEV 13179 printed Sep 23, 2025@19:38:36 Page 2
PSGOEV ;BIR/CML - VERIFY (MAKE ACTIVE) ORDERS ;Dec 9, 2018@04:26:42
+1 ;;5.0;INPATIENT MEDICATIONS;**5,7,15,28,33,50,64,58,77,78,80,110,111,133,171,207,241,267,268,260,288,199,281,256,347,327,414,449**;16 DEC 97;Build 18
+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 ^PSDRUG( supported by DBIA# 2192.
+8 ; Reference to MAIN^TIUEDIT is supported by DBIA #2410.
+9 ; Reference to ^TMP("PSODAOC",$J supported by DBIA 6071
+10 ;
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 NEW PSJOLDNM,PSJOLDX
+3 if '$DATA(PSGOEAV)
SET PSGOEAV=$PIECE($GET(PSJSYSP0),"^",9)&$GET(PSJSYSU)
+4 IF $DATA(PSGOES)
IF 'PSGOEAV
IF PSGORD["P"
IF $PIECE($GET(^PS(53.1,+PSGORD,0)),"^",21)']""
DO ORSET^PSGOETO1
+5 DO FULL^VALM1
IF 'PSJSYSU
WRITE $CHAR(7),$CHAR(7),!!," THIS FUNCTION NOT AVAILABLE TO WARD STAFF."
QUIT
+6 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
+7 IF +PSJSYSU=3
DO DDCHK
if CHK
GOTO DONE
+8 ;PSJ*5*256 - inform user of old schedule name and quit
+9 IF $SELECT((PSGORD["P"):$PIECE($GET(^PS(53.1,+PSGORD,0)),U,24)="R",(PSGORD["U"):$PIECE($GET(^PS(55,+PSGP,5,+PSGORD,0)),U,24)="R",1:0)
SET PSJOLDX="R"
+10 SET PSJOLDNM("ORD_SCHD")=$GET(PSGSCH)
+11 IF $$CHKSCHD^PSJMISC2(.PSJOLDNM,$SELECT($GET(PSJOLDX)="R":"R",1:"V"))
SET CHK=1
GOTO DONE
+12 IF PSGORD["P"
DO CHK($GET(^PS(53.1,+PSGORD,0)),$GET(^(.2)),$GET(^(2)))
+13 IF $GET(PSGSCH)]""
Begin DoDot:1
+14 NEW X,Y,PSGS0Y,PSGS0XT,PSGOES
SET PSGOES=1
SET X=PSGSCH
DO ENOS^PSGS0
IF $GET(X)=""
SET CHK=4
End DoDot:1
+15 ;G VFY
IF $GET(CHK)
if $DATA(PSJSPEED)
QUIT
DO EN^VALM("PSJU LM ACCEPT")
if '$GET(PSJACEPT)
GOTO DONE
+16 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
+17 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
+18 ;
VFY ; change status, move to 55, and change label record **ENHANCEMENTS MADE IN PSJ*5.0*260 **CCR 6214 **CCR 6244
+1 IF PSGORD["P"
SET PSJCOM=+$PIECE($GET(^PS(53.1,+PSGORD,.2)),"^",8)
IF PSJCOM
DO VFY^PSJCOM
QUIT
+2 NEW PSJACEPT,PSJDOSE,PSJDSFLG,PSJDIS,PSGORQF,PSJCNT,PSJCNT1,PSJCNT2,LIST,PSJFLG,PSGDN
SET PSJDIS=""
SET PSJCNT=0
SET PSJCNT1=""
SET PSJCNT2=""
SET LIST="PSGPRE"
SET PSJFLG=""
SET PSGDN=""
+3 DO DOSECHK^PSJDOSE
+4 SET PSJFLG=+$GET(PSGORD)
+5 FOR
SET PSJCNT=$ORDER(^PS(53.1,PSJFLG,1,PSJCNT))
if '+PSJCNT
QUIT
Begin DoDot:1
+6 IF $DATA(^PS(53.1,PSJFLG,1,PSJCNT,0))
SET PSGDN=$PIECE($GET(^PS(53.1,PSJFLG,1,PSJCNT,0)),U,1)
+7 IF +$GET(PSGDN)
IF ($$GET1^DIQ(50,PSGDN,3)'["S")&($EXTRACT($$GET1^DIQ(50,PSGDN,2),1,2)'="XA")
Begin DoDot:2
+8 DO PROFILE^PSJBLDOC($GET(DFN),LIST,"I;"_$GET(PSGORD))
+9 FOR
SET PSJCNT1=$ORDER(^TMP($JOB,LIST,"IN","PROFILE",PSJCNT1))
if (PSJCNT1="")!(PSJDIS'="")
QUIT
Begin DoDot:3
+10 SET PSJCNT2=$PIECE(PSJCNT1,";",2)
+11 IF PSJCNT2=$GET(PSGORD)
SET PSJDIS=$PIECE(^TMP($JOB,LIST,"IN","PROFILE",PSJCNT1),U,3)
End DoDot:3
+12 ;**Do order checks if PSJDIS (Dispense drug IEN) has a value
+13 ;IF $G(PSJNEWOE)=0,'$G(PSJLMFIN),'$G(PSJSTARI),'$G(PSGCOPY),$G(PSJDIS),'$G(PSJSPEED) D
+14 IF '+$GET(PSJNEWOE)
IF '$GET(PSJLMFIN)
IF '$GET(PSJSTARI)
IF '$GET(PSGCOPY)
IF $GET(PSJDIS)
IF '$GET(PSJSPEED)
Begin DoDot:3
+15 DO ALLERGY($GET(PSJORD),.PSJALLGY)
DO ENDDC^PSGSICHK($GET(PSGP),PSJDIS)
if ('$GET(PSGORQF)&'$GET(PSJDSVFY)&'$GET(PSJSTARI))
DO IN^PSJOCDS($GET(PSGORD),"UD",PSJDIS)
IF $GET(PSGORQF)
KILL ^TMP($JOB,LIST)
if $GET(PSJORD)]""
DO EN^VALM("PSJ LM UD ACTION")
QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+16 IF $GET(PSGORQF)
QUIT
+17 ;PSJ*5*241
DO FULL^VALM1
+18 ;;PSJ*5*449 Display 0 unit Per Dose warning
+19 IF +$GET(PSJDSFLG0)
DO SETVAR0^PSJDOSE
DO DSPWARN0^PSJDOSE
+20 IF +$GET(PSJDSFLG)
DO SETVAR^PSJDOSE
WRITE !!,PSJDOSE("WARN"),!,PSJDOSE("WARN1")
+21 ;PSJ*5*449 Add conditions
+22 IF +$GET(PSJDSFLG)!+$GET(PSJDSFLG0)
Begin DoDot:1
+23 SET PSJACEPT=1
+24 IF '$$CONT()
WRITE !,"...order was not verified..."
DO PAUSE^VALM1
Begin DoDot:2
+25 SET PSGOEEF(109)=1
+26 SET PSJACEPT=0
End DoDot:2
+27 ;D EN^VALM("PSJU LM ACCEPT")
End DoDot:1
if '$GET(PSJACEPT)
QUIT
+28 DO DDCHK
if CHK
GOTO DONE
+29 IF $GET(PSGSCH)]""
IF ((",P,R,")'[(","_PSGST_","))
Begin DoDot:1
+30 NEW SWD,SDW,XABB,X,QX
SET X=$GET(PSGSCH)
DO DW^PSGS0
if ($GET(X)="")
QUIT
IF $GET(PSGS0XT)=""
SET PSGS0XT="D"
+31 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
+32 IF $GET(PSGSCH)]""
Begin DoDot:1
+33 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
+34 WRITE !,"...a few moments, please..."
+35 IF PSGORD["P"
Begin DoDot:1
+36 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
+37 NEW OEORD,OOEORD,FILE55,FILE55N0
SET FILE55="^PS(55,"_DFN_$SELECT($PIECE(PND0,U,4)="U":",5,",1:",""IV"",")
SET FILE55N0=FILE55_+PSGORDR_",0)"
+38 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))
+39 SET PSGORDP=PSGORD
SET DIE="^PS(53.1,"
SET DA=+PSGORD
SET DR="28////A;104////@"
WRITE "."
DO ^DIE
+40 DO START^PSGOTR(PSGORD,+PSGORDR)
IF OEORD
Begin DoDot:3
+41 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
+42 DO EN1^PSJHL2(DFN,"SC",PSGORDR)
DO EN^PSGPEN(PSGORDR)
DO UNL^PSSLOCK(PSGP,PSGORDR)
End DoDot:3
End DoDot:2
QUIT
+43 ;Used in ACTLOG to update activity log in 55
SET PSGORDP=PSGORD
+44 DO REQDT^PSJLIVMD(PSGORD)
+45 SET DIE="^PS(53.1,"
SET DA=+PSGORD
SET DR="28////A"
WRITE "."
DO ^DIE
DO ^PSGOT
+46 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))
+47 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))
+48 IF (",S,A,")[(","_$GET(PSJPRIO)_",")!($GET(PSJSCHED)="NOW")!($GET(PSJSCHED)["STAT")
DO NOTIFY^PSJHL4(PSGORD,DFN,$GET(PSJPRIO),$GET(PSJSCHED))
+49 IF $GET(PSGRDTX)=""
SET PSGRDTX=$GET(^PS(53.1,+PSGORDP,2.5))
End DoDot:1
+50 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))
+51 IF $GET(PSGRDTX)
DO NEWUDAL^PSGAL5(PSGP,PSGORD,6090,"Requested Start Date",+$GET(PSGRDTX))
+52 IF $PIECE($GET(PSGRDTX),U,3)
DO NEWUDAL^PSGAL5(PSGP,PSGORD,6090,"Requested Stop Date",+$PIECE($GET(PSGRDTX),U,3))
+53 NEW DUR,DURON
SET DURON=$SELECT($GET(PSGORD):$GET(PSGORD),1:"")
IF DURON
Begin DoDot:1
+54 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
+55 IF $GET(DUR)]""
SET $PIECE(^PS(55,PSGP,5,+PSGORD,2.5),"^",2)=DUR
+56 if $DATA(PSGORDP)
DO ACTLOG(PSGORDP,PSGP,PSGORD)
+57 KILL PSGRSD,PSGRFD,PSGALFN
+58 NEW X
SET X=0
IF $GET(PSGONF)
IF (+$GET(PSGODDD(1))'<+$GET(PSGONF))
SET X=1
+59 IF +PSJSYSU=3
IF PSGORD'["O"
IF $SELECT(X:0,'$PIECE(VND4,"^",9):1,1:$PIECE(VND4,"^",15))
DO EN^PSGPEN(+PSGORD)
+60 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)
+61 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
+62 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
+63 IF '$PIECE(VND4,U,9)
SET ^PS(55,"APV",PSGP,+PSGORD)=""
+64 IF '$PIECE(VND4,U,10)
SET ^PS(55,"ANV",PSGP,+PSGORD)=""
+65 IF $PIECE(VND4,U,9)
KILL ^PS(55,"APV",PSGP,+PSGORD)
+66 IF $PIECE(VND4,U,10)
KILL ^PS(55,"ANV",PSGP,+PSGORD)
+67 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
+68 ;; START NCC REMEDIATION >> 327*RJS
+69 NEW CLOZFLG
SET CLOZFLG=$$ISCLOZ^PSJCLOZ(,,PSGP,+PSGORD)
+70 IF CLOZFLG
IF '$$GET1^DIQ(55.06,+PSGORD_","_PSGP,301)
IF $GET(^TMP($JOB,"PSGCLOZ",PSGP,+PSJORD,"SAND"))
Begin DoDot:1
+71 NEW DIE,DA,DR
SET DIE="^PS(55,"_PSGP_",5,"
SET DA=+PSGORD
SET DA(1)=PSGP
+72 SET DR="301////"_^TMP($JOB,"PSGCLOZ",PSGP,+PSGORD,"SAND")
DO ^DIE
+73 KILL ^TMP($JOB,"PSGCLOZ",PSGP,+$GET(PSJORD),"SAND")
End DoDot:1
+74 ;; END NCC REMEDIATION >> 327*RJS
+75 ; 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")
+76 SET ^TMP("PSODAOC",$JOB,"IP IEN")=$GET(PSJORD)
SET ^TMP("PSODAOC",$JOB,"IP NEW IEN")=$GET(PSGORD)
+77 ;@414 moved these 2 lines from VFY+61,62 to here
if '$DATA(PSJSPEED)
WRITE !
WRITE !,"ORDER VERIFIED.",!
+78 IF '$DATA(PSJSPEED)
KILL DIR
SET DIR(0)="E"
DO ^DIR
KILL DIR
+79 ; -- RTC 198753 - clean-up variable - K PSJAGYSV
+80 DO SETOC^PSJNEWOC(PSGORD)
KILL PSJAGYSV
+81 ; **This is where the Automated Dispensing Machine hook is called. Do NOT DELETE or change this location **
+82 ;; START NCC REMEDIATION >> 327*RJS - next line
+83 DO NEWJ^PSJADM
IF CLOZFLG
DO CLOZSND^PSJOE
+84 ; **END of Interface hook **
+85 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,PSGTOL,PSGTOO,PSGUOW,PSJDOSE,PSJVAR,VND4,X,ZZND
QUIT
+7 ;
LBL ;
+1 QUIT
+2 ;
ALLERGY(PSGORD,PSJALLGY) ;setup PSJALLGY when non-vf was selected to verify
+1 NEW PSGDDI,PSJDD,PSJX,ARR
+2 IF '+$GET(PSGORD)
IF ($GET(PSGORD)'["P")
QUIT
+3 DO LIST^DIC(53.11,","_+PSGORD_",",,"I",,,,,,,"ARR")
+4 FOR I=1:1
if '$DATA(ARR("DILIST",2,I))
QUIT
SET PSGDDI=ARR("DILIST",2,I)
Begin DoDot:1
+5 SET PSJDD=+$$GET1^DIQ(53.11,PSGDDI_","_+PSGORD,.01,"I")
+6 SET PSJX=$SELECT('$LENGTH($$GET1^DIQ(50,+PSJDD,.01)):1,$$GET1^DIQ(50,+PSJDD,63,"I")'["U":1,$$GET1^DIQ(50,+PSJDD,100)="":0,1:$$GET1^DIQ(50,+PSJDD,100,"I")'>$GET(DT))
+7 if PSJX
QUIT
+8 SET PSJALLGY(PSJDD)=""
End DoDot:1
+9 QUIT
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 Y=$GET(Y)
+5 SET CHK=""
IF DRG
IF $DATA(^PS(50.7,+DRG,0))
+6 IF '$TEST
SET CHK=1
+7 IF ND=""
SET CHK=CHK_23
+8 IF '$TEST
SET CHK=CHK_$SELECT($PIECE(ND,"^",3):"",1:2)_$SELECT($PIECE(ND,"^",7)]"":"",1:3)
+9 ;The naked reference on the line below refers to the variable ND 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 '$$DDOK^PSGOE2("^PS(53.45,"_PSJSYSP_",2,",+DRG)
SET CHK=CHK_7
SET (PSGDFLG,PSGDI)=1
+15 if '$$OIOK^PSGOE2(+DRG)
SET PSGPFLG=1
+16 IF 'CHK
IF $GET(PSGSCH)]""
Begin DoDot:1
+17 NEW X,Y,PSGS0Y,PSGS0XT,PSGOES
SET PSGOES=2
SET X=PSGSCH
DO ENOS^PSGS0
IF $GET(X)=""
SET CHK=4
End DoDot:1
+18 if 'CHK
QUIT
+19 WRITE $CHAR(7)
+20 ;
CHKM ;
+1 DO FULL^VALM1
if CHK
KILL Y
+2 ; changed to remove ^DD ref
+3 ; PSJ*5*267 VMP Add the 8th condition
+4 WRITE !!,"THE FOLLOWING ",$SELECT($LENGTH(CHK)>1:"ARE",1:"IS")," EITHER INVALID OR MISSING FROM THIS ORDER:"
FOR X=1:1:8
if CHK[X
WRITE !?5,$PIECE("ORDERABLE ITEM^MED ROUTE^SCHEDULE TYPE^SCHEDULE^START DATE/TIME^STOP DATE/TIME^DISPENSE DRUG^DOSAGE ORDERED","^",X)
+5 IF CHK=7
WRITE !,"Orders with no dispense drugs or multiple dispense drugs",!,"require dosage ordered"
+6 if CHK]""
WRITE !!,$SELECT($LENGTH(CHK)>1:"THESE FIELDS ARE",1:"THIS FIELD IS")," NECESSARY FOR VERIFICATION."
+7 NEW DIR,DUOUT,DTOUT
SET DIR(0)="E"
DO ^DIR
IF $DATA(DUOUT)!$DATA(DTOUT)
SET CHK=1
QUIT
+8 QUIT
+9 ;
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")="No"
+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,%X,%Y,PSGPD
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
+8 NEW TXTLN
SET TXTLN=""
FOR
SET TXTLN=$ORDER(^PS(53.1,+PSGORDP,"A",PSGX,1,TXTLN))
if TXTLN=""
QUIT
Begin DoDot:2
+9 IF TXTLN=0
SET ^PS(55,DFN,5,+PSGORD,9,PSGXDA,1,TXTLN)=^PS(53.1,+PSGORDP,"A",PSGX,1,TXTLN)
QUIT
+10 SET ^PS(55,DFN,5,+PSGORD,9,PSGXDA,1,TXTLN,0)=^PS(53.1,+PSGORDP,"A",PSGX,1,TXTLN,0)
End DoDot:2
End DoDot:1
+11 QUIT
