- PSJCLOR ;BIR/JCH - FIND ORDERS BY CLINIC, CLINIC GROUP, OR PATIENT ; 2/28/12 9:11am
- ;;5.0;INPATIENT MEDICATIONS;**275,407**;DEC 16, 1997;Build 26
- ;
- ; Reference to ^PS(55 is supported by DBIA #2191
- ; Reference to ^PS(51.1 is supported by DBIA #2177
- ; Reference to ^DPT is supported by DBIA #10035
- ;
- N PSJNEW,PSGPTMP,PPAGE,CL,CG S PSJNEW=1
- START ; Lookup patient by clinic or patient, depending on value of PSGSS
- ;
- N PSJTOO,PSJPAC,PSJBEG,PSJEND,PSGOEAV,PSJTMPED,PSJTMPBG,PSJCLOR,PSGSS S PSJTOO=3,PSJPAC=3,PSJCLOR=1,PSGSS=""
- D ENCV^PSGSETU I $D(XQUIT) K XQUIT Q
- D ^PSIVXU I $D(XQUIT) K XQUIT Q
- Q:$G(DONE) ;P407
- D NOW^%DTC S PSGDT=%
- K ^TMP("PSJ",$J) S PSGPXN=0 L +^PS(53.45,PSJSYSP):1 E D LOCKERR^PSJOE G DONE
- S PSGSSH="VBW",PSGPXN=0,PSJPROT=$S($P(PSJSYSU,";",3)=3:3,1:1)
- S PSGVBWW="ACTIVE AND/OR NON-VERIFIED"
- S PSGOEAV=$P(PSJSYSP0,"^",9)&PSJSYSU
- F Q:(PSGSS="^") S PSJVALQ=0 Q:'$$DTRANGE F K ^TMP("PSJSELECT",$J) D SELECT Q:(PSGSS["^")!(PSGSS="") F S (PSGP,WD,WG)=0 S PSGPTMP=0,PPAGE=1 K PSGPRIF D @PSGSS Q:+Y'>0 D GO
- ;
- DONE ; Cleanup
- D DONE2
- K SETWDN,PTPRI,SETTM,SETPN,SUBS,TMPWD,STATUS,X1,X2,PSJBEG,PSJEND
- K CHK,D0,DRGI,FQC,J,ND,ON,PN,PSGODT,PSGOEA,PSGOP,PSGSS,PSGSSH,RB,SD,ST,TM,WD,WDN,WG,PRI,PSJPNV,PSJCT,PSGCLF,PSGPRIF,LIDT,WDNAME,IFPRI
- K PSGODDD,PSGOEORF,PSJORL,PSJORPCL,PSJORTOU,PSJORVP,PSGTOL,PSJTOO,PSGUOW,PSGONV,PX,PSGOEAV,PSGPX,PSGVBWTO,PSGVBWW,PSJOPC,PSGOENOF,PSJPROT,PSJLM,PSJASK
- K PSJPAC,PSJINDEX,PSJCNT,PSIVSN,PSGWORP1,PSGWORP2,PSGVBY,PSGVBWN,PSGVBTM,PSGVBPN,PSGPRIN,PSGPRD,PSGINWD,PSGINCL,PRDON,PRDNS,PRD,PPN,ORDT
- K %,DTOUT,DUOUT,ND0,PSGSS2,PSGDT,PSJNV,PSJPBID,PSJPAD,%Y,IOP,POP,PSGDICA,PSGH,PSJEXTP,PSJH,PSJHDATE,PSJPAD
- K PSJPAGE,PSJPBID,PSJPCAF,PSJPDD,PSJPDOB,PSJPDX,PSJPPID,PSJPRB,PSJPSEX,PSJPSSN,PSJPTD,PSJPTS,PSJPTSP,PSJPWD,PSJPWDN
- K XQORNOD,XRT0,XRTL,XRTN,ZTSAVE,WRD,WS,TYPE,TMPSEL,TMPNEWSD,TMPDT,TMPCNT,TMPAT,SWD,STOP,STAST,SORT,SM,SEQ,SDW,SCH,RTE,RSLT,RNDT,QX,PSOC,PSJX,PSJVALQ
- K PSJTEAM,PSJPSTO,PSJPINIT,PSJORIFN,PSJORF,PSJORD,PSJONTMP,PSJOL,PSJOCL,PSJO,PSJNOO,PSJMSG,PSJLOOP,PSJLMX,PSJLACT,PSJIVORF,PSJHLMTN,PSJDB,PSJDAY,PSJCOUNT
- K PSJCLIN,PSJBLOOP,PSJBLN,PSJBCID,PSJACNWP,PSJ,PSIVUP,PSIVTYPE,PSIVSTRT,PSIVITE,PSIVRT,PSIVRP,PSIVREA,PSIVPR,PSIVPL,PSIVNOW,PSIVLN,PSIVLIM,PSIVC,PSIVACT
- K PSIVAC,PSGVALG,PSGVADR,PSGSTAT,PSGST,PSGSM,PSGSDN,PSGSCH,PSGS0XT,PSGPRN,PSGPR,PSGPENWS,PSGPEN,PSGPDN,PSGPD,PSGOSTN,PSGOST,PSGOSM,PSGOSI,PSGOSDN,PSGOSCH
- K PSGORD,PSGOPRN,PSGPR,PSGOPDN,PSGOPD,PSGOORD,PSGOMRN,PSGOMR,PSGOL,PSGOINST,PSGOHSM,PSGOFDN,PSGOEPR,PSGOEEWF,PSGOEENO,PSGOEE,PSGODO,PSGOC,PSGOAT,PSGNEFDO
- K PSGLRN,PSGLI,PSGFDX,PSGDFN,PSGF2,PSGEBN,PSGEB,PSGDW,PSGCANFL,PSGAL,PSBSTR,PSBFLAG,PSBCNT,P,PDRG,ORO,OD,OCXSEG,NF,NDP2,ND6,ND4,ND14
- L -^PS(53.45,PSJSYSP) G:$G(PSGPXN) ^PSGPER1 D ENKV^PSGSETU K ND,PSGPXN Q
- ;
- DONE2 ; Partial Cleanup
- K ^TMP("PSGVBW",$J),^TMP("PSGVBW2",$J),^TMP("PSGVBW3",$J),^TMP("PSJSELECT",$J),^TMP("PSJLIST",$J),^TMP("PSJON",$J)
- K PRD,PSJL,DFN,PSGP
- Q
- ;
- GO ; Find and display matching patients
- I PSGSS'="P" W !,"...a few moments, please..." K ^TMP("PSGVBW",$J),^TMP("PSGVBW2",$J) D ARRAY K CHK,ON,PN,RB,SD,TM,WD,WDN,WG,X,Y
- I PSGSS'="P",'$D(^TMP("PSGVBW",$J)) W !,$C(7),"NO ",PSGVBWW," ORDERS FOR SELECTED ",$S(PSGSS="P":"PATIENT",PSGSS="L":"CLINIC GROUP",PSGSS="C":"CLINIC",PSGSS="PR":"PRIORITY",1:"WARD"),$S(PSGSS="G":" GROUP",1:"") Q
- D ^PSJCLOR1,DONE2 Q
- ;
- C ; Select a Clinic
- K CL,DIC,PSJCLNAR,PSJCDONE
- F Q:$G(PSJCDONE) K DIR S DIR(0)="FAO",DIR("A")="Select CLINIC: ",DIR("?")="^D ENCD^PSJCLOR" W ! D ^DIR S:$G(DUOUT) PSJCDONE=2 S:(Y="") PSJCDONE=1 D CDIC
- Q
- CDIC ; Clinic lookup
- I $G(PSJCDONE) S:($O(PSJCLNAR(0))&'$G(DUOUT)) Y=+$O(PSJCLNAR(0)) Q
- S DIC="^SC(",DIC(0)="QEMIZ" D ^DIC K DIC I Y>0 S CL=+Y,PSJCLNAR(+Y)=""
- I Y="" S PSJCDONE=1 Q
- I $G(DTOUT)!$G(DUTOUT) S PSJCDONE=1 Q
- W:X["?" !!,"Enter the clinic you want to use to select patients for processing.",!
- I '$G(DUOUT),($G(Y)<0),($G(X)'="") S X="?"
- I X["?" W !!,"Enter the name of the clinic to use to select patients for processing." G C
- Q:'$G(CL)
- DTRANGE() ; Enter Date Range
- K PSJBEG,PSJEND
- D BEGDT I ($G(PSJBEG)<1) S Y=0 Q 0
- D ENDDT(PSJBEG) I ($G(PSJEND)<1) S Y=0 Q 0
- Q Y
- BEGDT ; begin date
- W !!?5,"Search for Active and Non-Verified CLINIC Medication Orders"
- W !?5,"that fall within the date range selected below: "
- W ! K %DT S %DT("A")="Begin Search Date: ",%DT="TAE",%DT("B")="TODAY"
- D ^%DT Q:Y<0!($D(DTOUT)) S (%DT(0),PSJBEG,PSJTMPBG)=Y
- N YRONLY,FMTX S YRONLY=+$G(PSJBEG) I $L(YRONLY)=7 S:'$E(YRONLY,4,5) $E(YRONLY,4,5)="01" S:'$E(YRONLY,6,7) $E(YRONLY,6,7)="01" S PSJBEG=YRONLY S FMTX=$$FMTE^XLFDT(PSJBEG,1) W " ",FMTX
- Q
- ENDDT(BEG) ; end date
- N YRONLY,FMTX
- W ! K DIR S DIR(0)="DA^"_BEG_"::TAE",DIR("A")="End Search Date: ",DIR("B")=$P($$FMTE^XLFDT(BEG,1),"@") D ^DIR
- S PSJEND=$S($G(Y):Y,1:BEG) I '$P(PSJEND,".",2) S PSJEND=Y_".24",PSJTMPED=PSJEND
- I '$E(PSJEND,4,7) S YRONLY=+$G(PSJEND) S:'$E(YRONLY,4,5) $E(YRONLY,4,5)="01" S:'$E(YRONLY,6,7) $E(YRONLY,6,7)="01" D
- .S PSJEND=YRONLY S FMTX=$$FMTE^XLFDT(PSJEND,1) W " ",FMTX
- Q
- L ; Select a Clinic Group
- K DIR,PSJCLNAR S DIR(0)="FAO",DIR("A")="Select CLINIC GROUP: "
- S DIR("?")="^D LDIC^PSGVBW" W ! D ^DIR
- LDIC ; Clinic Group lookup
- K DIC S DIC="^PS(57.8,",DIC(0)="QEMI" D ^DIC K DIC S:+Y>0 CG=+Y
- I $G(CG) N TMPCNT,TMPCL S TMPCNT=0 F S TMPCNT=$O(^PS(57.8,+CG,1,TMPCNT)) Q:'TMPCNT S TMPCL=$G(^(TMPCNT,0)) I TMPCL S PSJCLNAR(TMPCL)=""
- I '$G(DUOUT),($G(Y)<0),($G(X)'="") S X="?"
- I X["?" W !!,"Enter the name of the clinic group to use to select patients for processing." G L
- Q
- P ; Select patient
- N PSJCLNAR,STOPD,TMPSTRT,ON2,BEGDTR,ENDTR,PSJSTAT S (PSJBEG,BEGDTR)=$S($G(PSJBEG):PSJBEG,1:$$FMADD^XLFDT(PSGDT,-365)),(PSJEND,ENDTR)=$S($G(PSJEND):PSJEND,1:$$FMADD^XLFDT(PSGDT,365)) S PSJCLNAR=""
- K ^TMP("PSJSELECT",$J) S PSJCNT=1 F D ^PSJP Q:PSGP<0 D
- .I $G(PSJTMPBG)&$G(PSJTMPED) S PSJBEG=+PSJTMPBG,PSJEND=+PSJTMPED K PSJTMPBG,PSJTMPED
- .S PSJNV=0 Q:$D(^TMP("PSJSELECT",$J,"C",PSGP))
- .NEW ON,XX S ON=0 F S ON=$O(^PS(53.1,"AS","N",PSGP,ON)) Q:'ON!$G(PSJNV) D
- ..N TMPSTRT,TMPSTP S TMPSTRT=$P($G(^PS(53.1,+ON,2)),"^",2) Q:(TMPSTRT>PSJEND) S TMPSTP=$P($G(^PS(53.1,+ON,2)),"^",4) Q:(TMPSTP<PSJBEG)
- ..N ND S ND=$G(^PS(53.1,+ON,0)) Q:((",D,E,")[(","_($E($P(ND,"^",9)))_",")) S PSJNV=+$G(^PS(53.1,ON,"DSS"))
- .I 'PSJNV D ^PSJAC D
- ..I '$D(PSGDT) D NOW^%DTC S PSGDT=$E(%,1,12)
- ..S STOPD=PSGDT F S STOPD=$O(^PS(55,"AUDC",STOPD)) Q:'STOPD!$G(PSJNV) S CL=0 F S CL=$O(^PS(55,"AUDC",STOPD,CL)) Q:'CL!$G(PSJNV) S ON2=0 F S ON2=$O(^PS(55,"AUDC",STOPD,CL,PSGP,ON2)) Q:'ON2!$G(PSJNV) D
- ...N ND S ND=$G(^PS(55,PSGP,5,+ON2,0)) S TMPSTRT=$P($G(^PS(55,PSGP,5,+ON2,2)),"^",2) Q:(TMPSTRT>ENDTR)!'$P(^PS(55,PSGP,5,+ON2,8),"^",2)
- ...Q:((",D,E,")[(","_($E($P(ND,"^",9)))_",")) S ON=+$G(ON2)_"U" S PSJNV=CL
- ..S SD=$$FMADD^XLFDT(PSJBEG,,,-1) F S SD=$O(^PS(55,PSGP,"IV","AIS",SD)) Q:'SD D
- ...F ON=0:0 S ON=$O(^PS(55,PSGP,"IV","AIS",SD,ON)) Q:'ON S PSJSTAT=$P($G(^PS(55,PSGP,"IV",ON,0)),"^",17) I (",E,D,")'[(","_$E(PSJSTAT)_",") D IFT2 Q
- .I PSJNV D ^PSJAC,SET S PN=$G(PSGP(0))_U_PSGP_U_PSJPBID S ^TMP("PSJSELECT",$J,PSJCNT)=PN,^TMP("PSJSELECT",$J,"B",$P(PN,U),PSJCNT)="",PSJCNT=PSJCNT+1,^TMP("PSJSELECT",$J,"C",+PSGP)="" Q
- .W !!?3,"No ",PSGVBWW," Clinic Orders found for this patient."
- S:$D(^TMP("PSJSELECT",$J)) Y=1
- I $G(PSJTMPBG)&$G(PSJTMPED) S PSJBEG=+PSJTMPBG,PSJEND=+PSJTMPED K PSJTMPBG,PSJTMPED
- Q
- ARRAY ; put patient(s) with non-verified orders into array
- I '$D(PSGDT) D NOW^%DTC S PSGDT=$E(%,1,12)
- S X1=$P(PSGDT,"."),X2=-2 D C^%DTC S PSGODT=X_(PSGDT#1),PSGVBWW="ACTIVE AND/OR NON-VERIFIED" I PSGSS="P" D IF S:$T ^TMP("PSGVBW",$J)=$P(PSGP(0),"^")_"^"_PSGP Q
- G CL:PSGSS="C"
- G CG:PSGSS="L"
- Q
- CG ; Find all clinics in selected clinic group
- S CL="" F S CL=$O(^PS(57.8,"AD",CG,CL)) Q:CL="" D CL
- Q
- CL ; Find all patients in selected clinic
- N BEGDTR,ENDTR,STOPD,ON2,TMPSTRT,TMPSTOP S BEGDTR=$$FMADD^XLFDT(PSJBEG,,-1),ENDTR=$$FMADD^XLFDT(PSJEND,,1)
- I PSGSS="C" D Q
- .S CL="" F S CL=$O(PSJCLNAR(CL)) Q:CL="" D CL1 I $G(CL) N CLINAME S CLINAME=$P($G(^SC(+$G(CL),0)),"^") Q:CLINAME="" D
- ..N I,J S (I,J)="" F S I=$O(PSJCLNAR(I)) Q:'I S J=J+1
- ..I (J>1),'$D(^TMP("PSGVBW",$J,CLINAME)) W !!,$C(7),"NO ",PSGVBWW," ORDERS FOR ",CLINAME,! D CONT^PSJOE0
- I PSGSS="L" D CL1
- Q
- CL1 ; Check each clinic for valid clinic orders
- S WDN=$S($D(^SC(CL,0)):$P(^(0),"^"),1:"")
- S PSGP="",PSGCLF=1 F S PSGP=$O(^PS(53.1,"AD",CL,PSGP)) Q:PSGP="" D ^PSJAC,IF
- S STOPD=PSGDT F S STOPD=$O(^PS(55,"AUDC",STOPD)) Q:'STOPD S PSGP=0 F S PSGP=$O(^PS(55,"AUDC",STOPD,CL,PSGP)) Q:'PSGP S ON2=0 F S ON2=$O(^PS(55,"AUDC",STOPD,CL,PSGP,ON2)) Q:'ON2 D
- .S TMPSTRT=$P($G(^PS(55,PSGP,5,+ON2,2)),"^",2),TMPSTOP=$P($G(^PS(55,PSGP,5,+ON2,2)),"^",4)
- .I TMPSTRT<ENDTR,(TMPSTOP>BEGDTR) Q:$E($P($G(^PS(55,PSGP,5,+ON2,0)),"^",9))="D" S ON=+$G(ON2)_"U" D ^PSJAC,SET
- S STOPD=PSGDT F S STOPD=$O(^PS(55,"AIVC",STOPD)) Q:'STOPD S PSGP=0 F S PSGP=$O(^PS(55,"AIVC",STOPD,CL,PSGP)) Q:'PSGP S ON2=0 F S ON2=$O(^PS(55,"AIVC",STOPD,CL,PSGP,ON2)) Q:'ON2 D
- .S TMPSTRT=$P($G(^PS(55,PSGP,"IV",+ON2,0)),"^",2),TMPSTOP=$P($G(^PS(55,PSGP,"IV",+ON2,0)),"^",3)
- .I TMPSTRT<ENDTR,(TMPSTOP>BEGDTR) Q:$E($P($G(^PS(55,PSGP,"IV",+ON2,0)),"^",17))="D" S ON=+$G(ON2)_"V" D ^PSJAC,SET
- K PSGCLF,TMPSTRT
- Q
- IF ; If called from CL subroutine and the order Doesn't exist for that Clinic, then QUIT.
- N PSJSTAT,ON2
- I $D(^PS(53.1,"AS","N",PSGP)) NEW XX S XX=0 S ON2=0 F S ON2=$O(^PS(53.1,"AS","N",PSGP,ON2)) Q:'ON2 N CLIN S CLIN=+$G(^PS(53.1,+$G(ON2),"DSS")) Q:'CLIN D
- .S XX=$S(PSGSS'="P"&$D(PSJCLNAR(+CLIN)):CLIN,1:CLIN) S ND=$P($G(^PS(53.1,ON2,0)),U,4),TMPSTRT=$P($G(^PS(53.1,ON2,2)),U,2),TMPSTP=$P($G(^PS(53.1,ON2,2)),U,4) I $G(XX) D
- ..Q:TMPSTRT>$S($G(ENDTR):ENDTR,1:$G(PSJEND)) Q:TMPSTP<$S($G(BEGDTR):BEGDTR,1:$G(PSJBEG))
- ..S PSJSTAT=$P($G(^PS(53.1,ON2,0)),"^",9) Q:PSJSTAT'="N"
- ..N ON S ON=ON2_"P" D ^PSJAC,SET
- S PSGODT=$P(PSJBEG,".")
- I PSJPAC'=2 F ST="C","O","OC","P","R" S SD=PSGODT F S SD=$O(^PS(55,PSGP,5,"AU",ST,SD)) Q:'SD S ON2=0 F S ON2=$O(^PS(55,PSGP,5,"AU",ST,SD,ON2)) Q:'ON2 S PSJSTAT=$P($G(^PS(55,PSGP,5,ON2,0)),"^",9) D
- .I (PSJSTAT]"")&((",D,E,"'[(","_$E(PSJSTAT)_","))) S ON=ON2_"U" D SET
- ;*PSJ*5*241:Expired IV orders must be one-time
- I PSJPAC'=1 S SD=$$FMADD^XLFDT(PSJBEG,,,-1) F S SD=$O(^PS(55,PSGP,"IV","AIS",SD)) Q:'SD S ON2=0 F S ON2=$O(^PS(55,PSGP,"IV","AIS",SD,ON2)) Q:'ON2 D
- .N SCH,STYPE S STYPE=0,SCH=$P($G(^PS(55,PSGP,"IV",ON2,0)),U,9)
- .S:SCH]"" SCH=$O(^PS(51.1,"APPSJ",SCH,STYPE)) S:SCH]"" STYPE=$P($G(^PS(51.1,SCH,0)),U,5)
- .S PSJSTAT=$P($G(^PS(55,PSGP,"IV",+ON2,0)),"^",17)
- .I ",D,E,"'[(","_$E(PSJSTAT)_",") I ($G(STYPE)'="O") S ON=ON2_"V" D IFT2,SET
- K TMPSTRT
- Q
- IFT2 ; Loop through active IV orders in ^PS(55
- N CL,TMPSTRT,TMPSTP S CL=+$G(^PS(55,+$G(PSGP),"IV",+$G(ON),"DSS"))
- S ND0=$G(^PS(55,PSGP,"IV",+ON,0)) S TMPSTRT=$P(ND0,"^",2),TMPSTP=$P(ND0,"^",3) Q:((TMPSTRT>PSJEND)!(TMPSTP<PSJBEG))
- Q:((",D,E,")[(","_($E($P(ND0,"^",17)))_","))
- S PSJNV=CL
- Q
- SET ; Set patient specific variables for ^TMP subscripts
- K DIC,X,Y,WDNAME,TMPWD
- N PSJSTAT,TMPSTRT,TMPSTP S TMPSTRT=$S($G(ON)["P":$P($G(^PS(53.1,ON,2)),U,2),$G(ON)["U":$P($G(^PS(55,PSGP,5,+ON,2)),"^",2),$G(ON)["V":$P($G(^PS(55,PSGP,"IV",+ON,0)),"^",2),1:"")
- S TMPSTP=$S($G(ON)["P":$P($G(^PS(53.1,+ON,2)),U,4),$G(ON)["U":$P($G(^PS(55,PSGP,5,+ON,2)),"^",4),$G(ON)["V":$P($G(^PS(55,PSGP,"IV",+ON,0)),"^",3),1:"")
- Q:TMPSTRT>$S($G(ENDTR):ENDTR,1:$G(PSJEND)) Q:TMPSTP<$S($G(BEGDTR):BEGDTR,1:$G(PSJBEG))
- S PSJSTAT=$S($G(ON)["P":$P($G(^PS(53.1,+ON,0)),"^",9),$G(ON)["U":$P($G(^PS(55,PSGP,5,+ON,0)),"^",9),$G(ON)["V":$P($G(^PS(55,PSGP,"IV",+ON,0)),"^",17),1:"")
- Q:PSJSTAT="" Q:(",D,E,")[(","_$E(PSJSTAT)_",")
- S X=$S($G(ON)["P":$G(^PS(53.1,+ON,"DSS")),$G(ON)["U":$G(^PS(55,PSGP,5,+ON,8)),$G(ON)["V":$G(^PS(55,PSGP,"IV",+ON,"DSS")),1:"")
- Q:'X Q:'$P(X,"^",2) S X=+X
- S X="`"_+X,DIC="^SC(",DIC(0)="BOXZ" D ^DIC S TMPWD=+Y,(WDN,WDNAME)=$P(Y,"^",2)
- I $G(PSGSS)'="P",$G(TMPWD),'$D(PSJCLNAR(+TMPWD)) Q
- S TM=$S(PSJPRB="":"",1:$P($G(^PS(57.7,TMPWD,1,+$O(^PS(57.7,"AWRT",TMPWD,PSJPRB,0)),0)),"^")) S:TM="" TM="zz"
- SETPN ; If searching for specific priority:
- ; - set patient into ^TMP("PSGBW" sorted by Clnic, Patient Name^IEN^SSN
- ; If not searching for specific priority:
- ; - set patient into ^TMP("PSGVBW2" sorted by 'Patient Name^IEN^SSN',
- ; - set patient into ^TMP("PSGVBW3" sorted by Patient IEN
- S PN=$P(PSGP(0),"^")_U_PSGP_U_PSJPBID
- S ^TMP("PSGVBW",$J,WDN,1,TM,PN)=$S($G(TMPWD):TMPWD,1:"")
- S ^TMP("PSGVBW2",$J,PN,1)=WDN_"^"_TM,^TMP("PSGVBW3",$J,WDN,+PSGP)=TMPWD
- Q
- SET2 ; If not searching for a specific priority,find the highest priority order associated with patient.
- ; Set the patient into ^TMP("PSGVBW" sorted by highest Priority Name, Priority #, Team, Patient Name^IEN^SSN
- S SETPN="" F S SETPN=$O(^TMP("PSGVBW2",$J,SETPN)) Q:SETPN="" D
- .S PTPRI=$O(^TMP("PSGVBW2",$J,SETPN,0)) Q:'$G(PTPRI)
- .S SUBS=$G(^TMP("PSGVBW2",$J,SETPN,PTPRI)),SETWDN=$P(SUBS,"^"),SETTM=$P(SUBS,"^",2) Q:SETWDN=""!(SETTM="")
- .S ^TMP("PSGVBW",$J,SETWDN,1,SETTM,SETPN)=""
- K ^TMP("PSGVBW2",$J)
- Q
- ;
- EXIT(X) ; Generic user error message
- W !!,X," not selected, option terminated."
- Q
- ;
- SELECT ; give user choice to select search method
- S PSJVALQ=0
- S:'$D(PSGSSH) PSGSSH="GENERIC"
- ;
- N PSJCLNAR
- F W !!,"Search by CLINIC (C), CLINIC GROUP (G), or PATIENT (P) : " R PSGSS:DTIME W:'$T $C(7) S:'$T!(PSGSS="") PSGSS="^" Q:"^"[PSGSS D CHK I ",C,P,L,"[(","_PSGSS_",") Q
- ;
- K PSGSSA Q
- ;
- CHK ;
- N Q
- S PSGSSA="" F Q=1:1:$L(PSGSS) S PSGSSA=PSGSSA_$S($E(PSGSS,Q)'?1L:$E(PSGSS,Q),1:$C($A(PSGSS,Q)-32))
- F X="CLINIC","PATIENT","GROUP" I $P(X,PSGSSA)="" W $P(X,PSGSSA,2,99) S PSGSS=$S(($E(PSGSSA)="G"):"L",1:$E(PSGSSA)) Q
- Q:$T I PSGSS'?1."?" W $C(7)," ??" S PSGSS="Z" Q
- W ! D @PSGSSH W !!?2,"To leave this option, press the RETURN key or enter '^'." Q
- ;
- CHK2 ;
- N Q
- S PSGSSA="" F Q=1:1:$L(PSGSS2) S PSGSSA=PSGSSA_$S($E(PSGSS2,Q)'?1L:$E(PSGSS2,Q),1:$C($A(PSGSS2,Q)-32))
- F X="WARD","CLINIC","GROUP" I $P(X,PSGSSA)="" W $P(X,PSGSSA,2,99) S PSGSS2=$S(($E(PSGSSA)="G"):"L",1:$E(PSGSSA)) Q
- Q:$T I PSGSS2'?1."?" W $C(7)," ??" S PSGSS2="Z" Q
- W ! D @PSGSSH W !!?2,"To leave this option, press the RETURN key or enter '^'." Q
- ;
- HELP ; the following are the help text messages for the various options
- ;
- GENERIC W !!,?2,"To run this option for an entire CLINIC, enter 'C'. To run this option for a single PATIENT, enter 'P'." Q
- ;
- VBW W !!?2,"To process orders in a single CLINIC, enter 'C'."
- W !,"To process orders for a single PATIENT, enter 'P'."
- Q
- ;
- ENCD ;edit Clinic Definitions file
- I X["?" W !,"Enter a clinic from the CLINIC DEFINITION file."
- K DIC S DIC="^PS(53.46,",DIC(0)="QEMIZ" D ^DIC K DIC ; S:(Y>0) Y=+$G(^PS(53.46,+Y,0))
- W !,"You may also select a clinic from the HOSPITAL LOCATION file."
- K DIC S DIC="^SC(",DIC(0)="QEMIZ" D ^DIC K DIC
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSJCLOR 15011 printed Feb 18, 2025@23:32:46 Page 2
- PSJCLOR ;BIR/JCH - FIND ORDERS BY CLINIC, CLINIC GROUP, OR PATIENT ; 2/28/12 9:11am
- +1 ;;5.0;INPATIENT MEDICATIONS;**275,407**;DEC 16, 1997;Build 26
- +2 ;
- +3 ; Reference to ^PS(55 is supported by DBIA #2191
- +4 ; Reference to ^PS(51.1 is supported by DBIA #2177
- +5 ; Reference to ^DPT is supported by DBIA #10035
- +6 ;
- +7 NEW PSJNEW,PSGPTMP,PPAGE,CL,CG
- SET PSJNEW=1
- START ; Lookup patient by clinic or patient, depending on value of PSGSS
- +1 ;
- +2 NEW PSJTOO,PSJPAC,PSJBEG,PSJEND,PSGOEAV,PSJTMPED,PSJTMPBG,PSJCLOR,PSGSS
- SET PSJTOO=3
- SET PSJPAC=3
- SET PSJCLOR=1
- SET PSGSS=""
- +3 DO ENCV^PSGSETU
- IF $DATA(XQUIT)
- KILL XQUIT
- QUIT
- +4 DO ^PSIVXU
- IF $DATA(XQUIT)
- KILL XQUIT
- QUIT
- +5 ;P407
- if $GET(DONE)
- QUIT
- +6 DO NOW^%DTC
- SET PSGDT=%
- +7 KILL ^TMP("PSJ",$JOB)
- SET PSGPXN=0
- LOCK +^PS(53.45,PSJSYSP):1
- IF '$TEST
- DO LOCKERR^PSJOE
- GOTO DONE
- +8 SET PSGSSH="VBW"
- SET PSGPXN=0
- SET PSJPROT=$SELECT($PIECE(PSJSYSU,";",3)=3:3,1:1)
- +9 SET PSGVBWW="ACTIVE AND/OR NON-VERIFIED"
- +10 SET PSGOEAV=$PIECE(PSJSYSP0,"^",9)&PSJSYSU
- +11 FOR
- if (PSGSS="^")
- QUIT
- SET PSJVALQ=0
- if '$$DTRANGE
- QUIT
- FOR
- KILL ^TMP("PSJSELECT",$JOB)
- DO SELECT
- if (PSGSS["^")!(PSGSS="")
- QUIT
- FOR
- SET (PSGP,WD,WG)=0
- SET PSGPTMP=0
- SET PPAGE=1
- KILL PSGPRIF
- DO @PSGSS
- if +Y'>0
- QUIT
- DO GO
- +12 ;
- DONE ; Cleanup
- +1 DO DONE2
- +2 KILL SETWDN,PTPRI,SETTM,SETPN,SUBS,TMPWD,STATUS,X1,X2,PSJBEG,PSJEND
- +3 KILL CHK,D0,DRGI,FQC,J,ND,ON,PN,PSGODT,PSGOEA,PSGOP,PSGSS,PSGSSH,RB,SD,ST,TM,WD,WDN,WG,PRI,PSJPNV,PSJCT,PSGCLF,PSGPRIF,LIDT,WDNAME,IFPRI
- +4 KILL PSGODDD,PSGOEORF,PSJORL,PSJORPCL,PSJORTOU,PSJORVP,PSGTOL,PSJTOO,PSGUOW,PSGONV,PX,PSGOEAV,PSGPX,PSGVBWTO,PSGVBWW,PSJOPC,PSGOENOF,PSJPROT,PSJLM,PSJASK
- +5 KILL PSJPAC,PSJINDEX,PSJCNT,PSIVSN,PSGWORP1,PSGWORP2,PSGVBY,PSGVBWN,PSGVBTM,PSGVBPN,PSGPRIN,PSGPRD,PSGINWD,PSGINCL,PRDON,PRDNS,PRD,PPN,ORDT
- +6 KILL %,DTOUT,DUOUT,ND0,PSGSS2,PSGDT,PSJNV,PSJPBID,PSJPAD,%Y,IOP,POP,PSGDICA,PSGH,PSJEXTP,PSJH,PSJHDATE,PSJPAD
- +7 KILL PSJPAGE,PSJPBID,PSJPCAF,PSJPDD,PSJPDOB,PSJPDX,PSJPPID,PSJPRB,PSJPSEX,PSJPSSN,PSJPTD,PSJPTS,PSJPTSP,PSJPWD,PSJPWDN
- +8 KILL XQORNOD,XRT0,XRTL,XRTN,ZTSAVE,WRD,WS,TYPE,TMPSEL,TMPNEWSD,TMPDT,TMPCNT,TMPAT,SWD,STOP,STAST,SORT,SM,SEQ,SDW,SCH,RTE,RSLT,RNDT,QX,PSOC,PSJX,PSJVALQ
- +9 KILL PSJTEAM,PSJPSTO,PSJPINIT,PSJORIFN,PSJORF,PSJORD,PSJONTMP,PSJOL,PSJOCL,PSJO,PSJNOO,PSJMSG,PSJLOOP,PSJLMX,PSJLACT,PSJIVORF,PSJHLMTN,PSJDB,PSJDAY,PSJCOUNT
- +10 KILL PSJCLIN,PSJBLOOP,PSJBLN,PSJBCID,PSJACNWP,PSJ,PSIVUP,PSIVTYPE,PSIVSTRT,PSIVITE,PSIVRT,PSIVRP,PSIVREA,PSIVPR,PSIVPL,PSIVNOW,PSIVLN,PSIVLIM,PSIVC,PSIVACT
- +11 KILL PSIVAC,PSGVALG,PSGVADR,PSGSTAT,PSGST,PSGSM,PSGSDN,PSGSCH,PSGS0XT,PSGPRN,PSGPR,PSGPENWS,PSGPEN,PSGPDN,PSGPD,PSGOSTN,PSGOST,PSGOSM,PSGOSI,PSGOSDN,PSGOSCH
- +12 KILL PSGORD,PSGOPRN,PSGPR,PSGOPDN,PSGOPD,PSGOORD,PSGOMRN,PSGOMR,PSGOL,PSGOINST,PSGOHSM,PSGOFDN,PSGOEPR,PSGOEEWF,PSGOEENO,PSGOEE,PSGODO,PSGOC,PSGOAT,PSGNEFDO
- +13 KILL PSGLRN,PSGLI,PSGFDX,PSGDFN,PSGF2,PSGEBN,PSGEB,PSGDW,PSGCANFL,PSGAL,PSBSTR,PSBFLAG,PSBCNT,P,PDRG,ORO,OD,OCXSEG,NF,NDP2,ND6,ND4,ND14
- +14 LOCK -^PS(53.45,PSJSYSP)
- if $GET(PSGPXN)
- GOTO ^PSGPER1
- DO ENKV^PSGSETU
- KILL ND,PSGPXN
- QUIT
- +15 ;
- DONE2 ; Partial Cleanup
- +1 KILL ^TMP("PSGVBW",$JOB),^TMP("PSGVBW2",$JOB),^TMP("PSGVBW3",$JOB),^TMP("PSJSELECT",$JOB),^TMP("PSJLIST",$JOB),^TMP("PSJON",$JOB)
- +2 KILL PRD,PSJL,DFN,PSGP
- +3 QUIT
- +4 ;
- GO ; Find and display matching patients
- +1 IF PSGSS'="P"
- WRITE !,"...a few moments, please..."
- KILL ^TMP("PSGVBW",$JOB),^TMP("PSGVBW2",$JOB)
- DO ARRAY
- KILL CHK,ON,PN,RB,SD,TM,WD,WDN,WG,X,Y
- +2 IF PSGSS'="P"
- IF '$DATA(^TMP("PSGVBW",$JOB))
- WRITE !,$CHAR(7),"NO ",PSGVBWW," ORDERS FOR SELECTED ",$SELECT(PSGSS="P":"PATIENT",PSGSS="L":"CLINIC GROUP",PSGSS="C":"CLINIC",PSGSS="PR":"PRIORITY",1:"WARD"),$SELECT(PSGSS="G":" GROUP",1:"")
- QUIT
- +3 DO ^PSJCLOR1
- DO DONE2
- QUIT
- +4 ;
- C ; Select a Clinic
- +1 KILL CL,DIC,PSJCLNAR,PSJCDONE
- +2 FOR
- if $GET(PSJCDONE)
- QUIT
- KILL DIR
- SET DIR(0)="FAO"
- SET DIR("A")="Select CLINIC: "
- SET DIR("?")="^D ENCD^PSJCLOR"
- WRITE !
- DO ^DIR
- if $GET(DUOUT)
- SET PSJCDONE=2
- if (Y="")
- SET PSJCDONE=1
- DO CDIC
- +3 QUIT
- CDIC ; Clinic lookup
- +1 IF $GET(PSJCDONE)
- if ($ORDER(PSJCLNAR(0))&'$GET(DUOUT))
- SET Y=+$ORDER(PSJCLNAR(0))
- QUIT
- +2 SET DIC="^SC("
- SET DIC(0)="QEMIZ"
- DO ^DIC
- KILL DIC
- IF Y>0
- SET CL=+Y
- SET PSJCLNAR(+Y)=""
- +3 IF Y=""
- SET PSJCDONE=1
- QUIT
- +4 IF $GET(DTOUT)!$GET(DUTOUT)
- SET PSJCDONE=1
- QUIT
- +5 if X["?"
- WRITE !!,"Enter the clinic you want to use to select patients for processing.",!
- +6 IF '$GET(DUOUT)
- IF ($GET(Y)<0)
- IF ($GET(X)'="")
- SET X="?"
- +7 IF X["?"
- WRITE !!,"Enter the name of the clinic to use to select patients for processing."
- GOTO C
- +8 if '$GET(CL)
- QUIT
- DTRANGE() ; Enter Date Range
- +1 KILL PSJBEG,PSJEND
- +2 DO BEGDT
- IF ($GET(PSJBEG)<1)
- SET Y=0
- QUIT 0
- +3 DO ENDDT(PSJBEG)
- IF ($GET(PSJEND)<1)
- SET Y=0
- QUIT 0
- +4 QUIT Y
- BEGDT ; begin date
- +1 WRITE !!?5,"Search for Active and Non-Verified CLINIC Medication Orders"
- +2 WRITE !?5,"that fall within the date range selected below: "
- +3 WRITE !
- KILL %DT
- SET %DT("A")="Begin Search Date: "
- SET %DT="TAE"
- SET %DT("B")="TODAY"
- +4 DO ^%DT
- if Y<0!($DATA(DTOUT))
- QUIT
- SET (%DT(0),PSJBEG,PSJTMPBG)=Y
- +5 NEW YRONLY,FMTX
- SET YRONLY=+$GET(PSJBEG)
- IF $LENGTH(YRONLY)=7
- if '$EXTRACT(YRONLY,4,5)
- SET $EXTRACT(YRONLY,4,5)="01"
- if '$EXTRACT(YRONLY,6,7)
- SET $EXTRACT(YRONLY,6,7)="01"
- SET PSJBEG=YRONLY
- SET FMTX=$$FMTE^XLFDT(PSJBEG,1)
- WRITE " ",FMTX
- +6 QUIT
- ENDDT(BEG) ; end date
- +1 NEW YRONLY,FMTX
- +2 WRITE !
- KILL DIR
- SET DIR(0)="DA^"_BEG_"::TAE"
- SET DIR("A")="End Search Date: "
- SET DIR("B")=$PIECE($$FMTE^XLFDT(BEG,1),"@")
- DO ^DIR
- +3 SET PSJEND=$SELECT($GET(Y):Y,1:BEG)
- IF '$PIECE(PSJEND,".",2)
- SET PSJEND=Y_".24"
- SET PSJTMPED=PSJEND
- +4 IF '$EXTRACT(PSJEND,4,7)
- SET YRONLY=+$GET(PSJEND)
- if '$EXTRACT(YRONLY,4,5)
- SET $EXTRACT(YRONLY,4,5)="01"
- if '$EXTRACT(YRONLY,6,7)
- SET $EXTRACT(YRONLY,6,7)="01"
- Begin DoDot:1
- +5 SET PSJEND=YRONLY
- SET FMTX=$$FMTE^XLFDT(PSJEND,1)
- WRITE " ",FMTX
- End DoDot:1
- +6 QUIT
- L ; Select a Clinic Group
- +1 KILL DIR,PSJCLNAR
- SET DIR(0)="FAO"
- SET DIR("A")="Select CLINIC GROUP: "
- +2 SET DIR("?")="^D LDIC^PSGVBW"
- WRITE !
- DO ^DIR
- LDIC ; Clinic Group lookup
- +1 KILL DIC
- SET DIC="^PS(57.8,"
- SET DIC(0)="QEMI"
- DO ^DIC
- KILL DIC
- if +Y>0
- SET CG=+Y
- +2 IF $GET(CG)
- NEW TMPCNT,TMPCL
- SET TMPCNT=0
- FOR
- SET TMPCNT=$ORDER(^PS(57.8,+CG,1,TMPCNT))
- if 'TMPCNT
- QUIT
- SET TMPCL=$GET(^(TMPCNT,0))
- IF TMPCL
- SET PSJCLNAR(TMPCL)=""
- +3 IF '$GET(DUOUT)
- IF ($GET(Y)<0)
- IF ($GET(X)'="")
- SET X="?"
- +4 IF X["?"
- WRITE !!,"Enter the name of the clinic group to use to select patients for processing."
- GOTO L
- +5 QUIT
- P ; Select patient
- +1 NEW PSJCLNAR,STOPD,TMPSTRT,ON2,BEGDTR,ENDTR,PSJSTAT
- SET (PSJBEG,BEGDTR)=$SELECT($GET(PSJBEG):PSJBEG,1:$$FMADD^XLFDT(PSGDT,-365))
- SET (PSJEND,ENDTR)=$SELECT($GET(PSJEND):PSJEND,1:$$FMADD^XLFDT(PSGDT,365))
- SET PSJCLNAR=""
- +2 KILL ^TMP("PSJSELECT",$JOB)
- SET PSJCNT=1
- FOR
- DO ^PSJP
- if PSGP<0
- QUIT
- Begin DoDot:1
- +3 IF $GET(PSJTMPBG)&$GET(PSJTMPED)
- SET PSJBEG=+PSJTMPBG
- SET PSJEND=+PSJTMPED
- KILL PSJTMPBG,PSJTMPED
- +4 SET PSJNV=0
- if $DATA(^TMP("PSJSELECT",$JOB,"C",PSGP))
- QUIT
- +5 NEW ON,XX
- SET ON=0
- FOR
- SET ON=$ORDER(^PS(53.1,"AS","N",PSGP,ON))
- if 'ON!$GET(PSJNV)
- QUIT
- Begin DoDot:2
- +6 NEW TMPSTRT,TMPSTP
- SET TMPSTRT=$PIECE($GET(^PS(53.1,+ON,2)),"^",2)
- if (TMPSTRT>PSJEND)
- QUIT
- SET TMPSTP=$PIECE($GET(^PS(53.1,+ON,2)),"^",4)
- if (TMPSTP<PSJBEG)
- QUIT
- +7 NEW ND
- SET ND=$GET(^PS(53.1,+ON,0))
- if ((",D,E,")[(","_($EXTRACT($PIECE(ND,"^",9)))_","))
- QUIT
- SET PSJNV=+$GET(^PS(53.1,ON,"DSS"))
- End DoDot:2
- +8 IF 'PSJNV
- DO ^PSJAC
- Begin DoDot:2
- +9 IF '$DATA(PSGDT)
- DO NOW^%DTC
- SET PSGDT=$EXTRACT(%,1,12)
- +10 SET STOPD=PSGDT
- FOR
- SET STOPD=$ORDER(^PS(55,"AUDC",STOPD))
- if 'STOPD!$GET(PSJNV)
- QUIT
- SET CL=0
- FOR
- SET CL=$ORDER(^PS(55,"AUDC",STOPD,CL))
- if 'CL!$GET(PSJNV)
- QUIT
- SET ON2=0
- FOR
- SET ON2=$ORDER(^PS(55,"AUDC",STOPD,CL,PSGP,ON2))
- if 'ON2!$GET(PSJNV)
- QUIT
- Begin DoDot:3
- +11 NEW ND
- SET ND=$GET(^PS(55,PSGP,5,+ON2,0))
- SET TMPSTRT=$PIECE($GET(^PS(55,PSGP,5,+ON2,2)),"^",2)
- if (TMPSTRT>ENDTR)!'$PIECE(^PS(55,PSGP,5,+ON2,8),"^",2)
- QUIT
- +12 if ((",D,E,")[(","_($EXTRACT($PIECE(ND,"^",9)))_","))
- QUIT
- SET ON=+$GET(ON2)_"U"
- SET PSJNV=CL
- End DoDot:3
- +13 SET SD=$$FMADD^XLFDT(PSJBEG,,,-1)
- FOR
- SET SD=$ORDER(^PS(55,PSGP,"IV","AIS",SD))
- if 'SD
- QUIT
- Begin DoDot:3
- +14 FOR ON=0:0
- SET ON=$ORDER(^PS(55,PSGP,"IV","AIS",SD,ON))
- if 'ON
- QUIT
- SET PSJSTAT=$PIECE($GET(^PS(55,PSGP,"IV",ON,0)),"^",17)
- IF (",E,D,")'[(","_$EXTRACT(PSJSTAT)_",")
- DO IFT2
- QUIT
- End DoDot:3
- End DoDot:2
- +15 IF PSJNV
- DO ^PSJAC
- DO SET
- SET PN=$GET(PSGP(0))_U_PSGP_U_PSJPBID
- SET ^TMP("PSJSELECT",$JOB,PSJCNT)=PN
- SET ^TMP("PSJSELECT",$JOB,"B",$PIECE(PN,U),PSJCNT)=""
- SET PSJCNT=PSJCNT+1
- SET ^TMP("PSJSELECT",$JOB,"C",+PSGP)=""
- QUIT
- +16 WRITE !!?3,"No ",PSGVBWW," Clinic Orders found for this patient."
- End DoDot:1
- +17 if $DATA(^TMP("PSJSELECT",$JOB))
- SET Y=1
- +18 IF $GET(PSJTMPBG)&$GET(PSJTMPED)
- SET PSJBEG=+PSJTMPBG
- SET PSJEND=+PSJTMPED
- KILL PSJTMPBG,PSJTMPED
- +19 QUIT
- ARRAY ; put patient(s) with non-verified orders into array
- +1 IF '$DATA(PSGDT)
- DO NOW^%DTC
- SET PSGDT=$EXTRACT(%,1,12)
- +2 SET X1=$PIECE(PSGDT,".")
- SET X2=-2
- DO C^%DTC
- SET PSGODT=X_(PSGDT#1)
- SET PSGVBWW="ACTIVE AND/OR NON-VERIFIED"
- IF PSGSS="P"
- DO IF
- if $TEST
- SET ^TMP("PSGVBW",$JOB)=$PIECE(PSGP(0),"^")_"^"_PSGP
- QUIT
- +3 if PSGSS="C"
- GOTO CL
- +4 if PSGSS="L"
- GOTO CG
- +5 QUIT
- CG ; Find all clinics in selected clinic group
- +1 SET CL=""
- FOR
- SET CL=$ORDER(^PS(57.8,"AD",CG,CL))
- if CL=""
- QUIT
- DO CL
- +2 QUIT
- CL ; Find all patients in selected clinic
- +1 NEW BEGDTR,ENDTR,STOPD,ON2,TMPSTRT,TMPSTOP
- SET BEGDTR=$$FMADD^XLFDT(PSJBEG,,-1)
- SET ENDTR=$$FMADD^XLFDT(PSJEND,,1)
- +2 IF PSGSS="C"
- Begin DoDot:1
- +3 SET CL=""
- FOR
- SET CL=$ORDER(PSJCLNAR(CL))
- if CL=""
- QUIT
- DO CL1
- IF $GET(CL)
- NEW CLINAME
- SET CLINAME=$PIECE($GET(^SC(+$GET(CL),0)),"^")
- if CLINAME=""
- QUIT
- Begin DoDot:2
- +4 NEW I,J
- SET (I,J)=""
- FOR
- SET I=$ORDER(PSJCLNAR(I))
- if 'I
- QUIT
- SET J=J+1
- +5 IF (J>1)
- IF '$DATA(^TMP("PSGVBW",$JOB,CLINAME))
- WRITE !!,$CHAR(7),"NO ",PSGVBWW," ORDERS FOR ",CLINAME,!
- DO CONT^PSJOE0
- End DoDot:2
- End DoDot:1
- QUIT
- +6 IF PSGSS="L"
- DO CL1
- +7 QUIT
- CL1 ; Check each clinic for valid clinic orders
- +1 SET WDN=$SELECT($DATA(^SC(CL,0)):$PIECE(^(0),"^"),1:"")
- +2 SET PSGP=""
- SET PSGCLF=1
- FOR
- SET PSGP=$ORDER(^PS(53.1,"AD",CL,PSGP))
- if PSGP=""
- QUIT
- DO ^PSJAC
- DO IF
- +3 SET STOPD=PSGDT
- FOR
- SET STOPD=$ORDER(^PS(55,"AUDC",STOPD))
- if 'STOPD
- QUIT
- SET PSGP=0
- FOR
- SET PSGP=$ORDER(^PS(55,"AUDC",STOPD,CL,PSGP))
- if 'PSGP
- QUIT
- SET ON2=0
- FOR
- SET ON2=$ORDER(^PS(55,"AUDC",STOPD,CL,PSGP,ON2))
- if 'ON2
- QUIT
- Begin DoDot:1
- +4 SET TMPSTRT=$PIECE($GET(^PS(55,PSGP,5,+ON2,2)),"^",2)
- SET TMPSTOP=$PIECE($GET(^PS(55,PSGP,5,+ON2,2)),"^",4)
- +5 IF TMPSTRT<ENDTR
- IF (TMPSTOP>BEGDTR)
- if $EXTRACT($PIECE($GET(^PS(55,PSGP,5,+ON2,0)),"^",9))="D"
- QUIT
- SET ON=+$GET(ON2)_"U"
- DO ^PSJAC
- DO SET
- End DoDot:1
- +6 SET STOPD=PSGDT
- FOR
- SET STOPD=$ORDER(^PS(55,"AIVC",STOPD))
- if 'STOPD
- QUIT
- SET PSGP=0
- FOR
- SET PSGP=$ORDER(^PS(55,"AIVC",STOPD,CL,PSGP))
- if 'PSGP
- QUIT
- SET ON2=0
- FOR
- SET ON2=$ORDER(^PS(55,"AIVC",STOPD,CL,PSGP,ON2))
- if 'ON2
- QUIT
- Begin DoDot:1
- +7 SET TMPSTRT=$PIECE($GET(^PS(55,PSGP,"IV",+ON2,0)),"^",2)
- SET TMPSTOP=$PIECE($GET(^PS(55,PSGP,"IV",+ON2,0)),"^",3)
- +8 IF TMPSTRT<ENDTR
- IF (TMPSTOP>BEGDTR)
- if $EXTRACT($PIECE($GET(^PS(55,PSGP,"IV",+ON2,0)),"^",17))="D"
- QUIT
- SET ON=+$GET(ON2)_"V"
- DO ^PSJAC
- DO SET
- End DoDot:1
- +9 KILL PSGCLF,TMPSTRT
- +10 QUIT
- IF ; If called from CL subroutine and the order Doesn't exist for that Clinic, then QUIT.
- +1 NEW PSJSTAT,ON2
- +2 IF $DATA(^PS(53.1,"AS","N",PSGP))
- NEW XX
- SET XX=0
- SET ON2=0
- FOR
- SET ON2=$ORDER(^PS(53.1,"AS","N",PSGP,ON2))
- if 'ON2
- QUIT
- NEW CLIN
- SET CLIN=+$GET(^PS(53.1,+$GET(ON2),"DSS"))
- if 'CLIN
- QUIT
- Begin DoDot:1
- +3 SET XX=$SELECT(PSGSS'="P"&$DATA(PSJCLNAR(+CLIN)):CLIN,1:CLIN)
- SET ND=$PIECE($GET(^PS(53.1,ON2,0)),U,4)
- SET TMPSTRT=$PIECE($GET(^PS(53.1,ON2,2)),U,2)
- SET TMPSTP=$PIECE($GET(^PS(53.1,ON2,2)),U,4)
- IF $GET(XX)
- Begin DoDot:2
- +4 if TMPSTRT>$SELECT($GET(ENDTR)
- QUIT
- if TMPSTP<$SELECT($GET(BEGDTR)
- QUIT
- +5 SET PSJSTAT=$PIECE($GET(^PS(53.1,ON2,0)),"^",9)
- if PSJSTAT'="N"
- QUIT
- +6 NEW ON
- SET ON=ON2_"P"
- DO ^PSJAC
- DO SET
- End DoDot:2
- End DoDot:1
- +7 SET PSGODT=$PIECE(PSJBEG,".")
- +8 IF PSJPAC'=2
- FOR ST="C","O","OC","P","R"
- SET SD=PSGODT
- FOR
- SET SD=$ORDER(^PS(55,PSGP,5,"AU",ST,SD))
- if 'SD
- QUIT
- SET ON2=0
- FOR
- SET ON2=$ORDER(^PS(55,PSGP,5,"AU",ST,SD,ON2))
- if 'ON2
- QUIT
- SET PSJSTAT=$PIECE($GET(^PS(55,PSGP,5,ON2,0)),"^",9)
- Begin DoDot:1
- +9 IF (PSJSTAT]"")&((",D,E,"'[(","_$EXTRACT(PSJSTAT)_",")))
- SET ON=ON2_"U"
- DO SET
- End DoDot:1
- +10 ;*PSJ*5*241:Expired IV orders must be one-time
- +11 IF PSJPAC'=1
- SET SD=$$FMADD^XLFDT(PSJBEG,,,-1)
- FOR
- SET SD=$ORDER(^PS(55,PSGP,"IV","AIS",SD))
- if 'SD
- QUIT
- SET ON2=0
- FOR
- SET ON2=$ORDER(^PS(55,PSGP,"IV","AIS",SD,ON2))
- if 'ON2
- QUIT
- Begin DoDot:1
- +12 NEW SCH,STYPE
- SET STYPE=0
- SET SCH=$PIECE($GET(^PS(55,PSGP,"IV",ON2,0)),U,9)
- +13 if SCH]""
- SET SCH=$ORDER(^PS(51.1,"APPSJ",SCH,STYPE))
- if SCH]""
- SET STYPE=$PIECE($GET(^PS(51.1,SCH,0)),U,5)
- +14 SET PSJSTAT=$PIECE($GET(^PS(55,PSGP,"IV",+ON2,0)),"^",17)
- +15 IF ",D,E,"'[(","_$EXTRACT(PSJSTAT)_",")
- IF ($GET(STYPE)'="O")
- SET ON=ON2_"V"
- DO IFT2
- DO SET
- End DoDot:1
- +16 KILL TMPSTRT
- +17 QUIT
- IFT2 ; Loop through active IV orders in ^PS(55
- +1 NEW CL,TMPSTRT,TMPSTP
- SET CL=+$GET(^PS(55,+$GET(PSGP),"IV",+$GET(ON),"DSS"))
- +2 SET ND0=$GET(^PS(55,PSGP,"IV",+ON,0))
- SET TMPSTRT=$PIECE(ND0,"^",2)
- SET TMPSTP=$PIECE(ND0,"^",3)
- if ((TMPSTRT>PSJEND)!(TMPSTP<PSJBEG))
- QUIT
- +3 if ((",D,E,")[(","_($EXTRACT($PIECE(ND0,"^",17)))_","))
- QUIT
- +4 SET PSJNV=CL
- +5 QUIT
- SET ; Set patient specific variables for ^TMP subscripts
- +1 KILL DIC,X,Y,WDNAME,TMPWD
- +2 NEW PSJSTAT,TMPSTRT,TMPSTP
- SET TMPSTRT=$SELECT($GET(ON)["P":$PIECE($GET(^PS(53.1,ON,2)),U,2),$GET(ON)["U":$PIECE($GET(^PS(55,PSGP,5,+ON,2)),"^",2),$GET(ON)["V":$PIECE($GET(^PS(55,PSGP,"IV",+ON,0)),"^",2),1:"")
- +3 SET TMPSTP=$SELECT($GET(ON)["P":$PIECE($GET(^PS(53.1,+ON,2)),U,4),$GET(ON)["U":$PIECE($GET(^PS(55,PSGP,5,+ON,2)),"^",4),$GET(ON)["V":$PIECE($GET(^PS(55,PSGP,"IV",+ON,0)),"^",3),1:"")
- +4 if TMPSTRT>$SELECT($GET(ENDTR)
- QUIT
- if TMPSTP<$SELECT($GET(BEGDTR)
- QUIT
- +5 SET PSJSTAT=$SELECT($GET(ON)["P":$PIECE($GET(^PS(53.1,+ON,0)),"^",9),$GET(ON)["U":$PIECE($GET(^PS(55,PSGP,5,+ON,0)),"^",9),$GET(ON)["V":$PIECE($GET(^PS(55,PSGP,"IV",+ON,0)),"^",17),1:"")
- +6 if PSJSTAT=""
- QUIT
- if (",D,E,")[(","_$EXTRACT(PSJSTAT)_",")
- QUIT
- +7 SET X=$SELECT($GET(ON)["P":$GET(^PS(53.1,+ON,"DSS")),$GET(ON)["U":$GET(^PS(55,PSGP,5,+ON,8)),$GET(ON)["V":$GET(^PS(55,PSGP,"IV",+ON,"DSS")),1:"")
- +8 if 'X
- QUIT
- if '$PIECE(X,"^",2)
- QUIT
- SET X=+X
- +9 SET X="`"_+X
- SET DIC="^SC("
- SET DIC(0)="BOXZ"
- DO ^DIC
- SET TMPWD=+Y
- SET (WDN,WDNAME)=$PIECE(Y,"^",2)
- +10 IF $GET(PSGSS)'="P"
- IF $GET(TMPWD)
- IF '$DATA(PSJCLNAR(+TMPWD))
- QUIT
- +11 SET TM=$SELECT(PSJPRB="":"",1:$PIECE($GET(^PS(57.7,TMPWD,1,+$ORDER(^PS(57.7,"AWRT",TMPWD,PSJPRB,0)),0)),"^"))
- if TM=""
- SET TM="zz"
- SETPN ; If searching for specific priority:
- +1 ; - set patient into ^TMP("PSGBW" sorted by Clnic, Patient Name^IEN^SSN
- +2 ; If not searching for specific priority:
- +3 ; - set patient into ^TMP("PSGVBW2" sorted by 'Patient Name^IEN^SSN',
- +4 ; - set patient into ^TMP("PSGVBW3" sorted by Patient IEN
- +5 SET PN=$PIECE(PSGP(0),"^")_U_PSGP_U_PSJPBID
- +6 SET ^TMP("PSGVBW",$JOB,WDN,1,TM,PN)=$SELECT($GET(TMPWD):TMPWD,1:"")
- +7 SET ^TMP("PSGVBW2",$JOB,PN,1)=WDN_"^"_TM
- SET ^TMP("PSGVBW3",$JOB,WDN,+PSGP)=TMPWD
- +8 QUIT
- SET2 ; If not searching for a specific priority,find the highest priority order associated with patient.
- +1 ; Set the patient into ^TMP("PSGVBW" sorted by highest Priority Name, Priority #, Team, Patient Name^IEN^SSN
- +2 SET SETPN=""
- FOR
- SET SETPN=$ORDER(^TMP("PSGVBW2",$JOB,SETPN))
- if SETPN=""
- QUIT
- Begin DoDot:1
- +3 SET PTPRI=$ORDER(^TMP("PSGVBW2",$JOB,SETPN,0))
- if '$GET(PTPRI)
- QUIT
- +4 SET SUBS=$GET(^TMP("PSGVBW2",$JOB,SETPN,PTPRI))
- SET SETWDN=$PIECE(SUBS,"^")
- SET SETTM=$PIECE(SUBS,"^",2)
- if SETWDN=""!(SETTM="")
- QUIT
- +5 SET ^TMP("PSGVBW",$JOB,SETWDN,1,SETTM,SETPN)=""
- End DoDot:1
- +6 KILL ^TMP("PSGVBW2",$JOB)
- +7 QUIT
- +8 ;
- EXIT(X) ; Generic user error message
- +1 WRITE !!,X," not selected, option terminated."
- +2 QUIT
- +3 ;
- SELECT ; give user choice to select search method
- +1 SET PSJVALQ=0
- +2 if '$DATA(PSGSSH)
- SET PSGSSH="GENERIC"
- +3 ;
- +4 NEW PSJCLNAR
- +5 FOR
- WRITE !!,"Search by CLINIC (C), CLINIC GROUP (G), or PATIENT (P) : "
- READ PSGSS:DTIME
- if '$TEST
- WRITE $CHAR(7)
- if '$TEST!(PSGSS="")
- SET PSGSS="^"
- if "^"[PSGSS
- QUIT
- DO CHK
- IF ",C,P,L,"[(","_PSGSS_",")
- QUIT
- +6 ;
- +7 KILL PSGSSA
- QUIT
- +8 ;
- CHK ;
- +1 NEW Q
- +2 SET PSGSSA=""
- FOR Q=1:1:$LENGTH(PSGSS)
- SET PSGSSA=PSGSSA_$SELECT($EXTRACT(PSGSS,Q)'?1L:$EXTRACT(PSGSS,Q),1:$CHAR($ASCII(PSGSS,Q)-32))
- +3 FOR X="CLINIC","PATIENT","GROUP"
- IF $PIECE(X,PSGSSA)=""
- WRITE $PIECE(X,PSGSSA,2,99)
- SET PSGSS=$SELECT(($EXTRACT(PSGSSA)="G"):"L",1:$EXTRACT(PSGSSA))
- QUIT
- +4 if $TEST
- QUIT
- IF PSGSS'?1."?"
- WRITE $CHAR(7)," ??"
- SET PSGSS="Z"
- QUIT
- +5 WRITE !
- DO @PSGSSH
- WRITE !!?2,"To leave this option, press the RETURN key or enter '^'."
- QUIT
- +6 ;
- CHK2 ;
- +1 NEW Q
- +2 SET PSGSSA=""
- FOR Q=1:1:$LENGTH(PSGSS2)
- SET PSGSSA=PSGSSA_$SELECT($EXTRACT(PSGSS2,Q)'?1L:$EXTRACT(PSGSS2,Q),1:$CHAR($ASCII(PSGSS2,Q)-32))
- +3 FOR X="WARD","CLINIC","GROUP"
- IF $PIECE(X,PSGSSA)=""
- WRITE $PIECE(X,PSGSSA,2,99)
- SET PSGSS2=$SELECT(($EXTRACT(PSGSSA)="G"):"L",1:$EXTRACT(PSGSSA))
- QUIT
- +4 if $TEST
- QUIT
- IF PSGSS2'?1."?"
- WRITE $CHAR(7)," ??"
- SET PSGSS2="Z"
- QUIT
- +5 WRITE !
- DO @PSGSSH
- WRITE !!?2,"To leave this option, press the RETURN key or enter '^'."
- QUIT
- +6 ;
- HELP ; the following are the help text messages for the various options
- +1 ;
- GENERIC WRITE !!,?2,"To run this option for an entire CLINIC, enter 'C'. To run this option for a single PATIENT, enter 'P'."
- QUIT
- +1 ;
- VBW WRITE !!?2,"To process orders in a single CLINIC, enter 'C'."
- +1 WRITE !,"To process orders for a single PATIENT, enter 'P'."
- +2 QUIT
- +3 ;
- ENCD ;edit Clinic Definitions file
- +1 IF X["?"
- WRITE !,"Enter a clinic from the CLINIC DEFINITION file."
- +2 ; S:(Y>0) Y=+$G(^PS(53.46,+Y,0))
- KILL DIC
- SET DIC="^PS(53.46,"
- SET DIC(0)="QEMIZ"
- DO ^DIC
- KILL DIC
- +3 WRITE !,"You may also select a clinic from the HOSPITAL LOCATION file."
- +4 KILL DIC
- SET DIC="^SC("
- SET DIC(0)="QEMIZ"
- DO ^DIC
- KILL DIC
- +5 QUIT