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 Apr 09, 2024@21:08:52 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
