PSJCLOR2 ;BIR/JCH - BUILD CLINIC ORDER LM HEADERS ; 2/28/12 9:11am
;;5.0;INPATIENT MEDICATIONS;**275,279,315,256,387**;16 DEC 97;Build 1
;;Per VHA Directive 2004-038, this routine should not be modified.
; Reference to ^PS(55 is supported by DBIA 2191
; Reference to CWAD^ORQPT2 is supported by DBIA 2831
; Reference to ^SC( is supported by DBIA 10040
; Reference to BSA^PSSDSAPI supported by DBIA #5425
; Reference to LS^PSSLOCK supported by DBIA #2789
; Reference to UNL^PSSLOCK supported by DBIA #2789
;
HDR(DFN) ; -- list screen header
; input: DFN := ifn of pat
; output: VALMHDR() := hdr array
;
K VAIN,VADM,GMRA,PSJACNWP,PSJ,VAERR,VA,X
S PSJACNWP=1 D ENBOTH^PSJAC
D HDRO(DFN)
S PSJ=" Sex: "_$P(PSJPSEX,U,2),VALMHDR(4)=$$SETSTR^VALM1($S(PSJPDD:"Last ",1:" ")_"Admitted: "_$P($G(PSJPAD),U,2),PSJ,45,23)
S PSJ=" Dx: "_$G(PSJPDX)
S:PSJPDD VALMHDR(5)=$$SETSTR^VALM1("Discharged: "_$E($P(PSJPDD,U,2),1,8),PSJ,48,26)
S:'PSJPDD VALMHDR(5)=$$SETSTR^VALM1("Last transferred: "_$$ENDTC^PSGMI(PSJPTD),PSJ,42,26)
;
; Display CrCl/BSA - show serum creatinine if CrCl can't be calculated
S PSJBSA=$$BSA^PSSDSAPI(DFN),PSJBSA=$P(PSJBSA,"^",3),PSJBSA=$S(PSJBSA'>0:"__________",1:$J(PSJBSA,4,2))
; RSLT -- DATE^CRCL^Serum Creatinine -- Ex. 11/25/11^68.7^1.1
S RSLT=$$CRCL^PSJLMHED(DFN)
; Display format of CrCL and Creatinine results updated - PSJ*5.0*387
I ($P($G(RSLT),"^",2)["Not Found")&($P($G(RSLT),"^",3)<.01) S ZDSPL=" CrCL: "_$P(RSLT,"^",2)_" (CREAT: Not Found)"
I ($P($G(RSLT),"^",2)["Not Found")&($P($G(RSLT),"^",3)>=.01) S ZDSPL=" CrCL: "_$P(RSLT,"^",2)_" (CREAT: "_$P($G(RSLT),"^",3)_"mg/dL "_$P($G(RSLT),"^")_")"
I ($P($G(RSLT),"^",2)'["Not Found")&($P($G(RSLT),"^",3)<.01) S ZDSPL=" CrCL: "_$P(RSLT,"^",2)_" (CREAT: Not Found)"
I ($P($G(RSLT),"^",2)'["Not Found")&($P($G(RSLT),"^",3)>=.01) S ZDSPL=" CrCL: "_$P(RSLT,"^",2)_"(est.)"_" (CREAT: "_$P($G(RSLT),"^",3)_"mg/dL "_$P($G(RSLT),"^")_")"
S PSJDB=$G(ZDSPL),VALMHDR(6)=$$SETSTR^VALM1("BSA (m2): "_$G(PSJBSA),PSJDB,50,23) K PSJBSA,ZDSPL,RSLT
Q
;
HDRO(DFN) ; Standardized part of profile header.
N PSJCLIN,PSJAPPT,PSJCLINN,RMORDT S (PSJCLIN,PSJAPPT)=0,(RMORDT,PSJCLINN)="" I $G(PSJORD) D
. S PSJCLIN=$S($G(PSJORD)["V":$G(^PS(55,DFN,"IV",+PSJORD,"DSS")),$G(PSJORD)["U":$G(^PS(55,DFN,5,+PSJORD,8)),$G(PSJORD)["P":$G(^PS(53.1,+PSJORD,"DSS")),1:"")
. S:PSJCLIN PSJAPPT=$P($G(PSJCLIN),U,2) I PSJCLIN,PSJAPPT S PSJCLINN=$P($G(^SC(+PSJCLIN,0)),U)
K VALMHDR I PSJCLINN]"" S PSJ=VADM(1),PSJ=$$SETSTR^VALM1(" Clinic: "_PSJCLINN,PSJ,28,26)
I PSJCLINN="" S PSJ=VADM(1),PSJ=$$SETSTR^VALM1($S('PSJPDD:" ",1:"Last ")_"Ward: "_PSJPWDN,PSJ,30,18)
S X=$$CWAD^ORQPT2(DFN)
S:X]"" X=$G(IORVON)_X_$G(IORVOFF),PSJ=$$SETSTR^VALM1(X,PSJ,80-$L(X),80) S VALMHDR(1)=PSJ
S PSJ=" PID: "_$P(PSJPSSN,U,2)
S RMORDT=$S($G(PSJPDD):"Last ",1:" ")_"Room-Bed: "_$G(PSJPRB)
I PSJCLINN]"",PSJAPPT S RMORDT="Clinic Date: "_$$ENDTC^PSGMI(PSJAPPT),RMORDT=$P(RMORDT," ")_" "_$P(RMORDT," ",2)
S PSJ=$$SETSTR^VALM1(RMORDT,PSJ,26,28),VALMHDR(2)=$$SETSTR^VALM1("Ht(cm): "_PSJPHT_" "_PSJPHTD,PSJ,55,25)
S PSJ=" DOB: "_$P($P(PSJPDOB,U,2)," ")_" ("_PSJPAGE_")",VALMHDR(3)=$$SETSTR^VALM1("Wt(kg): "_PSJPWT_" "_PSJPWTD,PSJ,55,25)
Q
;
INIT(PSJPROT) ; -- init bld vars
; PSJPROT=1:UD ONLY; 2:IV ONLY; 3:BOTH
K PSJUDPRF,^TMP("PSJ",$J),^TMP("PSJON",$J),^TMP("PSJPRO",$J),^TMP("PSJCLOR",$J) D FULL^VALM1
N TMPCLIN,DFN,UDU S PSJVALQ=0,TMPCLIN="",DFN=PSGP,PSGSSAV=PSGSS,UDU=$S($P(PSJSYSU,";",3)>1:3,1:1)
S:PSJPROT=1 PSJUDPRF=1
D KILL^VALM10(),EN^PSJCLOR3(PSJPROT)
I '$D(^TMP("PSJ",$J)) W !!,?22,"NO CLINIC ORDERS FOUND." S VALMQUIT=1,PSJVALQ=1 D PAUSE^PSJLMUTL Q
S PSJLN=1,PSJEN=1 S PSJCLIN="" F S PSJCLIN=$O(^TMP("PSJ",$J,PSJCLIN)) Q:PSJCLIN="" S PSJTF=0,PSJC="" F S PSJC=$O(^TMP("PSJ",$J,PSJCLIN,PSJC)) Q:PSJC="" D
.N PSJF S PSJF="^PS("_$S("AO"[PSJC:"55,"_PSGP_",5,",PSJC="DF":"55,"_PSGP_",5,",1:"53.1,")
.I TMPCLIN'=PSJCLIN D TF S PSJTF=$E(PSJC,1),TMPCLIN=PSJCLIN ;DAM 8-29-07 Added Q:PSJC="CB" Q:PSJC="O"
.S PSJST="" F S PSJST=$O(^TMP("PSJ",$J,PSJCLIN,PSJC,PSJST)) Q:PSJST="" D
..S PSJS="" F S PSJS=$O(^TMP("PSJ",$J,PSJCLIN,PSJC,PSJST,PSJS)) Q:PSJS="" Q:PSJC="CB" Q:PSJC="O" Q:PSJC="DF" D ON ;DAM 8-29-07 Added Q:PSJC="CB" Q:PSJC="O"
.;
.;DAM 8-29-07 New code to place Pending Orders after Pending Renewal Orders on the roll and scroll display. Non-Active Orders appear last.
S PSJCLIN="" F S PSJCLIN=$O(^TMP("PSJ",$J,PSJCLIN)) Q:PSJCLIN="" S PSJTF=0,PSJC="" F S PSJC=$O(^TMP("PSJ",$J,PSJCLIN,PSJC)) Q:PSJC="" D
. N PSJF S PSJF="^PS("_$S("AO"[PSJC:"55,"_PSGP_",5,",PSJC="DF":"55,"_PSGP_",5,",1:"53.1,")
. I PSJC="CB" I TMPCLIN'=PSJCLIN D TF S PSJTF=$E(PSJC,1),TMPCLIN=PSJCLIN ;These are Pending Orders
. I PSJC="CB" S PSJST="" F S PSJST=$O(^TMP("PSJ",$J,PSJCLIN,PSJC,PSJST)) Q:PSJST="" D
. . S PSJS="" F S PSJS=$O(^TMP("PSJ",$J,PSJCLIN,PSJC,PSJST,PSJS)) Q:PSJS="" D ON
. I PSJC="DF" I TMPCLIN'=PSJCLIN D TF S PSJTF=$E(PSJC,1),TMPCLIN=PSJCLIN ;These are recently DC Orders (mv)
. I PSJC="DF" S PSJST="" F S PSJST=$O(^TMP("PSJ",$J,PSJCLIN,PSJC,PSJST)) Q:PSJST="" D
. . S PSJS="" F S PSJS=$O(^TMP("PSJ",$J,PSJCLIN,PSJC,PSJST,PSJS)) Q:PSJS="" D ON
. I PSJC="O" I TMPCLIN'=PSJCLIN D TF S PSJTF=$E(PSJC,1),TMPCLIN=PSJCLIN ;These are Non-Active Orders
. I PSJC="O" S PSJST="" F S PSJST=$O(^TMP("PSJ",$J,PSJCLIN,PSJC,PSJST)) Q:PSJST="" D
. . S PSJS="" F S PSJS=$O(^TMP("PSJ",$J,PSJCLIN,PSJC,PSJST,PSJS)) Q:PSJS="" D ON
.; END DAM changes
.;
S VALMCNT=PSJLN-1
DONE ;
K ^TMP("PSJCLOR",$J) M ^TMP("PSJCLOR",$J)=^TMP("PSJON",$J)
K PSJC,PSJEN,PSJLN,PSJST,PSJS,CNT,PSJPRI,^TMP("PSJ",$J),PSGSSAV,PSJDCEXP,PSJL,PSJON,PSJOS,PSJTF
Q
ON ; Set order number into ^TMP
N PSJCLORD S PSJCLORD=1
S PSJSCHT=$S(PSJOS:PSJS,1:PSJST)
S PSJO="" F FQ=0:0 S PSJO=$O(^TMP("PSJ",$J,PSJCLIN,PSJC,PSJST,PSJS,PSJO)) Q:PSJO="" S DN=^(PSJO) D
.N PRJPRI S PSJPRI=$S(PSJO["V":$P($G(^PS(55,PSGP,"IV",+PSJO,.2)),"^",4),PSJO["U":$P($G(^PS(55,PSGP,5,+PSJO,.2)),"^",4),1:$P($G(^PS(53.1,+PSJO,.2)),"^",4))
.S ^TMP("PSJON",$J,PSJEN)=PSJO,PSJL=$J(PSJEN,4) D @$S(PSJO["V":"PIV^PSJLMPRI(PSGP,PSJO,PSJF,DN)",PSJO["U":"PUD^PSJLMPRU(PSGP,PSJO,PSJF,DN)",1:"PIV^PSJLMPRI(PSGP,PSJO,PSJF,DN)") S ^TMP("PSJPRO",$J,0)=PSJEN,PSJEN=PSJEN+1
.S ^TMP("PSJON",$J)=+$O(^TMP("PSJON",$J,""),-1)
K DN,FQ,PSJSCHT
Q
TF ; Set up order type header
NEW PSJDFHDR
I $D(^TMP("PSJ",$J,PSJCLIN)) D
.S PSJDCEXP=$$RECDCEXP^PSJP()
.S PSJDFHDR="RECENTLY DISCONTINUED/EXPIRED (LAST "_+$G(PSJDCEXP)_" HOURS)"
.N C,X,Y S C=PSJC,Y="",$P(Y," -",40)=""
.S X=PSJCLIN
.I $G(PSJCLIN)]"" S X=PSJCLIN
.S ^TMP("PSJPRO",$J,PSJLN,0)=$E($E(Y,1,(80-$L(X))/2)_" "_X_$E(Y,1,(80-$L(X))/2),1,80),PSJLN=PSJLN+1
Q
TEST ; Headers
N X,Y S Y="",$P(Y," -",40)=""
F X="A C T I V E","P E N D I N G R E N E W A L S","P E N D I N G ","N O N - V E R I F I E D","N O N - A C T I V E" W !,$E($E(Y,1,(80-$L(X))/2)_" "_X_$E(Y,1,(80-$L(X))/2),1,80)
Q
VWDETAIL(PSGP) ;
N VAIN,VADM,PSJLM,PSGPRF,PSJPRP,PSJSYSL,DFN D ENCV^PSGSETU
S DFN=PSGP D ^PSJAC D INIT^PSJCLOR2(3)
S PSGPRF="",PSJPRP="P",PSJPR=0,PSJON=+$G(^TMP("PSJON",$J)) D FULL^VALM1,ENVW
D DONEVD
Q
ENVW ; ask user to select or view any of the orders shown
S (PSGONC,PSGONR,PSGONV)=0,PSGLMT=PSJON S:$D(PSJPRF) PSGPRF=1
N PSJXDIR S PSJXDIR=$P($G(XQORNOD(0)),"=",2) I PSJXDIR S X=$E(PSJXDIR,1,$L(PSJXDIR)-1) D ENCHK^PSGON
I '$G(PSJXDIR) D ENASR^PSGON
K PSGPRF
G:X["^" DONEVD I X]"" S PSGOEA=""
K PSJDLW
I F PSJOE=1:1:PSGODDD S PSGOE=PSJOE F PSJOE1=1:1:$L(PSGODDD(PSJOE),",")-1 S PSJOE2=$P(PSGODDD(PSJOE),",",PSJOE1),(PSGORD,PSJORD)=^TMP("PSJON",$J,PSJOE2) G:$D(PSJDLW) DONEVD D
.I PSJORD=+PSJORD N PSJO,PSJO1 S PSJO=PSJORD,PSJO1=0 F S PSJO1=$O(^PS(53.1,"ACX",PSJO,PSJO1)) Q:'PSJO1 Q:$D(PSJDLW) S PSJORD=PSJO1_"P",PSGOEA="" D GODO(PSJORD) S PSJORD=""
.Q:PSJORD="" S PSGOEA="" D GODO(PSJORD)
Q
;
GODO(PSJORD) ;
D GODO^PSJOE0
Q
DONEVD ; Kill variables
K DTOUT,PSGONC,PSGONR,PSGONV,PSGODDD,PSGOE,PSGOEA,PSJL,PSJOE,PSJOE1,PSJOE2,PSJON,PSJPR,PSJPRF
Q
;
NEWORDER(PSGP,PSGORD,PSGNWSD,PSGOEAV) ;
N PSGSD,PSGOEEF,PSGOFD,PSGNEFD,PSGOSD,PSGFD,PSGAT,PSGFDN S PSGOEEF(10)=1,PSJNOLOK=0
K DIR I '$$LS^PSSLOCK(DFN,PSGORD) W !,"NO ACTION TAKEN ON ORDER",! D CONT^PSJOE0 S PSJNOLOK=1 Q
I $D(^PS(53.45,+$G(PSJSYSP),5)) N PSJFSI S PSJFSI=1 D FILESI^PSJBCMA5(DFN,PSGORD) N SIARRAY S SIARRAY="" D
.I PSGORD["P" M SIARRAY=^PS(53.1,+PSGORD,15) D NEWNVAL^PSGAL5(PSGORD,6000,"SPECIAL INSTRUCTIONS",,.SIARRAY)
.I PSGORD["U" M SIARRAY=^PS(55,DFN,5,+PSGORD,15) D NEWUDAL^PSGAL5(DFN,PSGORD,6000,"SPECIAL INSTRUCTIONS",,.SIARRAY)
I PSGORD["P" S PSJCOM=+$P($G(^PS(53.1,+PSGORD,.2)),"^",8) I PSJCOM D NEW^PSJCOM1 Q
;
I PSGORD["P"!(PSGORD["U") D
.N PSGST,PSGSCH,PSGNESD,ND,ND2,ND2P1,PSJEDFLD,I ;*315
.F I=0,2 S ND(I)=$S($G(PSGORD)["P":$G(^PS(53.1,+PSGORD,I)),$G(PSGORD)["U":$G(^PS(55,+$G(PSGP),5,+PSGORD,I)),$G(PSJTMPON)["V":$G(^PS(55,+$G(PSGP),"IV",+PSGORD,I)),1:"")
.S PSGNESD=PSGNWSD,PSGSCH=$S(PSGORD["P"!(PSGORD["U"):$P(ND(2),"^"),PSGORD["V":$P(ND(0),"^",9),1:"")
.S PSGST=$S(PSGORD["P"!(PSGORD["U"):$P(ND(0),"^",7),1:""),(PSGFD,PSGOFD)=$S(PSGORD["V":$P(ND(0),"^",3),1:$P(ND(2),"^",4)),(PSGSD,PSGOSD)=$S(PSGORD["V":$P(ND(0),"^",2),1:$P(ND(2),"^",2))
.S PSGNEFD="" D ENFD^PSGNE3(PSGNWSD) S PSGFD=$S($G(PSGRDTX(+PSGORD,"PSGFD")):PSGRDTX(+PSGORD,"PSGFD"),1:PSGNEFD)
.I $G(PSGNEFD),(PSGNEFD<PSGNWSD) W $C(7),!?5,"*** THE START DATE CANNOT BE AFTER THE STOP DATE! ***" S PSJQMSG=1 Q
.S PSJEDFLD=$S(PSGORD["P":25,1:34) S PSGOEEF(PSJEDFLD)=1
;
I PSGORD["U" D Q
.N TMPNEFD S TMPNEFD=$G(PSGNEFD) S PSGOEEWF="^PS(55,"_PSGP_",5,"_+PSGORD_"," S (ND,ND0)=$G(@(PSGOEEWF_"0)")),ND2=$G(^(2)),ND2P1=$G(^(2.1)) ;*315
.D EN2^PSGOEEW
.S PSGOORD=PSGORD S (PSGNESD,SD,PSGSD)=PSGNWSD I ($G(TMPNEFD)'="") S (PSGNEFD,PSGFD)=TMPNEFD,PSGFDN=$$ENDD^PSGMI(PSGNEFD)_U_$$ENDTC^PSGMI(PSGNEFD)
.S PSGOFD=$P(^PS(55,PSGP,5,+PSGORD,2),"^",4),PSGOEENO=1,PSJOCL=+$G(^PS(55,PSGP,5,+PSGORD,8))
.W !,"START DATE/TIME: ",$$ENDD^PSGMI(PSGSD) D A34^PSJCLOR4
.S PSJNOO=$$ENNOO^PSJUTL5("E") I PSJNOO<0 W " No changes made to this order!" D CONT^PSJOE0 Q
.N PSJOCL,PSGOEENO S PSGOEENO=1,PSJOCL=+$G(^PS(55,PSGP,5,+PSGORD,8))
.D NEW^PSGOEE
.Q
;
I PSGORD["P" D
.N DR,PSJTMPFD,P S DR="10////^S X=PSGSD;" S:$G(PSGOEEF(25)) DR=DR_"25////^S X=PSGFD;" S DR=DR_"W ""."";"
.S PSJTMPFD=PSGFD
.D GETUD^PSJLMGUD(PSGP,PSGORD) N PSGNESD,PSGPDRG,PSJOCL S PSGPDRG=PSGPD,PSJOCL=+$G(^PS(53.1,+PSGORD,"DSS")) S:$G(PSGOEEF(25)) (PSGNEFD,PSGFD)=PSJTMPFD,PSGFDN=$$ENDD^PSGMI(PSGNEFD)_U_$$ENDTC^PSGMI(PSGNEFD)
.Q:'$G(PSJOCL) S PSGS0Y=PSGAT,(PSGNESD,PSGSD)=PSGNWSD,PSGPDRG=PSGPD,PSGPDRGN=PSGPDN,PSGOEE="E"
.W !,"START DATE/TIME: ",$$ENDD^PSGMI(PSGSD) D A25NV^PSJCLOR4
.N PSGOEENO S PSGOEENO=0 D UPD^PSGOEE
.D EN1^PSJHL2(PSGP,"XX",PSGORD)
;
I PSGORD["V" D
.N ON55,ND,ND2,ND0,PSIVCHG,PSIVSYSP,P,PSJSTRDF,PSJSTPDF,PSJINIV S PSGOEEWF="^PS(55,"_PSGP_",""IV"","_+PSGORD_",",PSIVCHG=1
.I '$G(XQORNOD),$G(PSJTMPXQ) N XQORNOD S XQORNOD=PSJTMPXQ
.S XQORNOD(0)="^^E"
.S PSJSYSW0=$G(PSJSYSW0) ; Initialize/restore PSJSYSW0 ward parameters. Killed at exit in ENKV^PSGSETU.
.I $G(PSGOEAV),'$P(PSJSYSP0,U,9) S PSIVSYSP=PSJSYSP0 N PSJSYSP0 S PSJSYSP0=PSIVSYSP,$P(PSJSYSP0,"^",9)=1
.S (ND,ND0)=$G(@(PSGOEEWF_"0)")),ND2=$G(^(2)),ON55=PSGORD
.D GT55^PSIVORFB S P(2)=PSGNWSD D ENSTOP^PSIVCAL
.W !,"START DATE/TIME: ",$$ENDD^PSGMI(P(2))
.D A25V^PSJCLOR4(PSGP,PSGORD)
.D NEWORD^PSIVOPT1
.S PSJORL=$$ENORL^PSJUTL($G(VAIN(4))) S ON=ON55,OD=P(2) D:ON["V" EN^PSIVORE D EN1^PSJHL2(DFN,"SN",ON55,"NEW ORDER")
.N TMPOLD S TMPOLD=$S(ON55["P":$P($G(^PS(53.1,+ON55,0)),"^",25),ON55["V":$P($G(^PS(55,PSGP,"IV",+ON55,2)),"^",5),1:"") I TMPOLD D
..I TMPOLD["V",$D(^PS(55,PSGP,"IV",+TMPOLD,10,1)) N LN S LN=+$O(^PS(55,PSGP,"IV",+TMPOLD,10,""),-1) D
...S:ON55["P" ^PS(53.1,+ON55,16,0)="^53.1136^"_LN_"^"_LN S:ON55["V" ^PS(55,PSGP,"IV",+ON55,10,0)="^55.1154^"_LN_"^"_LN
...S LN=0 F S LN=$O(^PS(55,PSGP,"IV",+TMPOLD,10,LN)) Q:'LN S:ON55["P" ^PS(53.1,+ON55,16,LN,0)=^PS(55,PSGP,"IV",+TMPOLD,10,LN,0) S:ON55["V" ^PS(55,PSGP,"IV",+ON55,10,LN,0)=^PS(55,PSGP,"IV",+TMPOLD,10,LN,0)
.;
I $G(PSJFSI)=1 I $$GETSI^PSJBCMA5(DFN,PSGORD) D FILESI^PSJBCMA5(DFN,$S($G(PSGOORD):PSGOORD,1:PSGORD))
I 'PSGOEAV,($G(PSGORD)["P"),'$G(^PS(53.1,+PSGORD,2.5)),$G(^PS(53.1,+PSGORD,0)) D
. N DUR S DUR=$$GETDUR^PSJLIVMD(PSGP,PSGORD,$S(PSGORD["P":"P",1:5),1) I DUR]"" K DA,DR,DIE S DIE="^PS(53.1,",DA=+PSGORD,DR="116////"_DUR D ^DIE
D NEWCLN^PSJCLOR5
D UNL^PSSLOCK(PSGP,PSGORD) I $G(PSGOORD) D UNL^PSSLOCK(PSGP,PSGOORD)
Q
;
DSPORD(PSGP,TMPORDER,PSJORDAR) ; Display order summary
D DSPORD^PSJCLOR5(PSGP,TMPORDER,.PSJORDAR)
Q
;
HDRDT ; Header Date Range
Q:'$G(PSJBEG)!'($G(PSJEND)) I $G(PSJTMPED),$P(PSJTMPED,"^",2) S PSJEND=$S($P(PSJTMPED,"^",2)'=$G(PSGP):+PSJTMPED,1:+PSJEND)
S VALMHDR(6)=" CLINIC ORDERS: "_$$FMTE^XLFDT(+$G(PSJBEG))_" to "_$$FMTE^XLFDT(+$G(PSJEND))
Q
;
CHGDT ; Change date range
N TMPBEG,TMPEND S TMPBEG=+PSJBEG,TMPEND=+PSJEND
D BEGDT I '$G(PSJBEG) S PSJBEG=+TMPBEG
D ENDDT(PSJBEG) I '$G(PSJEND) S PSJEND=+TMPEND
D INIT^PSJCLOR2(3) S VALMBCK="R" D HDR^PSJLMHED($S($G(DFN):DFN,1:$G(PSGP))) D HDRDT^PSJCLOR2
Q
BEGDT ; begin date
I '$G(PSJTMPBG) S PSJTMPBG=+PSJBEG_"^"_PSGP
W !!?5,"Search for CLINIC Medication Orders with a Start Date/Time"
W !?5,"within the date range selected below: "
W ! K %DT S %DT("A")="Begin Search Date: ",%DT="TAE",%DT("B")=$P($$FMTE^XLFDT(PSJBEG,1),"@")
D ^%DT Q:Y<0!($D(DTOUT)) S (%DT(0),PSJBEG)=Y
Q
ENDDT(BEG) ; end date
I $G(BEG) S $P(BEG,".",2)=24
I '$G(PSJTMPED) S PSJTMPED=+PSJEND_"^"_PSGP
W ! K DIR S DIR(0)="DA^"_BEG_"::TAE",DIR("A")="End Search Date: ",DIR("B")=$$FMTE^XLFDT(BEG) D ^DIR
S PSJEND=$S($G(Y):Y,1:BEG) I '$P(PSJEND,".",2) S PSJEND=Y_".24"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSJCLOR2 13982 printed Sep 23, 2025@19:42:31 Page 2
PSJCLOR2 ;BIR/JCH - BUILD CLINIC ORDER LM HEADERS ; 2/28/12 9:11am
+1 ;;5.0;INPATIENT MEDICATIONS;**275,279,315,256,387**;16 DEC 97;Build 1
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ; Reference to ^PS(55 is supported by DBIA 2191
+4 ; Reference to CWAD^ORQPT2 is supported by DBIA 2831
+5 ; Reference to ^SC( is supported by DBIA 10040
+6 ; Reference to BSA^PSSDSAPI supported by DBIA #5425
+7 ; Reference to LS^PSSLOCK supported by DBIA #2789
+8 ; Reference to UNL^PSSLOCK supported by DBIA #2789
+9 ;
HDR(DFN) ; -- list screen header
+1 ; input: DFN := ifn of pat
+2 ; output: VALMHDR() := hdr array
+3 ;
+4 KILL VAIN,VADM,GMRA,PSJACNWP,PSJ,VAERR,VA,X
+5 SET PSJACNWP=1
DO ENBOTH^PSJAC
+6 DO HDRO(DFN)
+7 SET PSJ=" Sex: "_$PIECE(PSJPSEX,U,2)
SET VALMHDR(4)=$$SETSTR^VALM1($SELECT(PSJPDD:"Last ",1:" ")_"Admitted: "_$PIECE($GET(PSJPAD),U,2),PSJ,45,23)
+8 SET PSJ=" Dx: "_$GET(PSJPDX)
+9 if PSJPDD
SET VALMHDR(5)=$$SETSTR^VALM1("Discharged: "_$EXTRACT($PIECE(PSJPDD,U,2),1,8),PSJ,48,26)
+10 if 'PSJPDD
SET VALMHDR(5)=$$SETSTR^VALM1("Last transferred: "_$$ENDTC^PSGMI(PSJPTD),PSJ,42,26)
+11 ;
+12 ; Display CrCl/BSA - show serum creatinine if CrCl can't be calculated
+13 SET PSJBSA=$$BSA^PSSDSAPI(DFN)
SET PSJBSA=$PIECE(PSJBSA,"^",3)
SET PSJBSA=$SELECT(PSJBSA'>0:"__________",1:$JUSTIFY(PSJBSA,4,2))
+14 ; RSLT -- DATE^CRCL^Serum Creatinine -- Ex. 11/25/11^68.7^1.1
+15 SET RSLT=$$CRCL^PSJLMHED(DFN)
+16 ; Display format of CrCL and Creatinine results updated - PSJ*5.0*387
+17 IF ($PIECE($GET(RSLT),"^",2)["Not Found")&($PIECE($GET(RSLT),"^",3)<.01)
SET ZDSPL=" CrCL: "_$PIECE(RSLT,"^",2)_" (CREAT: Not Found)"
+18 IF ($PIECE($GET(RSLT),"^",2)["Not Found")&($PIECE($GET(RSLT),"^",3)>=.01)
SET ZDSPL=" CrCL: "_$PIECE(RSLT,"^",2)_" (CREAT: "_$PIECE($GET(RSLT),"^",3)_"mg/dL "_$PIECE($GET(RSLT),"^")_")"
+19 IF ($PIECE($GET(RSLT),"^",2)'["Not Found")&($PIECE($GET(RSLT),"^",3)<.01)
SET ZDSPL=" CrCL: "_$PIECE(RSLT,"^",2)_" (CREAT: Not Found)"
+20 IF ($PIECE($GET(RSLT),"^",2)'["Not Found")&($PIECE($GET(RSLT),"^",3)>=.01)
SET ZDSPL=" CrCL: "_$PIECE(RSLT,"^",2)_"(est.)"_" (CREAT: "_$PIECE($GET(RSLT),"^",3)_"mg/dL "_$PIECE($GET(RSLT),"^")_")"
+21 SET PSJDB=$GET(ZDSPL)
SET VALMHDR(6)=$$SETSTR^VALM1("BSA (m2): "_$GET(PSJBSA),PSJDB,50,23)
KILL PSJBSA,ZDSPL,RSLT
+22 QUIT
+23 ;
HDRO(DFN) ; Standardized part of profile header.
+1 NEW PSJCLIN,PSJAPPT,PSJCLINN,RMORDT
SET (PSJCLIN,PSJAPPT)=0
SET (RMORDT,PSJCLINN)=""
IF $GET(PSJORD)
Begin DoDot:1
+2 SET PSJCLIN=$SELECT($GET(PSJORD)["V":$GET(^PS(55,DFN,"IV",+PSJORD,"DSS")),$GET(PSJORD)["U":$GET(^PS(55,DFN,5,+PSJORD,8)),$GET(PSJORD)["P":$GET(^PS(53.1,+PSJORD,"DSS")),1:"")
+3 if PSJCLIN
SET PSJAPPT=$PIECE($GET(PSJCLIN),U,2)
IF PSJCLIN
IF PSJAPPT
SET PSJCLINN=$PIECE($GET(^SC(+PSJCLIN,0)),U)
End DoDot:1
+4 KILL VALMHDR
IF PSJCLINN]""
SET PSJ=VADM(1)
SET PSJ=$$SETSTR^VALM1(" Clinic: "_PSJCLINN,PSJ,28,26)
+5 IF PSJCLINN=""
SET PSJ=VADM(1)
SET PSJ=$$SETSTR^VALM1($SELECT('PSJPDD:" ",1:"Last ")_"Ward: "_PSJPWDN,PSJ,30,18)
+6 SET X=$$CWAD^ORQPT2(DFN)
+7 if X]""
SET X=$GET(IORVON)_X_$GET(IORVOFF)
SET PSJ=$$SETSTR^VALM1(X,PSJ,80-$LENGTH(X),80)
SET VALMHDR(1)=PSJ
+8 SET PSJ=" PID: "_$PIECE(PSJPSSN,U,2)
+9 SET RMORDT=$SELECT($GET(PSJPDD):"Last ",1:" ")_"Room-Bed: "_$GET(PSJPRB)
+10 IF PSJCLINN]""
IF PSJAPPT
SET RMORDT="Clinic Date: "_$$ENDTC^PSGMI(PSJAPPT)
SET RMORDT=$PIECE(RMORDT," ")_" "_$PIECE(RMORDT," ",2)
+11 SET PSJ=$$SETSTR^VALM1(RMORDT,PSJ,26,28)
SET VALMHDR(2)=$$SETSTR^VALM1("Ht(cm): "_PSJPHT_" "_PSJPHTD,PSJ,55,25)
+12 SET PSJ=" DOB: "_$PIECE($PIECE(PSJPDOB,U,2)," ")_" ("_PSJPAGE_")"
SET VALMHDR(3)=$$SETSTR^VALM1("Wt(kg): "_PSJPWT_" "_PSJPWTD,PSJ,55,25)
+13 QUIT
+14 ;
INIT(PSJPROT) ; -- init bld vars
+1 ; PSJPROT=1:UD ONLY; 2:IV ONLY; 3:BOTH
+2 KILL PSJUDPRF,^TMP("PSJ",$JOB),^TMP("PSJON",$JOB),^TMP("PSJPRO",$JOB),^TMP("PSJCLOR",$JOB)
DO FULL^VALM1
+3 NEW TMPCLIN,DFN,UDU
SET PSJVALQ=0
SET TMPCLIN=""
SET DFN=PSGP
SET PSGSSAV=PSGSS
SET UDU=$SELECT($PIECE(PSJSYSU,";",3)>1:3,1:1)
+4 if PSJPROT=1
SET PSJUDPRF=1
+5 DO KILL^VALM10()
DO EN^PSJCLOR3(PSJPROT)
+6 IF '$DATA(^TMP("PSJ",$JOB))
WRITE !!,?22,"NO CLINIC ORDERS FOUND."
SET VALMQUIT=1
SET PSJVALQ=1
DO PAUSE^PSJLMUTL
QUIT
+7 SET PSJLN=1
SET PSJEN=1
SET PSJCLIN=""
FOR
SET PSJCLIN=$ORDER(^TMP("PSJ",$JOB,PSJCLIN))
if PSJCLIN=""
QUIT
SET PSJTF=0
SET PSJC=""
FOR
SET PSJC=$ORDER(^TMP("PSJ",$JOB,PSJCLIN,PSJC))
if PSJC=""
QUIT
Begin DoDot:1
+8 NEW PSJF
SET PSJF="^PS("_$SELECT("AO"[PSJC:"55,"_PSGP_",5,",PSJC="DF":"55,"_PSGP_",5,",1:"53.1,")
+9 ;DAM 8-29-07 Added Q:PSJC="CB" Q:PSJC="O"
IF TMPCLIN'=PSJCLIN
DO TF
SET PSJTF=$EXTRACT(PSJC,1)
SET TMPCLIN=PSJCLIN
+10 SET PSJST=""
FOR
SET PSJST=$ORDER(^TMP("PSJ",$JOB,PSJCLIN,PSJC,PSJST))
if PSJST=""
QUIT
Begin DoDot:2
+11 ;DAM 8-29-07 Added Q:PSJC="CB" Q:PSJC="O"
SET PSJS=""
FOR
SET PSJS=$ORDER(^TMP("PSJ",$JOB,PSJCLIN,PSJC,PSJST,PSJS))
if PSJS=""
QUIT
if PSJC="CB"
QUIT
if PSJC="O"
QUIT
if PSJC="DF"
QUIT
DO ON
End DoDot:2
+12 ;
+13 ;DAM 8-29-07 New code to place Pending Orders after Pending Renewal Orders on the roll and scroll display. Non-Active Orders appear last.
End DoDot:1
+14 SET PSJCLIN=""
FOR
SET PSJCLIN=$ORDER(^TMP("PSJ",$JOB,PSJCLIN))
if PSJCLIN=""
QUIT
SET PSJTF=0
SET PSJC=""
FOR
SET PSJC=$ORDER(^TMP("PSJ",$JOB,PSJCLIN,PSJC))
if PSJC=""
QUIT
Begin DoDot:1
+15 NEW PSJF
SET PSJF="^PS("_$SELECT("AO"[PSJC:"55,"_PSGP_",5,",PSJC="DF":"55,"_PSGP_",5,",1:"53.1,")
+16 ;These are Pending Orders
IF PSJC="CB"
IF TMPCLIN'=PSJCLIN
DO TF
SET PSJTF=$EXTRACT(PSJC,1)
SET TMPCLIN=PSJCLIN
+17 IF PSJC="CB"
SET PSJST=""
FOR
SET PSJST=$ORDER(^TMP("PSJ",$JOB,PSJCLIN,PSJC,PSJST))
if PSJST=""
QUIT
Begin DoDot:2
+18 SET PSJS=""
FOR
SET PSJS=$ORDER(^TMP("PSJ",$JOB,PSJCLIN,PSJC,PSJST,PSJS))
if PSJS=""
QUIT
DO ON
End DoDot:2
+19 ;These are recently DC Orders (mv)
IF PSJC="DF"
IF TMPCLIN'=PSJCLIN
DO TF
SET PSJTF=$EXTRACT(PSJC,1)
SET TMPCLIN=PSJCLIN
+20 IF PSJC="DF"
SET PSJST=""
FOR
SET PSJST=$ORDER(^TMP("PSJ",$JOB,PSJCLIN,PSJC,PSJST))
if PSJST=""
QUIT
Begin DoDot:2
+21 SET PSJS=""
FOR
SET PSJS=$ORDER(^TMP("PSJ",$JOB,PSJCLIN,PSJC,PSJST,PSJS))
if PSJS=""
QUIT
DO ON
End DoDot:2
+22 ;These are Non-Active Orders
IF PSJC="O"
IF TMPCLIN'=PSJCLIN
DO TF
SET PSJTF=$EXTRACT(PSJC,1)
SET TMPCLIN=PSJCLIN
+23 IF PSJC="O"
SET PSJST=""
FOR
SET PSJST=$ORDER(^TMP("PSJ",$JOB,PSJCLIN,PSJC,PSJST))
if PSJST=""
QUIT
Begin DoDot:2
+24 SET PSJS=""
FOR
SET PSJS=$ORDER(^TMP("PSJ",$JOB,PSJCLIN,PSJC,PSJST,PSJS))
if PSJS=""
QUIT
DO ON
End DoDot:2
+25 ; END DAM changes
+26 ;
End DoDot:1
+27 SET VALMCNT=PSJLN-1
DONE ;
+1 KILL ^TMP("PSJCLOR",$JOB)
MERGE ^TMP("PSJCLOR",$JOB)=^TMP("PSJON",$JOB)
+2 KILL PSJC,PSJEN,PSJLN,PSJST,PSJS,CNT,PSJPRI,^TMP("PSJ",$JOB),PSGSSAV,PSJDCEXP,PSJL,PSJON,PSJOS,PSJTF
+3 QUIT
ON ; Set order number into ^TMP
+1 NEW PSJCLORD
SET PSJCLORD=1
+2 SET PSJSCHT=$SELECT(PSJOS:PSJS,1:PSJST)
+3 SET PSJO=""
FOR FQ=0:0
SET PSJO=$ORDER(^TMP("PSJ",$JOB,PSJCLIN,PSJC,PSJST,PSJS,PSJO))
if PSJO=""
QUIT
SET DN=^(PSJO)
Begin DoDot:1
+4 NEW PRJPRI
SET PSJPRI=$SELECT(PSJO["V":$PIECE($GET(^PS(55,PSGP,"IV",+PSJO,.2)),"^",4),PSJO["U":$PIECE($GET(^PS(55,PSGP,5,+PSJO,.2)),"^",4),1:$PIECE($GET(^PS(53.1,+PSJO,.2)),"^",4))
+5 SET ^TMP("PSJON",$JOB,PSJEN)=PSJO
SET PSJL=$JUSTIFY(PSJEN,4)
DO @$SELECT(PSJO["V":"PIV^PSJLMPRI(PSGP,PSJO,PSJF,DN)",PSJO["U":"PUD^PSJLMPRU(PSGP,PSJO,PSJF,DN)",1:"PIV^PSJLMPRI(PSGP,PSJO,PSJF,DN)")
SET ^TMP("PSJPRO",$JOB,0)=PSJEN
SET PSJEN=PSJEN+1
+6 SET ^TMP("PSJON",$JOB)=+$ORDER(^TMP("PSJON",$JOB,""),-1)
End DoDot:1
+7 KILL DN,FQ,PSJSCHT
+8 QUIT
TF ; Set up order type header
+1 NEW PSJDFHDR
+2 IF $DATA(^TMP("PSJ",$JOB,PSJCLIN))
Begin DoDot:1
+3 SET PSJDCEXP=$$RECDCEXP^PSJP()
+4 SET PSJDFHDR="RECENTLY DISCONTINUED/EXPIRED (LAST "_+$GET(PSJDCEXP)_" HOURS)"
+5 NEW C,X,Y
SET C=PSJC
SET Y=""
SET $PIECE(Y," -",40)=""
+6 SET X=PSJCLIN
+7 IF $GET(PSJCLIN)]""
SET X=PSJCLIN
+8 SET ^TMP("PSJPRO",$JOB,PSJLN,0)=$EXTRACT($EXTRACT(Y,1,(80-$LENGTH(X))/2)_" "_X_$EXTRACT(Y,1,(80-$LENGTH(X))/2),1,80)
SET PSJLN=PSJLN+1
End DoDot:1
+9 QUIT
TEST ; Headers
+1 NEW X,Y
SET Y=""
SET $PIECE(Y," -",40)=""
+2 FOR X="A C T I V E","P E N D I N G R E N E W A L S","P E N D I N G ","N O N - V E R I F I E D","N O N - A C T I V E"
WRITE !,$EXTRACT($EXTRACT(Y,1,(80-$LENGTH(X))/2)_" "_X_$EXTRACT(Y,1,(80-$LENGTH(X))/2),1,80)
+3 QUIT
VWDETAIL(PSGP) ;
+1 NEW VAIN,VADM,PSJLM,PSGPRF,PSJPRP,PSJSYSL,DFN
DO ENCV^PSGSETU
+2 SET DFN=PSGP
DO ^PSJAC
DO INIT^PSJCLOR2(3)
+3 SET PSGPRF=""
SET PSJPRP="P"
SET PSJPR=0
SET PSJON=+$GET(^TMP("PSJON",$JOB))
DO FULL^VALM1
DO ENVW
+4 DO DONEVD
+5 QUIT
ENVW ; ask user to select or view any of the orders shown
+1 SET (PSGONC,PSGONR,PSGONV)=0
SET PSGLMT=PSJON
if $DATA(PSJPRF)
SET PSGPRF=1
+2 NEW PSJXDIR
SET PSJXDIR=$PIECE($GET(XQORNOD(0)),"=",2)
IF PSJXDIR
SET X=$EXTRACT(PSJXDIR,1,$LENGTH(PSJXDIR)-1)
DO ENCHK^PSGON
+3 IF '$GET(PSJXDIR)
DO ENASR^PSGON
+4 KILL PSGPRF
+5 if X["^"
GOTO DONEVD
IF X]""
SET PSGOEA=""
+6 KILL PSJDLW
+7 IF $TEST
FOR PSJOE=1:1:PSGODDD
SET PSGOE=PSJOE
FOR PSJOE1=1:1:$LENGTH(PSGODDD(PSJOE),",")-1
SET PSJOE2=$PIECE(PSGODDD(PSJOE),",",PSJOE1)
SET (PSGORD,PSJORD)=^TMP("PSJON",$JOB,PSJOE2)
if $DATA(PSJDLW)
GOTO DONEVD
Begin DoDot:1
+8 IF PSJORD=+PSJORD
NEW PSJO,PSJO1
SET PSJO=PSJORD
SET PSJO1=0
FOR
SET PSJO1=$ORDER(^PS(53.1,"ACX",PSJO,PSJO1))
if 'PSJO1
QUIT
if $DATA(PSJDLW)
QUIT
SET PSJORD=PSJO1_"P"
SET PSGOEA=""
DO GODO(PSJORD)
SET PSJORD=""
+9 if PSJORD=""
QUIT
SET PSGOEA=""
DO GODO(PSJORD)
End DoDot:1
+10 QUIT
+11 ;
GODO(PSJORD) ;
+1 DO GODO^PSJOE0
+2 QUIT
DONEVD ; Kill variables
+1 KILL DTOUT,PSGONC,PSGONR,PSGONV,PSGODDD,PSGOE,PSGOEA,PSJL,PSJOE,PSJOE1,PSJOE2,PSJON,PSJPR,PSJPRF
+2 QUIT
+3 ;
NEWORDER(PSGP,PSGORD,PSGNWSD,PSGOEAV) ;
+1 NEW PSGSD,PSGOEEF,PSGOFD,PSGNEFD,PSGOSD,PSGFD,PSGAT,PSGFDN
SET PSGOEEF(10)=1
SET PSJNOLOK=0
+2 KILL DIR
IF '$$LS^PSSLOCK(DFN,PSGORD)
WRITE !,"NO ACTION TAKEN ON ORDER",!
DO CONT^PSJOE0
SET PSJNOLOK=1
QUIT
+3 IF $DATA(^PS(53.45,+$GET(PSJSYSP),5))
NEW PSJFSI
SET PSJFSI=1
DO FILESI^PSJBCMA5(DFN,PSGORD)
NEW SIARRAY
SET SIARRAY=""
Begin DoDot:1
+4 IF PSGORD["P"
MERGE SIARRAY=^PS(53.1,+PSGORD,15)
DO NEWNVAL^PSGAL5(PSGORD,6000,"SPECIAL INSTRUCTIONS",,.SIARRAY)
+5 IF PSGORD["U"
MERGE SIARRAY=^PS(55,DFN,5,+PSGORD,15)
DO NEWUDAL^PSGAL5(DFN,PSGORD,6000,"SPECIAL INSTRUCTIONS",,.SIARRAY)
End DoDot:1
+6 IF PSGORD["P"
SET PSJCOM=+$PIECE($GET(^PS(53.1,+PSGORD,.2)),"^",8)
IF PSJCOM
DO NEW^PSJCOM1
QUIT
+7 ;
+8 IF PSGORD["P"!(PSGORD["U")
Begin DoDot:1
+9 ;*315
NEW PSGST,PSGSCH,PSGNESD,ND,ND2,ND2P1,PSJEDFLD,I
+10 FOR I=0,2
SET ND(I)=$SELECT($GET(PSGORD)["P":$GET(^PS(53.1,+PSGORD,I)),$GET(PSGORD)["U":$GET(^PS(55,+$GET(PSGP),5,+PSGORD,I)),$GET(PSJTMPON)["V":$GET(^PS(55,+$GET(PSGP),"IV",+PSGORD,I)),1:"")
+11 SET PSGNESD=PSGNWSD
SET PSGSCH=$SELECT(PSGORD["P"!(PSGORD["U"):$PIECE(ND(2),"^"),PSGORD["V":$PIECE(ND(0),"^",9),1:"")
+12 SET PSGST=$SELECT(PSGORD["P"!(PSGORD["U"):$PIECE(ND(0),"^",7),1:"")
SET (PSGFD,PSGOFD)=$SELECT(PSGORD["V":$PIECE(ND(0),"^",3),1:$PIECE(ND(2),"^",4))
SET (PSGSD,PSGOSD)=$SELECT(PSGORD["V":$PIECE(ND(0),"^",2),1:$PIECE(ND(2),"^",2))
+13 SET PSGNEFD=""
DO ENFD^PSGNE3(PSGNWSD)
SET PSGFD=$SELECT($GET(PSGRDTX(+PSGORD,"PSGFD")):PSGRDTX(+PSGORD,"PSGFD"),1:PSGNEFD)
+14 IF $GET(PSGNEFD)
IF (PSGNEFD<PSGNWSD)
WRITE $CHAR(7),!?5,"*** THE START DATE CANNOT BE AFTER THE STOP DATE! ***"
SET PSJQMSG=1
QUIT
+15 SET PSJEDFLD=$SELECT(PSGORD["P":25,1:34)
SET PSGOEEF(PSJEDFLD)=1
End DoDot:1
+16 ;
+17 IF PSGORD["U"
Begin DoDot:1
+18 ;*315
NEW TMPNEFD
SET TMPNEFD=$GET(PSGNEFD)
SET PSGOEEWF="^PS(55,"_PSGP_",5,"_+PSGORD_","
SET (ND,ND0)=$GET(@(PSGOEEWF_"0)"))
SET ND2=$GET(^(2))
SET ND2P1=$GET(^(2.1))
+19 DO EN2^PSGOEEW
+20 SET PSGOORD=PSGORD
SET (PSGNESD,SD,PSGSD)=PSGNWSD
IF ($GET(TMPNEFD)'="")
SET (PSGNEFD,PSGFD)=TMPNEFD
SET PSGFDN=$$ENDD^PSGMI(PSGNEFD)_U_$$ENDTC^PSGMI(PSGNEFD)
+21 SET PSGOFD=$PIECE(^PS(55,PSGP,5,+PSGORD,2),"^",4)
SET PSGOEENO=1
SET PSJOCL=+$GET(^PS(55,PSGP,5,+PSGORD,8))
+22 WRITE !,"START DATE/TIME: ",$$ENDD^PSGMI(PSGSD)
DO A34^PSJCLOR4
+23 SET PSJNOO=$$ENNOO^PSJUTL5("E")
IF PSJNOO<0
WRITE " No changes made to this order!"
DO CONT^PSJOE0
QUIT
+24 NEW PSJOCL,PSGOEENO
SET PSGOEENO=1
SET PSJOCL=+$GET(^PS(55,PSGP,5,+PSGORD,8))
+25 DO NEW^PSGOEE
+26 QUIT
End DoDot:1
QUIT
+27 ;
+28 IF PSGORD["P"
Begin DoDot:1
+29 NEW DR,PSJTMPFD,P
SET DR="10////^S X=PSGSD;"
if $GET(PSGOEEF(25))
SET DR=DR_"25////^S X=PSGFD;"
SET DR=DR_"W ""."";"
+30 SET PSJTMPFD=PSGFD
+31 DO GETUD^PSJLMGUD(PSGP,PSGORD)
NEW PSGNESD,PSGPDRG,PSJOCL
SET PSGPDRG=PSGPD
SET PSJOCL=+$GET(^PS(53.1,+PSGORD,"DSS"))
if $GET(PSGOEEF(25))
SET (PSGNEFD,PSGFD)=PSJTMPFD
SET PSGFDN=$$ENDD^PSGMI(PSGNEFD)_U_$$ENDTC^PSGMI(PSGNEFD)
+32 if '$GET(PSJOCL)
QUIT
SET PSGS0Y=PSGAT
SET (PSGNESD,PSGSD)=PSGNWSD
SET PSGPDRG=PSGPD
SET PSGPDRGN=PSGPDN
SET PSGOEE="E"
+33 WRITE !,"START DATE/TIME: ",$$ENDD^PSGMI(PSGSD)
DO A25NV^PSJCLOR4
+34 NEW PSGOEENO
SET PSGOEENO=0
DO UPD^PSGOEE
+35 DO EN1^PSJHL2(PSGP,"XX",PSGORD)
End DoDot:1
+36 ;
+37 IF PSGORD["V"
Begin DoDot:1
+38 NEW ON55,ND,ND2,ND0,PSIVCHG,PSIVSYSP,P,PSJSTRDF,PSJSTPDF,PSJINIV
SET PSGOEEWF="^PS(55,"_PSGP_",""IV"","_+PSGORD_","
SET PSIVCHG=1
+39 IF '$GET(XQORNOD)
IF $GET(PSJTMPXQ)
NEW XQORNOD
SET XQORNOD=PSJTMPXQ
+40 SET XQORNOD(0)="^^E"
+41 ; Initialize/restore PSJSYSW0 ward parameters. Killed at exit in ENKV^PSGSETU.
SET PSJSYSW0=$GET(PSJSYSW0)
+42 IF $GET(PSGOEAV)
IF '$PIECE(PSJSYSP0,U,9)
SET PSIVSYSP=PSJSYSP0
NEW PSJSYSP0
SET PSJSYSP0=PSIVSYSP
SET $PIECE(PSJSYSP0,"^",9)=1
+43 SET (ND,ND0)=$GET(@(PSGOEEWF_"0)"))
SET ND2=$GET(^(2))
SET ON55=PSGORD
+44 DO GT55^PSIVORFB
SET P(2)=PSGNWSD
DO ENSTOP^PSIVCAL
+45 WRITE !,"START DATE/TIME: ",$$ENDD^PSGMI(P(2))
+46 DO A25V^PSJCLOR4(PSGP,PSGORD)
+47 DO NEWORD^PSIVOPT1
+48 SET PSJORL=$$ENORL^PSJUTL($GET(VAIN(4)))
SET ON=ON55
SET OD=P(2)
if ON["V"
DO EN^PSIVORE
DO EN1^PSJHL2(DFN,"SN",ON55,"NEW ORDER")
+49 NEW TMPOLD
SET TMPOLD=$SELECT(ON55["P":$PIECE($GET(^PS(53.1,+ON55,0)),"^",25),ON55["V":$PIECE($GET(^PS(55,PSGP,"IV",+ON55,2)),"^",5),1:"")
IF TMPOLD
Begin DoDot:2
+50 IF TMPOLD["V"
IF $DATA(^PS(55,PSGP,"IV",+TMPOLD,10,1))
NEW LN
SET LN=+$ORDER(^PS(55,PSGP,"IV",+TMPOLD,10,""),-1)
Begin DoDot:3
+51 if ON55["P"
SET ^PS(53.1,+ON55,16,0)="^53.1136^"_LN_"^"_LN
if ON55["V"
SET ^PS(55,PSGP,"IV",+ON55,10,0)="^55.1154^"_LN_"^"_LN
+52 SET LN=0
FOR
SET LN=$ORDER(^PS(55,PSGP,"IV",+TMPOLD,10,LN))
if 'LN
QUIT
if ON55["P"
SET ^PS(53.1,+ON55,16,LN,0)=^PS(55,PSGP,"IV",+TMPOLD,10,LN,0)
if ON55["V"
SET ^PS(55,PSGP,"IV",+ON55,10,LN,0)=^PS(55,PSGP,"IV",+TMPOLD,10,LN,0)
End DoDot:3
End DoDot:2
+53 ;
End DoDot:1
+54 IF $GET(PSJFSI)=1
IF $$GETSI^PSJBCMA5(DFN,PSGORD)
DO FILESI^PSJBCMA5(DFN,$SELECT($GET(PSGOORD):PSGOORD,1:PSGORD))
+55 IF 'PSGOEAV
IF ($GET(PSGORD)["P")
IF '$GET(^PS(53.1,+PSGORD,2.5))
IF $GET(^PS(53.1,+PSGORD,0))
Begin DoDot:1
+56 NEW DUR
SET DUR=$$GETDUR^PSJLIVMD(PSGP,PSGORD,$SELECT(PSGORD["P":"P",1:5),1)
IF DUR]""
KILL DA,DR,DIE
SET DIE="^PS(53.1,"
SET DA=+PSGORD
SET DR="116////"_DUR
DO ^DIE
End DoDot:1
+57 DO NEWCLN^PSJCLOR5
+58 DO UNL^PSSLOCK(PSGP,PSGORD)
IF $GET(PSGOORD)
DO UNL^PSSLOCK(PSGP,PSGOORD)
+59 QUIT
+60 ;
DSPORD(PSGP,TMPORDER,PSJORDAR) ; Display order summary
+1 DO DSPORD^PSJCLOR5(PSGP,TMPORDER,.PSJORDAR)
+2 QUIT
+3 ;
HDRDT ; Header Date Range
+1 if '$GET(PSJBEG)!'($GET(PSJEND))
QUIT
IF $GET(PSJTMPED)
IF $PIECE(PSJTMPED,"^",2)
SET PSJEND=$SELECT($PIECE(PSJTMPED,"^",2)'=$GET(PSGP):+PSJTMPED,1:+PSJEND)
+2 SET VALMHDR(6)=" CLINIC ORDERS: "_$$FMTE^XLFDT(+$GET(PSJBEG))_" to "_$$FMTE^XLFDT(+$GET(PSJEND))
+3 QUIT
+4 ;
CHGDT ; Change date range
+1 NEW TMPBEG,TMPEND
SET TMPBEG=+PSJBEG
SET TMPEND=+PSJEND
+2 DO BEGDT
IF '$GET(PSJBEG)
SET PSJBEG=+TMPBEG
+3 DO ENDDT(PSJBEG)
IF '$GET(PSJEND)
SET PSJEND=+TMPEND
+4 DO INIT^PSJCLOR2(3)
SET VALMBCK="R"
DO HDR^PSJLMHED($SELECT($GET(DFN):DFN,1:$GET(PSGP)))
DO HDRDT^PSJCLOR2
+5 QUIT
BEGDT ; begin date
+1 IF '$GET(PSJTMPBG)
SET PSJTMPBG=+PSJBEG_"^"_PSGP
+2 WRITE !!?5,"Search for CLINIC Medication Orders with a Start Date/Time"
+3 WRITE !?5,"within the date range selected below: "
+4 WRITE !
KILL %DT
SET %DT("A")="Begin Search Date: "
SET %DT="TAE"
SET %DT("B")=$PIECE($$FMTE^XLFDT(PSJBEG,1),"@")
+5 DO ^%DT
if Y<0!($DATA(DTOUT))
QUIT
SET (%DT(0),PSJBEG)=Y
+6 QUIT
ENDDT(BEG) ; end date
+1 IF $GET(BEG)
SET $PIECE(BEG,".",2)=24
+2 IF '$GET(PSJTMPED)
SET PSJTMPED=+PSJEND_"^"_PSGP
+3 WRITE !
KILL DIR
SET DIR(0)="DA^"_BEG_"::TAE"
SET DIR("A")="End Search Date: "
SET DIR("B")=$$FMTE^XLFDT(BEG)
DO ^DIR
+4 SET PSJEND=$SELECT($GET(Y):Y,1:BEG)
IF '$PIECE(PSJEND,".",2)
SET PSJEND=Y_".24"
+5 QUIT
