PSGOETO ;BIR/CML3 - TRANSCRIBE ORDERS ;Nov 09, 2020@14:45:15
;;5.0;INPATIENT MEDICATIONS;**3,13,25,31,33,50,68,58,85,105,90,117,110,111,112,161,254,267,268,315,327,398,319,399**;16 DEC 97;Build 64
;Per VHA Directive 2004-038, this routine should not be modified.
; Reference to ^PS(51.2 via DBIA 2178
; Reference to ^PS(55 via DBIA 2191
; Reference to ^PS(59.7 via DBIA 2181
; Reference to ^PSUHL via DBIA 4803
;
W:'$D(PSGOEE)&'$D(PSGOES) !!,"...transcribing this ",$S($D(PSGOES):"",'PSGOEAV:"non-verified ",1:"active "),"order..." S PSGOETOF=1 S:PSGSM="" PSGSM=0
I PSGPR'=PSGOEPR D:'$D(^PS(55,PSGP,0)) ENSET0^PSGNE3(PSGP) S $P(^PS(55,PSGP,5.1),U,2)=PSGPR,PSGOEPR=PSGPR
K ND4,DA D ENGNN:'PSGOEAV,ENGNA:PSGOEAV S PSGDT=$$DATE^PSJUTL2() I $S($D(ORACTION):0,$G(PSGOEE)="R":1,+$G(^PS(55,PSGP,5.1))>PSGDT:0,1:$G(PSGOEE)'="E") D ENWALL^PSGNE3(PSGNESD,PSGNEFD,PSGP)
I $D(^PS(51.2,+PSGMR,0)),$P(^(0),U,3)]"" S PSGMRN=$P(^(0),U,3)
S ND=DA_U_PSGPR_U_PSGMR_"^U^"_PSGSM_U_PSGHSM_U_PSGST_"^^"_$S(PSGOEAV:"A",1:"N")_"^^^^^"_PSGDT_U_PSGP_U_PSGDT S:PSGNEDFD $P(ND,U,$P(PSGNEDFD,U)["L"+10)=+PSGNEDFD
S:$D(PSGOEE) $P(ND,U,24,25)=PSGOEE_U_PSGOORD S:'PSGOEAV $P(ND,U,18)=DA S ND2=PSGSCH_U_$S(PSGNESD:+PSGNESD,1:"")_"^^"_+PSGNEFD_U_PSGS0Y_U_PSGS0XT_"^^^^"_+PSJPWD ;*398
S:$G(PSGRF)]"" ND2P1=$G(PSGDUR)_U_$G(PSGRMVT)_U_$G(PSGRMV)_U_$G(PSGRF) ;*315 drp
; naked reference below refers to ^PS(55,PSGP,0)
I PSGOEAV S F=^PS(55,PSGP,0) I $P(F,"^",7)="" S $P(F,"^",7)=$P($P(ND,"^",16),"."),$P(F,"^",8)="A",^(0)=F D LOGDFN^PSUHL(PSGP)
S $P(ND4,U,7)=DUZ I PSGOEAV,PSJSYSU D
.S $P(ND4,U,PSJSYSU,PSJSYSU+1)=DUZ_U_PSGDT,$P(ND4,U,+PSJSYSU=1+9)=1,$P(ND4,U,+PSJSYSU=3+9)=0
.S $P(ND4,U,9,10)=+$P(ND4,U,9)_U_+$P(ND4,U,10)
.I '$P(ND4,U,9) S ^PS(55,"APV",PSGP,DA)=""
.I '$P(ND4,U,10) S ^PS(55,"NPV",PSGP,DA)=""
.I $P(ND4,U,9) K ^PS(55,"APV",PSGP,DA)
.I $P(ND4,U,10) K ^PS(55,"NPV",PSGP,DA)
S F="^PS("_$S(PSGOEAV:"55,"_PSGP_",5",1:53.1)_","_DA_",",@(F_"0)")=ND
;naked reference below refers to full reference inside indirection @(F_".2)") for either file 53.1 or 55
S @(F_".2)")=PSGPDRG_U_PSGDO_U_PSJNOO S:$G(PSJDOSE("DO"))]"" $P(^(.2),U,5,6)=$P(PSJDOSE("DO"),U,1,2)
I '$D(PSJDOSE("DO")),$D(PSGORD),PSGPDRG=$P(@("^PS("_$S(PSGORD["U":"55,"_PSGP_",5",1:53.1)_","_+PSGORD_",.2)"),U) S $P(@(F_".2)"),U,5,6)=$P(@("^PS("_$S(PSGORD["U":"55,"_PSGP_",5",1:53.1)_","_+PSGORD_",.2)"),U,5,6)
;naked reference below refers to full reference inside indirection @(F_"2)") for either file 53.1 or 55
S @(F_"2)")=$S(PSGOEAV:ND2,1:$P(ND2,"^",1,6)),^(4)=ND4 S:PSGSI]"" ^(6)=PSGSI
;*315 DRP INSERT UPDATE FOR REMOVAL FIELDS HERE
S:$G(ND2P1)]"" @(F_"2.1)")=ND2P1
S X=-1 S:'$D(^PS(53.45,+$G(DUZ),5,1,0)) X=$S($G(PSGORD):$$GETSIOPI^PSJBCMA5(DFN,PSGORD),1:"") I X D FILESI^PSJBCMA5(PSGP,DA_$S(F["PS(55":"U",1:"P"))
S (C,X)=0 F S X=$O(^PS(53.45,PSJSYSP,2,X)) Q:'X S D=$G(^(X,0)) I D,$S('$P(D,U,3):1,1:$P(D,U,3)>DT) S C=C+1,@(F_"1,"_C_",0)")=$P(D,U,1,2),@(F_"1,""B"","_+D_","_C_")")=""
S:C @(F_"1,0)")=U_$S(PSGOEAV:55.07,1:53.11)_"P^"_C_U_C
S (C,Q)=0 F S Q=$O(^PS(53.45,PSJSYSP,1,Q)) Q:'Q S X=$G(^(Q,0)) S:X]"" C=C+1,@(F_"3,"_C_",0)")=X
S:C @(F_"3,0)")=U_$S(PSGOEAV:55.08,1:53.12)_U_C_U_C
I $P(ND,U,24)="R" S %X="^PS(55,"_PSGP_",5,"_+PSGORD_",12,",%Y=F_"12," D %XY^%RCR
W "." D CRN:'PSGOEAV,CRA:PSGOEAV
S:'PSGOEAV ^PS(53.1,DA,18)=$G(PSGIND) S:PSGOEAV ^PS(55,PSGP,5,DA,18)=$G(PSGIND) ;*399-IND
; don't send message to CPRS if from Order Set and autoverify turned off
;; START NCC REMEDIATION >> 327*RJS
N ARR,FOUND D FIND^DIC(53.1,,.01,"Q",PSGP,,"AC",,,"ARR")
F I=2:1 Q:'$D(ARR("DILIST",2,I)) I ARR("DILIST",2,I)=DA S FOUND=1
I $G(FOUND)!($$GET1^DIQ(55.06,+$G(ND)_","_DFN,.01,"I")) D
.I +$G(PSGCTDD) N PSGTMP S PSGTDD=PSGCTDD,PSGTMP=DA K PSGCTDD
.I +$G(PSGETDD) N PSGTMP S PSGTDD=PSGETDD,PSGTMP=DA K PSGETDD
.I +$G(PSGNTDD) N PSGTMP S PSGTDD=PSGNTDD,PSGTMP=DA K PSGNTDD
I +$G(ND)["U" S PSGTMP=+$G(ND)
S:'+$G(PSGTMP) PSGTMP=DA
I $G(PSGTDD) D
.;/MZR changed the next line
.I PSGOEAV,'$D(^TMP("PSJCOM",$J,DA)) S ^TMP("PSJCOM",$J,DA,"SAND")=PSGTDD
.S ^TMP($J,"PSGCLOZ",DFN,+$G(PSGTMP),"SAND")=PSGTDD K PSGTDD
I $G(PSGETDD) D
.I 'PSGOEAV,'$D(^TMP("PSJCOM",$J,DA)) S ^TMP("PSJCOM",$J,DA,"SAND")=PSGETDD K PSGETDD
;; END NCC REMEDIATION >> 327*RJS
S PSGORD=DA_$S(PSGOEAV:"U",1:"P")
I $G(PSGOORD),$D(PSGOEE) N CLINAPPT S CLINAPPT=$S(PSGOORD["U":$G(^PS(55,PSGP,5,+PSGOORD,8)),PSGOORD["P":$G(^PS(53.1,+PSGOORD,"DSS")),1:"") I CLINAPPT D
.N DIE,DA,DR
.I PSGORD["U" S DIE="^PS(55,"_PSGP_",5,",DA=+PSGORD,DA(1)=PSGP,DR="130////"_+CLINAPPT_";" S:$P(CLINAPPT,"^",2) DR=DR_"131////"_$P(CLINAPPT,"^",2)_";"
.I PSGORD["P" S DIE="^PS(53.1,",DA=+PSGORD,DR="113////"_+CLINAPPT_";" S:$P(CLINAPPT,"^",2) DR=DR_"126////"_$P(CLINAPPT,"^",2)_";"
.I $G(DR) D ^DIE
;PSJ*319,jmc - Clinic Order
I ($G(PSJCMO)!$G(PSJCM01)),$D(PSJCLAPP) N CLINAPPT S CLINAPPT=PSJCLAPP I CLINAPPT D
.N DIE,DA,DR
.I PSGORD["U" S DIE="^PS(55,"_PSGP_",5,",DA=+PSGORD,DA(1)=PSGP,DR="130////"_+CLINAPPT_";" S:$P(CLINAPPT,"^",2) DR=DR_"131////"_$P(CLINAPPT,"^",2)_";"
.I PSGORD["P" S DIE="^PS(53.1,",DA=+PSGORD,DR="113////"_+CLINAPPT_";" S:$P(CLINAPPT,"^",2) DR=DR_"126////"_$P(CLINAPPT,"^",2)_";"
.I $G(DR) D ^DIE
D:('$D(PSGOES))!(($D(PSGOES)&(PSGOEAV))) ORSET^PSGOETO1
I $D(PSGOES),'$D(PSGOESON) N PSGOESON S PSGOESON=PSGORD D DISACTIO^PSJOE(DFN,PSGORD,0) D:PSGORD["U"&(PSGOESON=PSGORD)&($P(@(PSGOEEWF_"0)"),"^",9)'="D") EN^PSGPEN(PSGORD) G OUT
D DONE S PSGCANFL="" I '$D(PSGOEE) S PSJLM=1,PSGOEEF=0 D GETUD^PSJLMGUD(PSGP,PSGORD),ENSFE^PSGOEE0(PSGP,PSGORD),EN^VALM("PSJ LM ACCEPT") I PSGCANFL=1 G OUT
I $D(PSJSYSO) S PSGPOSA="W",PSGPOSD=PSGDT D ENPOS^PSGVDS
S DA=+PSGORD,X=$P(PSGORD,DA,2) I PSJSYSL,$S(PSGOEAV:1,1:PSJSYSL<3),$S("AOU"[X:'$D(^PS(55,PSGP,5,+PSGORD,7)),1:'$D(^PS(53.1,+PSGORD,7))) D
.; naked ref below is from line above, ^PS(53.1,+PSGORD,7)
.S $P(^(7),U,1,2)=PSGDT_"^N"_$G(PSGOEE),PSGUOW=DUZ,PSGTOL=2,PSGTOO=$S("AOU"[X:1,1:2) D ENL^PSGVDS
D STOREINT^PSGSICH1
OUT ;
K PSGOETOF
; ** This is where the Automated Dispensing Machine hook is called. Do NOT DELETE or change location **
D NEWG^PSJADM
; ** END of Interface hook **
DONE ;
I PSGOEAV L -^PS(55,PSGP,5,+PSGORD)
I 'PSGOEAV L -^PS(53.1,+PSGORD)
K C,D,ND,ND2,ND4,PSGDO,PSGDRG,PSGDRGN,PSGFOK,PSGHSM,PSGMR,PSGMRN,PSGNEDFD,PSGNEFD,PSGNESD,PSGPDRG,PSGPDRGN,PSGSI,PSGSTN,PSJDOSE,ND0,ND2P1,PSJCLAPP
K ^PS(53.45,+$G(DUZ),5)
Q
CRA ;
S:PSGPDRG ^PS(55,PSGP,5,"C",PSGPDRG,DA)="" S (^PS(55,"AUE",PSGP,DA),^PS(55,PSGP,5,"AU",PSGST,+PSGNEFD,DA),^PS(55,PSGP,5,"AUS",+PSGNEFD,DA))="",^PS(55,"AUD",+$P(ND2,"^",4),PSGP,DA)="",^PS(55,"AUDS",+$P(ND2,"^",2),PSGP,DA)=""
I $$PATCH^XPDUTL("PXRM*1.5*12") S X(1)=+PSGNESD,X(2)=+PSGNEFD,DA(1)=PSGP D SPSPA^PSJXRFS(.X,.DA,"UD")
S DA(1)=PSGP K DIK S DIK="^PS(55,"_DA(1)_",5,",DIK(1)=125 D EN1^DIK K DIK
K PSGALO,PSGALR S DA(1)=PSGP,PSGAL("C")=PSJSYSU*10+$S('$D(PSGOEE):22500,PSGOEE="E":22600,1:22700) D ^PSGAL5 Q
CRN ;
S (^PS(53.1,"AC",PSGP,DA),^PS(53.1,"AS","N",PSGP,DA),^PS(53.1,"B",DA,DA),^PS(53.1,"C",PSGP,DA))="" S:PSGPDRG (^PS(53.1,"AOD",PSGP,PSGPDRG,DA),^PS(53.1,"D",PSGPDRG,DA))="" Q
ENGNA ; Verified
F L +^PS(55,PSGP,5,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) S:'$D(^PS(55,PSGP,0)) ^(0)=PSGP,^PS(55,"B",PSGP,PSGP)="" S ND=$S($D(^PS(55,PSGP,5,0)):^(0),1:"^55.06IA") Q
N PSGLCK S PSGLCK=0
F DA=$P(ND,U,3)+1:1 W "." I '$D(^PS(55,PSGP,5,DA)),'$D(^PS(55,PSGP,5,"B",DA)) D I PSGLCK S ^PS(55,PSGP,5,DA,0)=DA,^PS(55,PSGP,5,"B",DA,DA)="",$P(ND,U,3)=DA,$P(ND,U,4)=$P(ND,U,4)+1,^PS(55,PSGP,5,0)=ND Q
. L +^PS(55,PSGP,5,DA):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I S PSGLCK=1
L -^PS(55,PSGP,5,0) Q
ENGNN ; Not Verified
N ND F L +^PS(59.7,1,25):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I S DA=+$G(^PS(59.7,1,25)) Q
F DA=DA+1:1 I '$D(^PS(53.1,DA)),'$D(^PS(53.1,"B",DA)) L +^PS(53.1,DA):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I S ^PS(59.7,1,25)=DA,^PS(53.1,DA,0)=DA,^PS(53.1,"B",DA,DA)="" Q
F L +^PS(53.1,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I S ND=$G(^PS(53.1,0)),$P(ND,U,3)=DA,$P(ND,U,4)=$P(ND,U,4)+1,^(0)=ND Q
L -^PS(59.7,1,25),-^PS(53.1,0)
I $G(PSIVCHG) D
.N PSGORD,ON S ON=DA_"P" D SETIVINT^PSGSICH1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSGOETO 8164 printed Sep 23, 2025@19:38:34 Page 2
PSGOETO ;BIR/CML3 - TRANSCRIBE ORDERS ;Nov 09, 2020@14:45:15
+1 ;;5.0;INPATIENT MEDICATIONS;**3,13,25,31,33,50,68,58,85,105,90,117,110,111,112,161,254,267,268,315,327,398,319,399**;16 DEC 97;Build 64
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 ; Reference to ^PS(51.2 via DBIA 2178
+4 ; Reference to ^PS(55 via DBIA 2191
+5 ; Reference to ^PS(59.7 via DBIA 2181
+6 ; Reference to ^PSUHL via DBIA 4803
+7 ;
+8 if '$DATA(PSGOEE)&'$DATA(PSGOES)
WRITE !!,"...transcribing this ",$SELECT($DATA(PSGOES):"",'PSGOEAV:"non-verified ",1:"active "),"order..."
SET PSGOETOF=1
if PSGSM=""
SET PSGSM=0
+9 IF PSGPR'=PSGOEPR
if '$DATA(^PS(55,PSGP,0))
DO ENSET0^PSGNE3(PSGP)
SET $PIECE(^PS(55,PSGP,5.1),U,2)=PSGPR
SET PSGOEPR=PSGPR
+10 KILL ND4,DA
if 'PSGOEAV
DO ENGNN
if PSGOEAV
DO ENGNA
SET PSGDT=$$DATE^PSJUTL2()
IF $SELECT($DATA(ORACTION):0,$GET(PSGOEE)="R":1,+$GET(^PS(55,PSGP,5.1))>PSGDT:0,1:$GET(PSGOEE)'="E")
DO ENWALL^PSGNE3(PSGNESD,PSGNEFD,PSGP)
+11 IF $DATA(^PS(51.2,+PSGMR,0))
IF $PIECE(^(0),U,3)]""
SET PSGMRN=$PIECE(^(0),U,3)
+12 SET ND=DA_U_PSGPR_U_PSGMR_"^U^"_PSGSM_U_PSGHSM_U_PSGST_"^^"_$SELECT(PSGOEAV:"A",1:"N")_"^^^^^"_PSGDT_U_PSGP_U_PSGDT
if PSGNEDFD
SET $PIECE(ND,U,$PIECE(PSGNEDFD,U)["L"+10)=+PSGNEDFD
+13 ;*398
if $DATA(PSGOEE)
SET $PIECE(ND,U,24,25)=PSGOEE_U_PSGOORD
if 'PSGOEAV
SET $PIECE(ND,U,18)=DA
SET ND2=PSGSCH_U_$SELECT(PSGNESD:+PSGNESD,1:"")_"^^"_+PSGNEFD_U_PSGS0Y_U_PSGS0XT_"^^^^"_+PSJPWD
+14 ;*315 drp
if $GET(PSGRF)]""
SET ND2P1=$GET(PSGDUR)_U_$GET(PSGRMVT)_U_$GET(PSGRMV)_U_$GET(PSGRF)
+15 ; naked reference below refers to ^PS(55,PSGP,0)
+16 IF PSGOEAV
SET F=^PS(55,PSGP,0)
IF $PIECE(F,"^",7)=""
SET $PIECE(F,"^",7)=$PIECE($PIECE(ND,"^",16),".")
SET $PIECE(F,"^",8)="A"
SET ^(0)=F
DO LOGDFN^PSUHL(PSGP)
+17 SET $PIECE(ND4,U,7)=DUZ
IF PSGOEAV
IF PSJSYSU
Begin DoDot:1
+18 SET $PIECE(ND4,U,PSJSYSU,PSJSYSU+1)=DUZ_U_PSGDT
SET $PIECE(ND4,U,+PSJSYSU=1+9)=1
SET $PIECE(ND4,U,+PSJSYSU=3+9)=0
+19 SET $PIECE(ND4,U,9,10)=+$PIECE(ND4,U,9)_U_+$PIECE(ND4,U,10)
+20 IF '$PIECE(ND4,U,9)
SET ^PS(55,"APV",PSGP,DA)=""
+21 IF '$PIECE(ND4,U,10)
SET ^PS(55,"NPV",PSGP,DA)=""
+22 IF $PIECE(ND4,U,9)
KILL ^PS(55,"APV",PSGP,DA)
+23 IF $PIECE(ND4,U,10)
KILL ^PS(55,"NPV",PSGP,DA)
End DoDot:1
+24 SET F="^PS("_$SELECT(PSGOEAV:"55,"_PSGP_",5",1:53.1)_","_DA_","
SET @(F_"0)")=ND
+25 ;naked reference below refers to full reference inside indirection @(F_".2)") for either file 53.1 or 55
+26 SET @(F_".2)")=PSGPDRG_U_PSGDO_U_PSJNOO
if $GET(PSJDOSE("DO"))]""
SET $PIECE(^(.2),U,5,6)=$PIECE(PSJDOSE("DO"),U,1,2)
+27 IF '$DATA(PSJDOSE("DO"))
IF $DATA(PSGORD)
IF PSGPDRG=$PIECE(@("^PS("_$SELECT(PSGORD["U":"55,"_PSGP_",5",1:53.1)_","_+PSGORD_",.2)"),U)
SET $PIECE(@(F_".2)"),U,5,6)=$PIECE(@("^PS("_$SELECT(PSGORD["U":"55,"_PSGP_",5",1:53.1)_","_+PSGORD_",.2)"),U,5,6)
+28 ;naked reference below refers to full reference inside indirection @(F_"2)") for either file 53.1 or 55
+29 SET @(F_"2)")=$SELECT(PSGOEAV:ND2,1:$PIECE(ND2,"^",1,6))
SET ^(4)=ND4
if PSGSI]""
SET ^(6)=PSGSI
+30 ;*315 DRP INSERT UPDATE FOR REMOVAL FIELDS HERE
+31 if $GET(ND2P1)]""
SET @(F_"2.1)")=ND2P1
+32 SET X=-1
if '$DATA(^PS(53.45,+$GET(DUZ),5,1,0))
SET X=$SELECT($GET(PSGORD):$$GETSIOPI^PSJBCMA5(DFN,PSGORD),1:"")
IF X
DO FILESI^PSJBCMA5(PSGP,DA_$SELECT(F["PS(55":"U",1:"P"))
+33 SET (C,X)=0
FOR
SET X=$ORDER(^PS(53.45,PSJSYSP,2,X))
if 'X
QUIT
SET D=$GET(^(X,0))
IF D
IF $SELECT('$PIECE(D,U,3):1,1:$PIECE(D,U,3)>DT)
SET C=C+1
SET @(F_"1,"_C_",0)")=$PIECE(D,U,1,2)
SET @(F_"1,""B"","_+D_","_C_")")=""
+34 if C
SET @(F_"1,0)")=U_$SELECT(PSGOEAV:55.07,1:53.11)_"P^"_C_U_C
+35 SET (C,Q)=0
FOR
SET Q=$ORDER(^PS(53.45,PSJSYSP,1,Q))
if 'Q
QUIT
SET X=$GET(^(Q,0))
if X]""
SET C=C+1
SET @(F_"3,"_C_",0)")=X
+36 if C
SET @(F_"3,0)")=U_$SELECT(PSGOEAV:55.08,1:53.12)_U_C_U_C
+37 IF $PIECE(ND,U,24)="R"
SET %X="^PS(55,"_PSGP_",5,"_+PSGORD_",12,"
SET %Y=F_"12,"
DO %XY^%RCR
+38 WRITE "."
if 'PSGOEAV
DO CRN
if PSGOEAV
DO CRA
+39 ;*399-IND
if 'PSGOEAV
SET ^PS(53.1,DA,18)=$GET(PSGIND)
if PSGOEAV
SET ^PS(55,PSGP,5,DA,18)=$GET(PSGIND)
+40 ; don't send message to CPRS if from Order Set and autoverify turned off
+41 ;; START NCC REMEDIATION >> 327*RJS
+42 NEW ARR,FOUND
DO FIND^DIC(53.1,,.01,"Q",PSGP,,"AC",,,"ARR")
+43 FOR I=2:1
if '$DATA(ARR("DILIST",2,I))
QUIT
IF ARR("DILIST",2,I)=DA
SET FOUND=1
+44 IF $GET(FOUND)!($$GET1^DIQ(55.06,+$GET(ND)_","_DFN,.01,"I"))
Begin DoDot:1
+45 IF +$GET(PSGCTDD)
NEW PSGTMP
SET PSGTDD=PSGCTDD
SET PSGTMP=DA
KILL PSGCTDD
+46 IF +$GET(PSGETDD)
NEW PSGTMP
SET PSGTDD=PSGETDD
SET PSGTMP=DA
KILL PSGETDD
+47 IF +$GET(PSGNTDD)
NEW PSGTMP
SET PSGTDD=PSGNTDD
SET PSGTMP=DA
KILL PSGNTDD
End DoDot:1
+48 IF +$GET(ND)["U"
SET PSGTMP=+$GET(ND)
+49 if '+$GET(PSGTMP)
SET PSGTMP=DA
+50 IF $GET(PSGTDD)
Begin DoDot:1
+51 ;/MZR changed the next line
+52 IF PSGOEAV
IF '$DATA(^TMP("PSJCOM",$JOB,DA))
SET ^TMP("PSJCOM",$JOB,DA,"SAND")=PSGTDD
+53 SET ^TMP($JOB,"PSGCLOZ",DFN,+$GET(PSGTMP),"SAND")=PSGTDD
KILL PSGTDD
End DoDot:1
+54 IF $GET(PSGETDD)
Begin DoDot:1
+55 IF 'PSGOEAV
IF '$DATA(^TMP("PSJCOM",$JOB,DA))
SET ^TMP("PSJCOM",$JOB,DA,"SAND")=PSGETDD
KILL PSGETDD
End DoDot:1
+56 ;; END NCC REMEDIATION >> 327*RJS
+57 SET PSGORD=DA_$SELECT(PSGOEAV:"U",1:"P")
+58 IF $GET(PSGOORD)
IF $DATA(PSGOEE)
NEW CLINAPPT
SET CLINAPPT=$SELECT(PSGOORD["U":$GET(^PS(55,PSGP,5,+PSGOORD,8)),PSGOORD["P":$GET(^PS(53.1,+PSGOORD,"DSS")),1:"")
IF CLINAPPT
Begin DoDot:1
+59 NEW DIE,DA,DR
+60 IF PSGORD["U"
SET DIE="^PS(55,"_PSGP_",5,"
SET DA=+PSGORD
SET DA(1)=PSGP
SET DR="130////"_+CLINAPPT_";"
if $PIECE(CLINAPPT,"^",2)
SET DR=DR_"131////"_$PIECE(CLINAPPT,"^",2)_";"
+61 IF PSGORD["P"
SET DIE="^PS(53.1,"
SET DA=+PSGORD
SET DR="113////"_+CLINAPPT_";"
if $PIECE(CLINAPPT,"^",2)
SET DR=DR_"126////"_$PIECE(CLINAPPT,"^",2)_";"
+62 IF $GET(DR)
DO ^DIE
End DoDot:1
+63 ;PSJ*319,jmc - Clinic Order
+64 IF ($GET(PSJCMO)!$GET(PSJCM01))
IF $DATA(PSJCLAPP)
NEW CLINAPPT
SET CLINAPPT=PSJCLAPP
IF CLINAPPT
Begin DoDot:1
+65 NEW DIE,DA,DR
+66 IF PSGORD["U"
SET DIE="^PS(55,"_PSGP_",5,"
SET DA=+PSGORD
SET DA(1)=PSGP
SET DR="130////"_+CLINAPPT_";"
if $PIECE(CLINAPPT,"^",2)
SET DR=DR_"131////"_$PIECE(CLINAPPT,"^",2)_";"
+67 IF PSGORD["P"
SET DIE="^PS(53.1,"
SET DA=+PSGORD
SET DR="113////"_+CLINAPPT_";"
if $PIECE(CLINAPPT,"^",2)
SET DR=DR_"126////"_$PIECE(CLINAPPT,"^",2)_";"
+68 IF $GET(DR)
DO ^DIE
End DoDot:1
+69 if ('$DATA(PSGOES))!(($DATA(PSGOES)&(PSGOEAV)))
DO ORSET^PSGOETO1
+70 IF $DATA(PSGOES)
IF '$DATA(PSGOESON)
NEW PSGOESON
SET PSGOESON=PSGORD
DO DISACTIO^PSJOE(DFN,PSGORD,0)
if PSGORD["U"&(PSGOESON=PSGORD)&($PIECE(@(PSGOEEWF_"0)"),"^",9)'="D")
DO EN^PSGPEN(PSGORD)
GOTO OUT
+71 DO DONE
SET PSGCANFL=""
IF '$DATA(PSGOEE)
SET PSJLM=1
SET PSGOEEF=0
DO GETUD^PSJLMGUD(PSGP,PSGORD)
DO ENSFE^PSGOEE0(PSGP,PSGORD)
DO EN^VALM("PSJ LM ACCEPT")
IF PSGCANFL=1
GOTO OUT
+72 IF $DATA(PSJSYSO)
SET PSGPOSA="W"
SET PSGPOSD=PSGDT
DO ENPOS^PSGVDS
+73 SET DA=+PSGORD
SET X=$PIECE(PSGORD,DA,2)
IF PSJSYSL
IF $SELECT(PSGOEAV:1,1:PSJSYSL<3)
IF $SELECT("AOU"[X:'$DATA(^PS(55,PSGP,5,+PSGORD,7)),1:'$DATA(^PS(53.1,+PSGORD,7)))
Begin DoDot:1
+74 ; naked ref below is from line above, ^PS(53.1,+PSGORD,7)
+75 SET $PIECE(^(7),U,1,2)=PSGDT_"^N"_$GET(PSGOEE)
SET PSGUOW=DUZ
SET PSGTOL=2
SET PSGTOO=$SELECT("AOU"[X:1,1:2)
DO ENL^PSGVDS
End DoDot:1
+76 DO STOREINT^PSGSICH1
OUT ;
+1 KILL PSGOETOF
+2 ; ** This is where the Automated Dispensing Machine hook is called. Do NOT DELETE or change location **
+3 DO NEWG^PSJADM
+4 ; ** END of Interface hook **
DONE ;
+1 IF PSGOEAV
LOCK -^PS(55,PSGP,5,+PSGORD)
+2 IF 'PSGOEAV
LOCK -^PS(53.1,+PSGORD)
+3 KILL C,D,ND,ND2,ND4,PSGDO,PSGDRG,PSGDRGN,PSGFOK,PSGHSM,PSGMR,PSGMRN,PSGNEDFD,PSGNEFD,PSGNESD,PSGPDRG,PSGPDRGN,PSGSI,PSGSTN,PSJDOSE,ND0,ND2P1,PSJCLAPP
+4 KILL ^PS(53.45,+$GET(DUZ),5)
+5 QUIT
CRA ;
+1 if PSGPDRG
SET ^PS(55,PSGP,5,"C",PSGPDRG,DA)=""
SET (^PS(55,"AUE",PSGP,DA),^PS(55,PSGP,5,"AU",PSGST,+PSGNEFD,DA),^PS(55,PSGP,5,"AUS",+PSGNEFD,DA))=""
SET ^PS(55,"AUD",+$PIECE(ND2,"^",4),PSGP,DA)=""
SET ^PS(55,"AUDS",+$PIECE(ND2,"^",2),PSGP,DA)=""
+2 IF $$PATCH^XPDUTL("PXRM*1.5*12")
SET X(1)=+PSGNESD
SET X(2)=+PSGNEFD
SET DA(1)=PSGP
DO SPSPA^PSJXRFS(.X,.DA,"UD")
+3 SET DA(1)=PSGP
KILL DIK
SET DIK="^PS(55,"_DA(1)_",5,"
SET DIK(1)=125
DO EN1^DIK
KILL DIK
+4 KILL PSGALO,PSGALR
SET DA(1)=PSGP
SET PSGAL("C")=PSJSYSU*10+$SELECT('$DATA(PSGOEE):22500,PSGOEE="E":22600,1:22700)
DO ^PSGAL5
QUIT
CRN ;
+1 SET (^PS(53.1,"AC",PSGP,DA),^PS(53.1,"AS","N",PSGP,DA),^PS(53.1,"B",DA,DA),^PS(53.1,"C",PSGP,DA))=""
if PSGPDRG
SET (^PS(53.1,"AOD",PSGP,PSGPDRG,DA),^PS(53.1,"D",PSGPDRG,DA))=""
QUIT
ENGNA ; Verified
+1 FOR
LOCK +^PS(55,PSGP,5,0):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)
if '$DATA(^PS(55,PSGP,0))
SET ^(0)=PSGP
SET ^PS(55,"B",PSGP,PSGP)=""
SET ND=$SELECT($DATA(^PS(55,PSGP,5,0)):^(0),1:"^55.06IA")
QUIT
+2 NEW PSGLCK
SET PSGLCK=0
+3 FOR DA=$PIECE(ND,U,3)+1:1
WRITE "."
IF '$DATA(^PS(55,PSGP,5,DA))
IF '$DATA(^PS(55,PSGP,5,"B",DA))
Begin DoDot:1
+4 LOCK +^PS(55,PSGP,5,DA):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)
IF $TEST
SET PSGLCK=1
End DoDot:1
IF PSGLCK
SET ^PS(55,PSGP,5,DA,0)=DA
SET ^PS(55,PSGP,5,"B",DA,DA)=""
SET $PIECE(ND,U,3)=DA
SET $PIECE(ND,U,4)=$PIECE(ND,U,4)+1
SET ^PS(55,PSGP,5,0)=ND
QUIT
+5 LOCK -^PS(55,PSGP,5,0)
QUIT
ENGNN ; Not Verified
+1 NEW ND
FOR
LOCK +^PS(59.7,1,25):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)
IF $TEST
SET DA=+$GET(^PS(59.7,1,25))
QUIT
+2 FOR DA=DA+1:1
IF '$DATA(^PS(53.1,DA))
IF '$DATA(^PS(53.1,"B",DA))
LOCK +^PS(53.1,DA):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)
IF $TEST
SET ^PS(59.7,1,25)=DA
SET ^PS(53.1,DA,0)=DA
SET ^PS(53.1,"B",DA,DA)=""
QUIT
+3 FOR
LOCK +^PS(53.1,0):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)
IF $TEST
SET ND=$GET(^PS(53.1,0))
SET $PIECE(ND,U,3)=DA
SET $PIECE(ND,U,4)=$PIECE(ND,U,4)+1
SET ^(0)=ND
QUIT
+4 LOCK -^PS(59.7,1,25),-^PS(53.1,0)
+5 IF $GET(PSIVCHG)
Begin DoDot:1
+6 NEW PSGORD,ON
SET ON=DA_"P"
DO SETIVINT^PSGSICH1
End DoDot:1
+7 QUIT
