Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PSJCLOR

PSJCLOR.m

Go to the documentation of this file.
  1. 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
  1. ;
  1. ; Reference to ^PS(55 is supported by DBIA #2191
  1. ; Reference to ^PS(51.1 is supported by DBIA #2177
  1. ; Reference to ^DPT is supported by DBIA #10035
  1. ;
  1. N PSJNEW,PSGPTMP,PPAGE,CL,CG S PSJNEW=1
  1. START ; Lookup patient by clinic or patient, depending on value of PSGSS
  1. ;
  1. N PSJTOO,PSJPAC,PSJBEG,PSJEND,PSGOEAV,PSJTMPED,PSJTMPBG,PSJCLOR,PSGSS S PSJTOO=3,PSJPAC=3,PSJCLOR=1,PSGSS=""
  1. D ENCV^PSGSETU I $D(XQUIT) K XQUIT Q
  1. D ^PSIVXU I $D(XQUIT) K XQUIT Q
  1. Q:$G(DONE) ;P407
  1. D NOW^%DTC S PSGDT=%
  1. K ^TMP("PSJ",$J) S PSGPXN=0 L +^PS(53.45,PSJSYSP):1 E D LOCKERR^PSJOE G DONE
  1. S PSGSSH="VBW",PSGPXN=0,PSJPROT=$S($P(PSJSYSU,";",3)=3:3,1:1)
  1. S PSGVBWW="ACTIVE AND/OR NON-VERIFIED"
  1. S PSGOEAV=$P(PSJSYSP0,"^",9)&PSJSYSU
  1. 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
  1. ;
  1. DONE ; Cleanup
  1. D DONE2
  1. K SETWDN,PTPRI,SETTM,SETPN,SUBS,TMPWD,STATUS,X1,X2,PSJBEG,PSJEND
  1. 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
  1. K PSGODDD,PSGOEORF,PSJORL,PSJORPCL,PSJORTOU,PSJORVP,PSGTOL,PSJTOO,PSGUOW,PSGONV,PX,PSGOEAV,PSGPX,PSGVBWTO,PSGVBWW,PSJOPC,PSGOENOF,PSJPROT,PSJLM,PSJASK
  1. K PSJPAC,PSJINDEX,PSJCNT,PSIVSN,PSGWORP1,PSGWORP2,PSGVBY,PSGVBWN,PSGVBTM,PSGVBPN,PSGPRIN,PSGPRD,PSGINWD,PSGINCL,PRDON,PRDNS,PRD,PPN,ORDT
  1. K %,DTOUT,DUOUT,ND0,PSGSS2,PSGDT,PSJNV,PSJPBID,PSJPAD,%Y,IOP,POP,PSGDICA,PSGH,PSJEXTP,PSJH,PSJHDATE,PSJPAD
  1. K PSJPAGE,PSJPBID,PSJPCAF,PSJPDD,PSJPDOB,PSJPDX,PSJPPID,PSJPRB,PSJPSEX,PSJPSSN,PSJPTD,PSJPTS,PSJPTSP,PSJPWD,PSJPWDN
  1. 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
  1. K PSJTEAM,PSJPSTO,PSJPINIT,PSJORIFN,PSJORF,PSJORD,PSJONTMP,PSJOL,PSJOCL,PSJO,PSJNOO,PSJMSG,PSJLOOP,PSJLMX,PSJLACT,PSJIVORF,PSJHLMTN,PSJDB,PSJDAY,PSJCOUNT
  1. K PSJCLIN,PSJBLOOP,PSJBLN,PSJBCID,PSJACNWP,PSJ,PSIVUP,PSIVTYPE,PSIVSTRT,PSIVITE,PSIVRT,PSIVRP,PSIVREA,PSIVPR,PSIVPL,PSIVNOW,PSIVLN,PSIVLIM,PSIVC,PSIVACT
  1. K PSIVAC,PSGVALG,PSGVADR,PSGSTAT,PSGST,PSGSM,PSGSDN,PSGSCH,PSGS0XT,PSGPRN,PSGPR,PSGPENWS,PSGPEN,PSGPDN,PSGPD,PSGOSTN,PSGOST,PSGOSM,PSGOSI,PSGOSDN,PSGOSCH
  1. K PSGORD,PSGOPRN,PSGPR,PSGOPDN,PSGOPD,PSGOORD,PSGOMRN,PSGOMR,PSGOL,PSGOINST,PSGOHSM,PSGOFDN,PSGOEPR,PSGOEEWF,PSGOEENO,PSGOEE,PSGODO,PSGOC,PSGOAT,PSGNEFDO
  1. K PSGLRN,PSGLI,PSGFDX,PSGDFN,PSGF2,PSGEBN,PSGEB,PSGDW,PSGCANFL,PSGAL,PSBSTR,PSBFLAG,PSBCNT,P,PDRG,ORO,OD,OCXSEG,NF,NDP2,ND6,ND4,ND14
  1. L -^PS(53.45,PSJSYSP) G:$G(PSGPXN) ^PSGPER1 D ENKV^PSGSETU K ND,PSGPXN Q
  1. ;
  1. DONE2 ; Partial Cleanup
  1. K ^TMP("PSGVBW",$J),^TMP("PSGVBW2",$J),^TMP("PSGVBW3",$J),^TMP("PSJSELECT",$J),^TMP("PSJLIST",$J),^TMP("PSJON",$J)
  1. K PRD,PSJL,DFN,PSGP
  1. Q
  1. ;
  1. GO ; Find and display matching patients
  1. 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
  1. 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
  1. D ^PSJCLOR1,DONE2 Q
  1. ;
  1. C ; Select a Clinic
  1. K CL,DIC,PSJCLNAR,PSJCDONE
  1. 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
  1. Q
  1. CDIC ; Clinic lookup
  1. I $G(PSJCDONE) S:($O(PSJCLNAR(0))&'$G(DUOUT)) Y=+$O(PSJCLNAR(0)) Q
  1. S DIC="^SC(",DIC(0)="QEMIZ" D ^DIC K DIC I Y>0 S CL=+Y,PSJCLNAR(+Y)=""
  1. I Y="" S PSJCDONE=1 Q
  1. I $G(DTOUT)!$G(DUTOUT) S PSJCDONE=1 Q
  1. W:X["?" !!,"Enter the clinic you want to use to select patients for processing.",!
  1. I '$G(DUOUT),($G(Y)<0),($G(X)'="") S X="?"
  1. I X["?" W !!,"Enter the name of the clinic to use to select patients for processing." G C
  1. Q:'$G(CL)
  1. DTRANGE() ; Enter Date Range
  1. K PSJBEG,PSJEND
  1. D BEGDT I ($G(PSJBEG)<1) S Y=0 Q 0
  1. D ENDDT(PSJBEG) I ($G(PSJEND)<1) S Y=0 Q 0
  1. Q Y
  1. BEGDT ; begin date
  1. W !!?5,"Search for Active and Non-Verified CLINIC Medication Orders"
  1. W !?5,"that fall within the date range selected below: "
  1. W ! K %DT S %DT("A")="Begin Search Date: ",%DT="TAE",%DT("B")="TODAY"
  1. D ^%DT Q:Y<0!($D(DTOUT)) S (%DT(0),PSJBEG,PSJTMPBG)=Y
  1. 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
  1. Q
  1. ENDDT(BEG) ; end date
  1. N YRONLY,FMTX
  1. W ! K DIR S DIR(0)="DA^"_BEG_"::TAE",DIR("A")="End Search Date: ",DIR("B")=$P($$FMTE^XLFDT(BEG,1),"@") D ^DIR
  1. S PSJEND=$S($G(Y):Y,1:BEG) I '$P(PSJEND,".",2) S PSJEND=Y_".24",PSJTMPED=PSJEND
  1. 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
  1. .S PSJEND=YRONLY S FMTX=$$FMTE^XLFDT(PSJEND,1) W " ",FMTX
  1. Q
  1. L ; Select a Clinic Group
  1. K DIR,PSJCLNAR S DIR(0)="FAO",DIR("A")="Select CLINIC GROUP: "
  1. S DIR("?")="^D LDIC^PSGVBW" W ! D ^DIR
  1. LDIC ; Clinic Group lookup
  1. K DIC S DIC="^PS(57.8,",DIC(0)="QEMI" D ^DIC K DIC S:+Y>0 CG=+Y
  1. 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)=""
  1. I '$G(DUOUT),($G(Y)<0),($G(X)'="") S X="?"
  1. I X["?" W !!,"Enter the name of the clinic group to use to select patients for processing." G L
  1. Q
  1. P ; Select patient
  1. 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=""
  1. K ^TMP("PSJSELECT",$J) S PSJCNT=1 F D ^PSJP Q:PSGP<0 D
  1. .I $G(PSJTMPBG)&$G(PSJTMPED) S PSJBEG=+PSJTMPBG,PSJEND=+PSJTMPED K PSJTMPBG,PSJTMPED
  1. .S PSJNV=0 Q:$D(^TMP("PSJSELECT",$J,"C",PSGP))
  1. .NEW ON,XX S ON=0 F S ON=$O(^PS(53.1,"AS","N",PSGP,ON)) Q:'ON!$G(PSJNV) D
  1. ..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)
  1. ..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"))
  1. .I 'PSJNV D ^PSJAC D
  1. ..I '$D(PSGDT) D NOW^%DTC S PSGDT=$E(%,1,12)
  1. ..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
  1. ...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)
  1. ...Q:((",D,E,")[(","_($E($P(ND,"^",9)))_",")) S ON=+$G(ON2)_"U" S PSJNV=CL
  1. ..S SD=$$FMADD^XLFDT(PSJBEG,,,-1) F S SD=$O(^PS(55,PSGP,"IV","AIS",SD)) Q:'SD D
  1. ...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
  1. .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
  1. .W !!?3,"No ",PSGVBWW," Clinic Orders found for this patient."
  1. S:$D(^TMP("PSJSELECT",$J)) Y=1
  1. I $G(PSJTMPBG)&$G(PSJTMPED) S PSJBEG=+PSJTMPBG,PSJEND=+PSJTMPED K PSJTMPBG,PSJTMPED
  1. Q
  1. ARRAY ; put patient(s) with non-verified orders into array
  1. I '$D(PSGDT) D NOW^%DTC S PSGDT=$E(%,1,12)
  1. 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
  1. G CL:PSGSS="C"
  1. G CG:PSGSS="L"
  1. Q
  1. CG ; Find all clinics in selected clinic group
  1. S CL="" F S CL=$O(^PS(57.8,"AD",CG,CL)) Q:CL="" D CL
  1. Q
  1. CL ; Find all patients in selected clinic
  1. N BEGDTR,ENDTR,STOPD,ON2,TMPSTRT,TMPSTOP S BEGDTR=$$FMADD^XLFDT(PSJBEG,,-1),ENDTR=$$FMADD^XLFDT(PSJEND,,1)
  1. I PSGSS="C" D Q
  1. .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
  1. ..N I,J S (I,J)="" F S I=$O(PSJCLNAR(I)) Q:'I S J=J+1
  1. ..I (J>1),'$D(^TMP("PSGVBW",$J,CLINAME)) W !!,$C(7),"NO ",PSGVBWW," ORDERS FOR ",CLINAME,! D CONT^PSJOE0
  1. I PSGSS="L" D CL1
  1. Q
  1. CL1 ; Check each clinic for valid clinic orders
  1. S WDN=$S($D(^SC(CL,0)):$P(^(0),"^"),1:"")
  1. S PSGP="",PSGCLF=1 F S PSGP=$O(^PS(53.1,"AD",CL,PSGP)) Q:PSGP="" D ^PSJAC,IF
  1. 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
  1. .S TMPSTRT=$P($G(^PS(55,PSGP,5,+ON2,2)),"^",2),TMPSTOP=$P($G(^PS(55,PSGP,5,+ON2,2)),"^",4)
  1. .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
  1. 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
  1. .S TMPSTRT=$P($G(^PS(55,PSGP,"IV",+ON2,0)),"^",2),TMPSTOP=$P($G(^PS(55,PSGP,"IV",+ON2,0)),"^",3)
  1. .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
  1. K PSGCLF,TMPSTRT
  1. Q
  1. IF ; If called from CL subroutine and the order Doesn't exist for that Clinic, then QUIT.
  1. N PSJSTAT,ON2
  1. 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
  1. .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
  1. ..Q:TMPSTRT>$S($G(ENDTR):ENDTR,1:$G(PSJEND)) Q:TMPSTP<$S($G(BEGDTR):BEGDTR,1:$G(PSJBEG))
  1. ..S PSJSTAT=$P($G(^PS(53.1,ON2,0)),"^",9) Q:PSJSTAT'="N"
  1. ..N ON S ON=ON2_"P" D ^PSJAC,SET
  1. S PSGODT=$P(PSJBEG,".")
  1. 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
  1. .I (PSJSTAT]"")&((",D,E,"'[(","_$E(PSJSTAT)_","))) S ON=ON2_"U" D SET
  1. ;*PSJ*5*241:Expired IV orders must be one-time
  1. 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
  1. .N SCH,STYPE S STYPE=0,SCH=$P($G(^PS(55,PSGP,"IV",ON2,0)),U,9)
  1. .S:SCH]"" SCH=$O(^PS(51.1,"APPSJ",SCH,STYPE)) S:SCH]"" STYPE=$P($G(^PS(51.1,SCH,0)),U,5)
  1. .S PSJSTAT=$P($G(^PS(55,PSGP,"IV",+ON2,0)),"^",17)
  1. .I ",D,E,"'[(","_$E(PSJSTAT)_",") I ($G(STYPE)'="O") S ON=ON2_"V" D IFT2,SET
  1. K TMPSTRT
  1. Q
  1. IFT2 ; Loop through active IV orders in ^PS(55
  1. N CL,TMPSTRT,TMPSTP S CL=+$G(^PS(55,+$G(PSGP),"IV",+$G(ON),"DSS"))
  1. S ND0=$G(^PS(55,PSGP,"IV",+ON,0)) S TMPSTRT=$P(ND0,"^",2),TMPSTP=$P(ND0,"^",3) Q:((TMPSTRT>PSJEND)!(TMPSTP<PSJBEG))
  1. Q:((",D,E,")[(","_($E($P(ND0,"^",17)))_","))
  1. S PSJNV=CL
  1. Q
  1. SET ; Set patient specific variables for ^TMP subscripts
  1. K DIC,X,Y,WDNAME,TMPWD
  1. 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:"")
  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:"")
  1. Q:TMPSTRT>$S($G(ENDTR):ENDTR,1:$G(PSJEND)) Q:TMPSTP<$S($G(BEGDTR):BEGDTR,1:$G(PSJBEG))
  1. 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:"")
  1. Q:PSJSTAT="" Q:(",D,E,")[(","_$E(PSJSTAT)_",")
  1. 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:"")
  1. Q:'X Q:'$P(X,"^",2) S X=+X
  1. S X="`"_+X,DIC="^SC(",DIC(0)="BOXZ" D ^DIC S TMPWD=+Y,(WDN,WDNAME)=$P(Y,"^",2)
  1. I $G(PSGSS)'="P",$G(TMPWD),'$D(PSJCLNAR(+TMPWD)) Q
  1. 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"
  1. SETPN ; If searching for specific priority:
  1. ; - set patient into ^TMP("PSGBW" sorted by Clnic, Patient Name^IEN^SSN
  1. ; If not searching for specific priority:
  1. ; - set patient into ^TMP("PSGVBW2" sorted by 'Patient Name^IEN^SSN',
  1. ; - set patient into ^TMP("PSGVBW3" sorted by Patient IEN
  1. S PN=$P(PSGP(0),"^")_U_PSGP_U_PSJPBID
  1. S ^TMP("PSGVBW",$J,WDN,1,TM,PN)=$S($G(TMPWD):TMPWD,1:"")
  1. S ^TMP("PSGVBW2",$J,PN,1)=WDN_"^"_TM,^TMP("PSGVBW3",$J,WDN,+PSGP)=TMPWD
  1. Q
  1. 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
  1. S SETPN="" F S SETPN=$O(^TMP("PSGVBW2",$J,SETPN)) Q:SETPN="" D
  1. .S PTPRI=$O(^TMP("PSGVBW2",$J,SETPN,0)) Q:'$G(PTPRI)
  1. .S SUBS=$G(^TMP("PSGVBW2",$J,SETPN,PTPRI)),SETWDN=$P(SUBS,"^"),SETTM=$P(SUBS,"^",2) Q:SETWDN=""!(SETTM="")
  1. .S ^TMP("PSGVBW",$J,SETWDN,1,SETTM,SETPN)=""
  1. K ^TMP("PSGVBW2",$J)
  1. Q
  1. ;
  1. EXIT(X) ; Generic user error message
  1. W !!,X," not selected, option terminated."
  1. Q
  1. ;
  1. SELECT ; give user choice to select search method
  1. S PSJVALQ=0
  1. S:'$D(PSGSSH) PSGSSH="GENERIC"
  1. ;
  1. N PSJCLNAR
  1. 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
  1. ;
  1. K PSGSSA Q
  1. ;
  1. CHK ;
  1. N Q
  1. 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))
  1. 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
  1. Q:$T I PSGSS'?1."?" W $C(7)," ??" S PSGSS="Z" Q
  1. W ! D @PSGSSH W !!?2,"To leave this option, press the RETURN key or enter '^'." Q
  1. ;
  1. CHK2 ;
  1. N Q
  1. 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))
  1. 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
  1. Q:$T I PSGSS2'?1."?" W $C(7)," ??" S PSGSS2="Z" Q
  1. W ! D @PSGSSH W !!?2,"To leave this option, press the RETURN key or enter '^'." Q
  1. ;
  1. HELP ; the following are the help text messages for the various options
  1. ;
  1. GENERIC W !!,?2,"To run this option for an entire CLINIC, enter 'C'. To run this option for a single PATIENT, enter 'P'." Q
  1. ;
  1. VBW W !!?2,"To process orders in a single CLINIC, enter 'C'."
  1. W !,"To process orders for a single PATIENT, enter 'P'."
  1. Q
  1. ;
  1. ENCD ;edit Clinic Definitions file
  1. I X["?" W !,"Enter a clinic from the CLINIC DEFINITION file."
  1. K DIC S DIC="^PS(53.46,",DIC(0)="QEMIZ" D ^DIC K DIC ; S:(Y>0) Y=+$G(^PS(53.46,+Y,0))
  1. W !,"You may also select a clinic from the HOSPITAL LOCATION file."
  1. K DIC S DIC="^SC(",DIC(0)="QEMIZ" D ^DIC K DIC
  1. Q