PSJCOM1 ;BIR/CML3 - DISPLAY COMPLEX ORDERS FOR DISCONTINUE ; 10/18/19 2:40pm
;;5.0;INPATIENT MEDICATIONS;**110,127,281,315,327,393**;16 DEC 97;Build 5
;Per VHA Directive 2004-038, this routine should not be modified.
; Reference to ^VALM1 via DBIA 10116
; Reference to ^PS(55 via DBIA 2191
; Reference to ^%DTC via DBIA 10000
; Reference to ^PS(51.2 via DBIA 2178
; Reference to ^DIE via DBIA 10018
; Reference to ^DIR via DBIA 10026
; Reference to ^TMP("PSODAOC",$J) via DBIA 6071
;
CMPLX(PSGP,ON,PSGORD) ;
D PAUSE K PSJCM
N PSJLINE,PSX,PSCM
S PSJLINE=1
I PSGORD["P" N PSJO S PSJO=0 F S PSJO=$O(^PS(53.1,"ACX",ON,PSJO)) Q:'PSJO D
.Q:PSJO=+PSGORD S PSJOO=PSGORD D DSPLORDU(PSGP,PSJO_"P") S PSJCM(PSJO_"P",PSJLINE)="",PSJLINE=PSJLINE+1
I PSGORD'["P" N PSJO,PSJOO S PSJOO="",PSJO=0 F S PSJO=$O(^PS(55,"ACX",ON,PSJO)) Q:'PSJO F S PSJOO=$O(^PS(55,"ACX",ON,PSJO,PSJOO)) Q:PSJOO="" D
.Q:PSJOO=PSGORD D:PSJOO["U" DSPLORDU(PSGP,PSJOO) D:PSJOO["V" DSPLORDV(PSGP,PSJOO) S PSJCM(PSJOO,PSJLINE)="",PSJLINE=PSJLINE+1
N ON S ON="" F S ON=$O(PSJCM(ON)) Q:ON="" D
.W ! F PSX=0:0 S PSX=$O(PSJCM(ON,PSX)) Q:'PSX D
..W !,PSJCM(ON,PSX) D:'(PSX#6) PAUSE
W !
Q
;
CMPLX2(PSGP,ON,PSGORD) ;
Q:$G(PSGORD)'["U"
;; START NCC REMEDIATION >> 327*RJS
N CLOZFLG I PSGORD["U" S CLOZFLG=$$ISCLOZ^PSJCLOZ(,,PSGP,+PSGORD) I 1
E S CLOZFLG=$$ISCLOZ^PSJCLOZ(+PSGORD)
I CLOZFLG D
.N PSGDN S PSGDN=$P(CLOZFLG,U,2)
.D PSJFILE^PSJCLOZ(PSGP),INPSND^YSCLTST5 K:$D(^TMP($J,"CLOZFLG",PSGP)) ^TMP($J,"CLOZFLG",PSGP)
;; END NCC REMEDIATION >> 327*RJS
N PSJLINE S PSJLINE=0
D FULL^VALM1
D DSPLORDU(PSGP,PSGORD)
W ! S PSJLINE="" F S PSJLINE=$O(PSJCM(PSGORD,PSJLINE)) Q:PSJLINE="" W !,PSJCM(PSGORD,PSJLINE) D:'((PSJLINE+1)#6) PAUSE
D EN^PSGPEN(PSGORD)
S ^TMP("PSODAOC",$J,"IP IEN")=PSJO_"P",^TMP("PSODAOC",$J,"IP NEW IEN")=PSGORD
D SETOC^PSJNEWOC(PSGORD)
W !
Q
;
UPDATE ; Refresh array, actions, & display.
D GETUD^PSJLMGUD(DFN,ON),INIT^PSJLMUDE(DFN,ON) S VALMBCK="R"
Q
HOLDHDR ; Freeze header text while processing order actions
I $D(VALM("TM")) S IOTM=VALM("TM"),IOBM=IOSL W IOSC W @IOSTBM W IORC
Q
;
DSPLORDU(PSGP,ON) ; Display UD order for order check as in the Inpat Profile.
NEW DRUGNAME,F,NODE0,NODE2,PSJID,PSJX,SCH,SD,STAT,X,Y K PSJCM
S F=$S(ON["U":"^PS(55,PSGP,5,"_+ON_",",1:"^PS(53.1,"_+ON_",")
S NODE0=$G(@(F_"0)")),NODE2=$G(@(F_"2)"))
D DRGDISP^PSJLMUT1(PSGP,ON,39,54,.DRUGNAME,0)
I ON["P",$P(NODE0,U,4)="F" D DSPLORDV(PSGP,ON) Q
S SCH=$P(NODE0,U,7)
S STAT=$P(NODE0,U,9)
D NOW^%DTC I "A"[STAT I $P(NODE2,U,4)<% D EXPIRE S STAT="E"
I STAT="A",$P(NODE0,U,27)="R" S STAT="R"
I STAT'="P" S PSJID=$E($$ENDTC^PSGMI($P(NODE2,U,2)),1,5),SD=$E($$ENDTC^PSGMI($P(NODE2,U,4)),1,5)
I STAT="P" S (PSJID,SD)="*****",SCH="?"
I $G(PSGPDN)["CLOZ" N PSGORD S PSGORD=+$G(NODE0),PSSD="" D DISPCMP^PSJCLOZ(PSGORD,.PSSD) I $G(PSSD) S SD=$E($$ENDTC^PSGMI(PSSD),1,5) K PSSD
F PSJX=0:0 S PSJX=$O(DRUGNAME(PSJX)) Q:'PSJX D
. S:PSJX=1 X=SCH_" "_PSJID_" "_SD_" "_$E(STAT,1)
. S:PSJX=1 DRUGNAME(1)=$$SETSTR^VALM1(X,$E(DRUGNAME(1),1,40),42,20)
. S PSJCM(ON,PSJLINE)=" "_DRUGNAME(PSJX)
. S PSJLINE=PSJLINE+1
Q
DSPLORDV(DFN,ON) ; Display IV order for order check as in the Inpat Profile.
N DRG,DRGI,DRGT,DRGX,FIL,ND,ON55,P,PSJIVFLG,PSJORIFN,TYP,X,Y
S TYP="?" I ON["V" D
.S Y=$G(^PS(55,DFN,"IV",+ON,0)) F X=2,3,4,5,8,9,17,23 S P(X)=$P(Y,U,X)
.D NOW^%DTC I "A"[P(17) I P(3)<% D EXPIRE S P(17)="E"
.S TYP=$$ONE^PSJBCMA(DFN,ON,P(9),P(2),P(3)) I TYP'="O" S TYP="C"
.S ON55=ON,P("OT")=$S(P(4)="A":"F",P(4)="H":"H",1:"I") D GTDRG^PSIVORFB,GTOT^PSIVUTL(P(4))
S PSJCT=0,PSJL=""
I ON'["V" S (P(2),P(3))="",P(17)=$P($G(^PS(53.1,+ON,0)),U,9),Y=$G(^(8)),P(4)=$P(Y,U),P(8)=$P(Y,U,5),P(9)=$P($G(^(2)),U) D GTDRG^PSIVORFA,GTOT^PSIVUTL(P(4))
S PSJIVFLG=1 D PIVAD,SOL
Q
SOL ;
S PSJL=$S($G(PSJIVFLG):PSJL,1:"")_" in"
S DRG=0 F S DRG=+$O(DRG("SOL",DRG)) Q:'DRG D NAME^PSIVUTL(DRG("SOL",DRG),39,.NAME,0) S DRGX=0 F S DRGX=$O(NAME(DRGX)) Q:'DRGX S PSJL=$$SETSTR^VALM1(NAME(DRGX),PSJL,12,60) D:$G(PSJIVFLG) PIV1 D SETTMP S PSJL=" "
Q
PIVAD ; Print IV Additives.
F DRG=0:0 S DRG=$O(DRG("AD",DRG)) Q:'DRG D NAME^PSIVUTL(DRG("AD",DRG),39,.NAME,1) F DRGX=0:0 S DRGX=$O(NAME(DRGX)) Q:'DRGX S PSJL=$$SETSTR^VALM1(NAME(DRGX),PSJL,9,60) D:$G(PSJIVFLG) PIV1 D SETTMP
Q
;
PIV1 ; Print Sched type, start/stop dates, and status.
K PSJIVFLG
F X=2,3 S P(X)=$E($$ENDTC^PSGMI(P(X)),1,$S($D(PSJEXTP):8,1:5))
I '$D(PSJEXTP) S PSJL=$$SETSTR^VALM1(TYP,PSJL,50,1),PSJL=$$SETSTR^VALM1(P(2),PSJL,53,7),PSJL=$$SETSTR^VALM1(P(3),PSJL,60,7),PSJL=$$SETSTR^VALM1(P(17),PSJL,67,1)
E S PSJL=$$SETSTR^VALM1(TYP,PSJL,50,1),PSJL=$$SETSTR^VALM1(P(2),53,7),PSJL=$$SETSTR^VALM1(P(3),PSJL,63,7),PSJL=$$SETSTR^VALM1(P(17),PSJL,73,1)
Q
SETTMP ;
S PSJCM(ON,PSJLINE)=PSJL,PSJLINE=PSJLINE+1
Q
PAUSE ;
K DIR W ! S DIR(0)="EA",DIR("A")="Press Return to continue..." D ^DIR W !
Q
NEW ;
Q:'PSJCOM
Q:PSGORD'["P"
M ^TMP("PSJCOM",$J,+PSGORD)=^PS(53.1,+PSGORD)
S PSGS0Y=PSGAT,PSGNESD=PSGSD,PSGNEFD=PSGFD,PSGOEPR=PSGPR,PSGPDRG=PSGPD,PSGPDRGN=PSGPDN,PSGOEE="E"
S $P(^TMP("PSJCOM",$J,+PSGORD,0),"^",27)="E",$P(^(0),"^",9)="DE"
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 NOW^%DTC S PSGDT=+$E(%,1,12),DA=+PSGORD
S PSJOWALL=+$G(^PS(55,PSGP,5.1))
I $D(^PS(51.2,+PSGMR,0)),$P(^(0),U,3)]"" S PSGMRN=$P(^(0),U,3)
I PSGS0XT="D",'PSGS0Y S PSGS0Y=$E(PSGNESD_"00011",9,12)
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_PSGORD S:'PSGOEAV $P(ND,U,18)=DA S ND2=PSGSCH_U_$S(+PSGNESD=PSGNESD:+PSGNESD,1:"")_"^^"_+PSGNEFD_U_PSGS0Y_U_PSGS0XT_"^^^^"_+PSJPWD
S:$G(PSGRF)]"" ND2P1=$G(PSGDUR)_U_$G(PSGRMVT)_U_$G(PSGRMV)_U_$G(PSGRF) ;*315
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)
S F="^TMP(""PSJCOM2"","_$J_","_DA_",",@(F_"0)")=ND
; Naked references below refers to full reference in F which is ^TMP("PSJCOM2",$J,DA,
S @(F_".2)")=PSGPDRG_U_PSGDO_U_PSJNOO S:$G(PSJDOSE("DO"))]"" $P(^(.2),U,5,6)=$P(PSJDOSE("DO"),U,1,2) S:PSJCOM]"" $P(^(.2),"^",8)=PSJCOM
I '$D(PSJDOSE("DO")),$D(PSGORD) S $P(@(F_".2)"),U,5,6)=$P(@("^PS("_$S(PSGORD["U":"55,"_PSGP_",5",1:53.1)_","_+PSGORD_",.2)"),U,5,6)
; Naked references below refers to full reference in F which is ^TMP("PSJCOM2",$J,DA,
S @(F_"2)")=$P(ND2,"^",1,6),^(4)=ND4 S:PSGSI]"" ^(6)=PSGSI
I $G(PSGRF)]"" S @(F_"2.1)")=ND2P1 ;*315
; Naked references below refers to full reference in F which is ^TMP("PSJCOM2",$J,DA,
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
; Naked references below refers to full reference in F which is ^TMP("PSJCOM2",$J,DA,
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
S:C @(F_"12,0)")=U_$S(PSGOEAV:55.0612,1:53.1012)_U_C_U_C
W "."
OUT ;
K PSGOETOF
DONE ;
K C,D,ND,ND2,ND2P1,ND4,PSGDO,PSGDRG,PSGDRGN,PSGFOK,PSGHSM,PSGMR,PSGMRN,PSGNEDFD,PSGNEFD,PSGNESD,PSGPDRG,PSGPDRGN,PSGSI,PSGSTN,PSJDOSE,%,Q
Q
EXPIRE ;Change status of order to expired and send notice to OE/RR
N DA,DIE,DR,PSGPO,PSIVACT
Q:'$G(PSJOO)!($G(PSJOO)["P")
S STATUS="E",(PSGPO,PSIVACT)=1,DA=+PSJOO,DA(1)=PSGP,DIE=$S(PSJOO["V":"^PS(55,"_PSGP_",""IV"",",1:"^PS(55,"_PSGP_",5,"),DR=$S(PSJOO["V":"100////E",1:"28////E") D ^DIE
D EN1^PSJHL2(PSGP,"SC",PSJOO)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSJCOM1 8031 printed Sep 23, 2025@19:42:37 Page 2
PSJCOM1 ;BIR/CML3 - DISPLAY COMPLEX ORDERS FOR DISCONTINUE ; 10/18/19 2:40pm
+1 ;;5.0;INPATIENT MEDICATIONS;**110,127,281,315,327,393**;16 DEC 97;Build 5
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 ; Reference to ^VALM1 via DBIA 10116
+4 ; Reference to ^PS(55 via DBIA 2191
+5 ; Reference to ^%DTC via DBIA 10000
+6 ; Reference to ^PS(51.2 via DBIA 2178
+7 ; Reference to ^DIE via DBIA 10018
+8 ; Reference to ^DIR via DBIA 10026
+9 ; Reference to ^TMP("PSODAOC",$J) via DBIA 6071
+10 ;
CMPLX(PSGP,ON,PSGORD) ;
+1 DO PAUSE
KILL PSJCM
+2 NEW PSJLINE,PSX,PSCM
+3 SET PSJLINE=1
+4 IF PSGORD["P"
NEW PSJO
SET PSJO=0
FOR
SET PSJO=$ORDER(^PS(53.1,"ACX",ON,PSJO))
if 'PSJO
QUIT
Begin DoDot:1
+5 if PSJO=+PSGORD
QUIT
SET PSJOO=PSGORD
DO DSPLORDU(PSGP,PSJO_"P")
SET PSJCM(PSJO_"P",PSJLINE)=""
SET PSJLINE=PSJLINE+1
End DoDot:1
+6 IF PSGORD'["P"
NEW PSJO,PSJOO
SET PSJOO=""
SET PSJO=0
FOR
SET PSJO=$ORDER(^PS(55,"ACX",ON,PSJO))
if 'PSJO
QUIT
FOR
SET PSJOO=$ORDER(^PS(55,"ACX",ON,PSJO,PSJOO))
if PSJOO=""
QUIT
Begin DoDot:1
+7 if PSJOO=PSGORD
QUIT
if PSJOO["U"
DO DSPLORDU(PSGP,PSJOO)
if PSJOO["V"
DO DSPLORDV(PSGP,PSJOO)
SET PSJCM(PSJOO,PSJLINE)=""
SET PSJLINE=PSJLINE+1
End DoDot:1
+8 NEW ON
SET ON=""
FOR
SET ON=$ORDER(PSJCM(ON))
if ON=""
QUIT
Begin DoDot:1
+9 WRITE !
FOR PSX=0:0
SET PSX=$ORDER(PSJCM(ON,PSX))
if 'PSX
QUIT
Begin DoDot:2
+10 WRITE !,PSJCM(ON,PSX)
if '(PSX#6)
DO PAUSE
End DoDot:2
End DoDot:1
+11 WRITE !
+12 QUIT
+13 ;
CMPLX2(PSGP,ON,PSGORD) ;
+1 if $GET(PSGORD)'["U"
QUIT
+2 ;; START NCC REMEDIATION >> 327*RJS
+3 NEW CLOZFLG
IF PSGORD["U"
SET CLOZFLG=$$ISCLOZ^PSJCLOZ(,,PSGP,+PSGORD)
IF 1
+4 IF '$TEST
SET CLOZFLG=$$ISCLOZ^PSJCLOZ(+PSGORD)
+5 IF CLOZFLG
Begin DoDot:1
+6 NEW PSGDN
SET PSGDN=$PIECE(CLOZFLG,U,2)
+7 DO PSJFILE^PSJCLOZ(PSGP)
DO INPSND^YSCLTST5
if $DATA(^TMP($JOB,"CLOZFLG",PSGP))
KILL ^TMP($JOB,"CLOZFLG",PSGP)
End DoDot:1
+8 ;; END NCC REMEDIATION >> 327*RJS
+9 NEW PSJLINE
SET PSJLINE=0
+10 DO FULL^VALM1
+11 DO DSPLORDU(PSGP,PSGORD)
+12 WRITE !
SET PSJLINE=""
FOR
SET PSJLINE=$ORDER(PSJCM(PSGORD,PSJLINE))
if PSJLINE=""
QUIT
WRITE !,PSJCM(PSGORD,PSJLINE)
if '((PSJLINE+1)#6)
DO PAUSE
+13 DO EN^PSGPEN(PSGORD)
+14 SET ^TMP("PSODAOC",$JOB,"IP IEN")=PSJO_"P"
SET ^TMP("PSODAOC",$JOB,"IP NEW IEN")=PSGORD
+15 DO SETOC^PSJNEWOC(PSGORD)
+16 WRITE !
+17 QUIT
+18 ;
UPDATE ; Refresh array, actions, & display.
+1 DO GETUD^PSJLMGUD(DFN,ON)
DO INIT^PSJLMUDE(DFN,ON)
SET VALMBCK="R"
+2 QUIT
HOLDHDR ; Freeze header text while processing order actions
+1 IF $DATA(VALM("TM"))
SET IOTM=VALM("TM")
SET IOBM=IOSL
WRITE IOSC
WRITE @IOSTBM
WRITE IORC
+2 QUIT
+3 ;
DSPLORDU(PSGP,ON) ; Display UD order for order check as in the Inpat Profile.
+1 NEW DRUGNAME,F,NODE0,NODE2,PSJID,PSJX,SCH,SD,STAT,X,Y
KILL PSJCM
+2 SET F=$SELECT(ON["U":"^PS(55,PSGP,5,"_+ON_",",1:"^PS(53.1,"_+ON_",")
+3 SET NODE0=$GET(@(F_"0)"))
SET NODE2=$GET(@(F_"2)"))
+4 DO DRGDISP^PSJLMUT1(PSGP,ON,39,54,.DRUGNAME,0)
+5 IF ON["P"
IF $PIECE(NODE0,U,4)="F"
DO DSPLORDV(PSGP,ON)
QUIT
+6 SET SCH=$PIECE(NODE0,U,7)
+7 SET STAT=$PIECE(NODE0,U,9)
+8 DO NOW^%DTC
IF "A"[STAT
IF $PIECE(NODE2,U,4)<%
DO EXPIRE
SET STAT="E"
+9 IF STAT="A"
IF $PIECE(NODE0,U,27)="R"
SET STAT="R"
+10 IF STAT'="P"
SET PSJID=$EXTRACT($$ENDTC^PSGMI($PIECE(NODE2,U,2)),1,5)
SET SD=$EXTRACT($$ENDTC^PSGMI($PIECE(NODE2,U,4)),1,5)
+11 IF STAT="P"
SET (PSJID,SD)="*****"
SET SCH="?"
+12 IF $GET(PSGPDN)["CLOZ"
NEW PSGORD
SET PSGORD=+$GET(NODE0)
SET PSSD=""
DO DISPCMP^PSJCLOZ(PSGORD,.PSSD)
IF $GET(PSSD)
SET SD=$EXTRACT($$ENDTC^PSGMI(PSSD),1,5)
KILL PSSD
+13 FOR PSJX=0:0
SET PSJX=$ORDER(DRUGNAME(PSJX))
if 'PSJX
QUIT
Begin DoDot:1
+14 if PSJX=1
SET X=SCH_" "_PSJID_" "_SD_" "_$EXTRACT(STAT,1)
+15 if PSJX=1
SET DRUGNAME(1)=$$SETSTR^VALM1(X,$EXTRACT(DRUGNAME(1),1,40),42,20)
+16 SET PSJCM(ON,PSJLINE)=" "_DRUGNAME(PSJX)
+17 SET PSJLINE=PSJLINE+1
End DoDot:1
+18 QUIT
DSPLORDV(DFN,ON) ; Display IV order for order check as in the Inpat Profile.
+1 NEW DRG,DRGI,DRGT,DRGX,FIL,ND,ON55,P,PSJIVFLG,PSJORIFN,TYP,X,Y
+2 SET TYP="?"
IF ON["V"
Begin DoDot:1
+3 SET Y=$GET(^PS(55,DFN,"IV",+ON,0))
FOR X=2,3,4,5,8,9,17,23
SET P(X)=$PIECE(Y,U,X)
+4 DO NOW^%DTC
IF "A"[P(17)
IF P(3)<%
DO EXPIRE
SET P(17)="E"
+5 SET TYP=$$ONE^PSJBCMA(DFN,ON,P(9),P(2),P(3))
IF TYP'="O"
SET TYP="C"
+6 SET ON55=ON
SET P("OT")=$SELECT(P(4)="A":"F",P(4)="H":"H",1:"I")
DO GTDRG^PSIVORFB
DO GTOT^PSIVUTL(P(4))
End DoDot:1
+7 SET PSJCT=0
SET PSJL=""
+8 IF ON'["V"
SET (P(2),P(3))=""
SET P(17)=$PIECE($GET(^PS(53.1,+ON,0)),U,9)
SET Y=$GET(^(8))
SET P(4)=$PIECE(Y,U)
SET P(8)=$PIECE(Y,U,5)
SET P(9)=$PIECE($GET(^(2)),U)
DO GTDRG^PSIVORFA
DO GTOT^PSIVUTL(P(4))
+9 SET PSJIVFLG=1
DO PIVAD
DO SOL
+10 QUIT
SOL ;
+1 SET PSJL=$SELECT($GET(PSJIVFLG):PSJL,1:"")_" in"
+2 SET DRG=0
FOR
SET DRG=+$ORDER(DRG("SOL",DRG))
if 'DRG
QUIT
DO NAME^PSIVUTL(DRG("SOL",DRG),39,.NAME,0)
SET DRGX=0
FOR
SET DRGX=$ORDER(NAME(DRGX))
if 'DRGX
QUIT
SET PSJL=$$SETSTR^VALM1(NAME(DRGX),PSJL,12,60)
if $GET(PSJIVFLG)
DO PIV1
DO SETTMP
SET PSJL=" "
+3 QUIT
PIVAD ; Print IV Additives.
+1 FOR DRG=0:0
SET DRG=$ORDER(DRG("AD",DRG))
if 'DRG
QUIT
DO NAME^PSIVUTL(DRG("AD",DRG),39,.NAME,1)
FOR DRGX=0:0
SET DRGX=$ORDER(NAME(DRGX))
if 'DRGX
QUIT
SET PSJL=$$SETSTR^VALM1(NAME(DRGX),PSJL,9,60)
if $GET(PSJIVFLG)
DO PIV1
DO SETTMP
+2 QUIT
+3 ;
PIV1 ; Print Sched type, start/stop dates, and status.
+1 KILL PSJIVFLG
+2 FOR X=2,3
SET P(X)=$EXTRACT($$ENDTC^PSGMI(P(X)),1,$SELECT($DATA(PSJEXTP):8,1:5))
+3 IF '$DATA(PSJEXTP)
SET PSJL=$$SETSTR^VALM1(TYP,PSJL,50,1)
SET PSJL=$$SETSTR^VALM1(P(2),PSJL,53,7)
SET PSJL=$$SETSTR^VALM1(P(3),PSJL,60,7)
SET PSJL=$$SETSTR^VALM1(P(17),PSJL,67,1)
+4 IF '$TEST
SET PSJL=$$SETSTR^VALM1(TYP,PSJL,50,1)
SET PSJL=$$SETSTR^VALM1(P(2),53,7)
SET PSJL=$$SETSTR^VALM1(P(3),PSJL,63,7)
SET PSJL=$$SETSTR^VALM1(P(17),PSJL,73,1)
+5 QUIT
SETTMP ;
+1 SET PSJCM(ON,PSJLINE)=PSJL
SET PSJLINE=PSJLINE+1
+2 QUIT
PAUSE ;
+1 KILL DIR
WRITE !
SET DIR(0)="EA"
SET DIR("A")="Press Return to continue..."
DO ^DIR
WRITE !
+2 QUIT
NEW ;
+1 if 'PSJCOM
QUIT
+2 if PSGORD'["P"
QUIT
+3 MERGE ^TMP("PSJCOM",$JOB,+PSGORD)=^PS(53.1,+PSGORD)
+4 SET PSGS0Y=PSGAT
SET PSGNESD=PSGSD
SET PSGNEFD=PSGFD
SET PSGOEPR=PSGPR
SET PSGPDRG=PSGPD
SET PSGPDRGN=PSGPDN
SET PSGOEE="E"
+5 SET $PIECE(^TMP("PSJCOM",$JOB,+PSGORD,0),"^",27)="E"
SET $PIECE(^(0),"^",9)="DE"
+6 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
+7 ;I PSGPR'=PSGOEPR D:'$D(^PS(55,PSGP,0)) ENSET0^PSGNE3(PSGP) S $P(^PS(55,PSGP,5.1),U,2)=PSGPR,PSGOEPR=PSGPR
+8 KILL ND4,DA
DO NOW^%DTC
SET PSGDT=+$EXTRACT(%,1,12)
SET DA=+PSGORD
+9 SET PSJOWALL=+$GET(^PS(55,PSGP,5.1))
+10 IF $DATA(^PS(51.2,+PSGMR,0))
IF $PIECE(^(0),U,3)]""
SET PSGMRN=$PIECE(^(0),U,3)
+11 IF PSGS0XT="D"
IF 'PSGS0Y
SET PSGS0Y=$EXTRACT(PSGNESD_"00011",9,12)
+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 if $DATA(PSGOEE)
SET $PIECE(ND,U,24,25)=PSGOEE_U_PSGORD
if 'PSGOEAV
SET $PIECE(ND,U,18)=DA
SET ND2=PSGSCH_U_$SELECT(+PSGNESD=PSGNESD:+PSGNESD,1:"")_"^^"_+PSGNEFD_U_PSGS0Y_U_PSGS0XT_"^^^^"_+PSJPWD
+14 ;*315
if $GET(PSGRF)]""
SET ND2P1=$GET(PSGDUR)_U_$GET(PSGRMVT)_U_$GET(PSGRMV)_U_$GET(PSGRF)
+15 SET $PIECE(ND4,U,7)=DUZ
IF PSGOEAV
IF PSJSYSU
Begin DoDot:1
+16 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
+17 SET $PIECE(ND4,U,9,10)=+$PIECE(ND4,U,9)_U_+$PIECE(ND4,U,10)
End DoDot:1
+18 SET F="^TMP(""PSJCOM2"","_$JOB_","_DA_","
SET @(F_"0)")=ND
+19 ; Naked references below refers to full reference in F which is ^TMP("PSJCOM2",$J,DA,
+20 SET @(F_".2)")=PSGPDRG_U_PSGDO_U_PSJNOO
if $GET(PSJDOSE("DO"))]""
SET $PIECE(^(.2),U,5,6)=$PIECE(PSJDOSE("DO"),U,1,2)
if PSJCOM]""
SET $PIECE(^(.2),"^",8)=PSJCOM
+21 IF '$DATA(PSJDOSE("DO"))
IF $DATA(PSGORD)
SET $PIECE(@(F_".2)"),U,5,6)=$PIECE(@("^PS("_$SELECT(PSGORD["U":"55,"_PSGP_",5",1:53.1)_","_+PSGORD_",.2)"),U,5,6)
+22 ; Naked references below refers to full reference in F which is ^TMP("PSJCOM2",$J,DA,
+23 SET @(F_"2)")=$PIECE(ND2,"^",1,6)
SET ^(4)=ND4
if PSGSI]""
SET ^(6)=PSGSI
+24 ;*315
IF $GET(PSGRF)]""
SET @(F_"2.1)")=ND2P1
+25 ; Naked references below refers to full reference in F which is ^TMP("PSJCOM2",$J,DA,
+26 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_")")=""
+27 if C
SET @(F_"1,0)")=U_$SELECT(PSGOEAV:55.07,1:53.11)_"P^"_C_U_C
+28 ; Naked references below refers to full reference in F which is ^TMP("PSJCOM2",$J,DA,
+29 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
+30 if C
SET @(F_"3,0)")=U_$SELECT(PSGOEAV:55.08,1:53.12)_U_C_U_C
+31 if C
SET @(F_"12,0)")=U_$SELECT(PSGOEAV:55.0612,1:53.1012)_U_C_U_C
+32 WRITE "."
OUT ;
+1 KILL PSGOETOF
DONE ;
+1 KILL C,D,ND,ND2,ND2P1,ND4,PSGDO,PSGDRG,PSGDRGN,PSGFOK,PSGHSM,PSGMR,PSGMRN,PSGNEDFD,PSGNEFD,PSGNESD,PSGPDRG,PSGPDRGN,PSGSI,PSGSTN,PSJDOSE,%,Q
+2 QUIT
EXPIRE ;Change status of order to expired and send notice to OE/RR
+1 NEW DA,DIE,DR,PSGPO,PSIVACT
+2 if '$GET(PSJOO)!($GET(PSJOO)["P")
QUIT
+3 SET STATUS="E"
SET (PSGPO,PSIVACT)=1
SET DA=+PSJOO
SET DA(1)=PSGP
SET DIE=$SELECT(PSJOO["V":"^PS(55,"_PSGP_",""IV"",",1:"^PS(55,"_PSGP_",5,")
SET DR=$SELECT(PSJOO["V":"100////E",1:"28////E")
DO ^DIE
+4 DO EN1^PSJHL2(PSGP,"SC",PSJOO)
+5 QUIT
