- 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 Jan 18, 2025@03:07:38 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