PSJMDWS ;BIR/MV-MAIN DRIVER FOR MED DUE WORKSHEET ;18 JUN 96 / 2:58 PM
;;5.0; INPATIENT MEDICATIONS ;**31,34,111**;16 DEC 97
;
;
S PSJSTOP=0 K ^TMP($J)
D ASK G:PSJSTOP EXIT
EN I $D(IO("Q")) D G EXIT
. NEW XDESC,XSAVE,XTRTN
. S XDESC="Med Due Worksheet (SORT)"
. S XSAVE="PSGIO;PSGMTYPE;PSGP;PSGP(;PSGPAT(;PSGPLF;PSGPLS;PSGRBADM;PSGSS;PSGTM;PSGTM(;PSGTMALL;PSGWD;PSGWG;PSGWGNM;PSGWN;PSJMPRN;PSGIODOC"
. S XTRTN="SORTQ^PSJMDWS" D SETSORTQ^PSJMUTL(XDESC,XSAVE,XTRTN)
D SORTQ
Q
SORTQ ;*** Entry when queue to do the sorting.
NEW ADMIN,CD,DRG,DRGI,DRGN,DRGT,ON,MID,MN,ND,ND1,OD,PLSD,PSIVUP,PSJORIFN,PST,QST,RBNO,ST,T,TM,TMNO,TS,UD0,UD2,XTYPE
D:PSGSS="G" ^PSJMEDS
D:PSGSS="W" WARD^PSJMEDS
I PSGSS="C" S PSGWG="^OTHER" D ^PSJMEDS
I PSGSS="P" S PPN="" F S PPN=$O(PSGPAT(PPN)) Q:PPN="" S PSGP=PSGPAT(PPN) S PSJACNWP="" D ^PSJAC D MEDTYPE^PSJMEDS
I $D(PSGIO) D G EXIT
. NEW XDESC,XSAVE,XTRTN
. S XDESC="Med Due Worksheet (PRINT)"
. S XSAVE="PSGMTYPE;PSGP;PSGP(;PSGPAT(;PSGPLF;PSGPLS;PSGRBADM;PSGSS;PSGTM;PSGTM(;PSGTMALL;PSGWD;PSGWG;PSGWGNM;PSGWN;PSJMPRN;^TMP($J,;PSGIODOC"
. S XTRTN="PRTQ^PSJMDWS" D SETPRTQ^PSJMUTL(XDESC,XSAVE,XTRTN)
PRTQ ;*** Entry when queue to the printer.
D ^PSJMPRT
;
;
EXIT ;
K ^TMP($J)
D EXITDEV^PSJMUTL,EXIT^PSJMUTL
D ENKV^PSGSETU ;*** Kill var called from ^PSJAC
K PFLG,PPN,PSGEXPDT,PSGIO,PSGLFD,PSGLOD,PSGLSD,PSGMAR,PSGMARWD,PSGMFOR,PSGMTYPE,PSGOES,PSGON,PSGP,PSGPAT,PSGPG,PSGPLC,PSGPLF,PSGPLO
K PSGPLS,PSGRBADM,PSGRBPPN,PSGRETF,PSGS0XT,PSGS0Y,PSGSS,PSGTM,PSGTMALL,PSGTMP,PSGTMP1,PSGWD,PSGWG,PSGWGNM
K PSGWN,PSGWN1,PSJACNWP,PSJADT,PSJADT1,PSJADTO,PSJADTME,PSJATME1,PSJATMEO
K PSJASTR,PSJATME,PSJATMEO,PSJDOS,PSJHL1,PSJHL2,PSJHL3,PSJHL62,PSJHOLD,PSJLN,PSJMPRN,PSJMR,PSJNEED,PSJONCAL,PSJONETM
K PSJPLC,PSJPRB,PSJPRT,PSJPWDN,PSJPWDO,PSJSCHE,PSJSI,PSJSTOP,PSJTOTLN,ZSTOP,ZTQUEUED
Q
;
;
ASK ;***Prompt for selection creteria. Quit when PSJSTOP=1
;
Q:$$PRN^PSJMDIR S PSJMPRN=Y
Q:$$STDATE^PSJMDIR S (X1,PSGTMP)=Y,X2=1 D C^%DTC S PSGTMP1=X,PSGPLS=Y
Q:$$ENDATE^PSJMDIR(PSGTMP,PSGTMP1) S PSGPLF=Y
Q:$$GWP^PSJMDIR1(1)
Q:$$MEDTYPE^PSJMDIR($G(PSGWD)) S PSGMTYPE=Y
Q:$$SELDEV^PSJMUTL
Q
;
ENLM ;Enrty Point for PSJ LM MDWS protocol
;
NEW VADM S PSJSTOP=0 K ^TMP($J)
I '$D(PSGP(0)) S DFN=PSGP D DEM^VADPT S PSGP(0)=VADM(1) K VADM
S PSGSS="P",PPN=PSGP(0),PSGPAT(PPN)=PSGP,PSJMDWS=1
Q:$$PRN^PSJMDIR S PSJMPRN=Y
Q:$$STDATE^PSJMDIR S (X1,PSGTMP)=Y,X2=1 D C^%DTC S PSGTMP1=X,PSGPLS=Y
Q:$$ENDATE^PSJMDIR(PSGTMP,PSGTMP1) S PSGPLF=Y
Q:$$MEDTYPE^PSJMDIR($G(PSGWD)) S PSGMTYPE=Y
Q:$$SELDEV^PSJMUTL
G EN
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSJMDWS 2628 printed Dec 13, 2024@02:07:39 Page 2
PSJMDWS ;BIR/MV-MAIN DRIVER FOR MED DUE WORKSHEET ;18 JUN 96 / 2:58 PM
+1 ;;5.0; INPATIENT MEDICATIONS ;**31,34,111**;16 DEC 97
+2 ;
+3 ;
+4 SET PSJSTOP=0
KILL ^TMP($JOB)
+5 DO ASK
if PSJSTOP
GOTO EXIT
EN IF $DATA(IO("Q"))
Begin DoDot:1
+1 NEW XDESC,XSAVE,XTRTN
+2 SET XDESC="Med Due Worksheet (SORT)"
+3 SET XSAVE="PSGIO;PSGMTYPE;PSGP;PSGP(;PSGPAT(;PSGPLF;PSGPLS;PSGRBADM;PSGSS;PSGTM;PSGTM(;PSGTMALL;PSGWD;PSGWG;PSGWGNM;PSGWN;PSJMPRN;PSGIODOC"
+4 SET XTRTN="SORTQ^PSJMDWS"
DO SETSORTQ^PSJMUTL(XDESC,XSAVE,XTRTN)
End DoDot:1
GOTO EXIT
+5 DO SORTQ
+6 QUIT
SORTQ ;*** Entry when queue to do the sorting.
+1 NEW ADMIN,CD,DRG,DRGI,DRGN,DRGT,ON,MID,MN,ND,ND1,OD,PLSD,PSIVUP,PSJORIFN,PST,QST,RBNO,ST,T,TM,TMNO,TS,UD0,UD2,XTYPE
+2 if PSGSS="G"
DO ^PSJMEDS
+3 if PSGSS="W"
DO WARD^PSJMEDS
+4 IF PSGSS="C"
SET PSGWG="^OTHER"
DO ^PSJMEDS
+5 IF PSGSS="P"
SET PPN=""
FOR
SET PPN=$ORDER(PSGPAT(PPN))
if PPN=""
QUIT
SET PSGP=PSGPAT(PPN)
SET PSJACNWP=""
DO ^PSJAC
DO MEDTYPE^PSJMEDS
+6 IF $DATA(PSGIO)
Begin DoDot:1
+7 NEW XDESC,XSAVE,XTRTN
+8 SET XDESC="Med Due Worksheet (PRINT)"
+9 SET XSAVE="PSGMTYPE;PSGP;PSGP(;PSGPAT(;PSGPLF;PSGPLS;PSGRBADM;PSGSS;PSGTM;PSGTM(;PSGTMALL;PSGWD;PSGWG;PSGWGNM;PSGWN;PSJMPRN;^TMP($J,;PSGIODOC"
+10 SET XTRTN="PRTQ^PSJMDWS"
DO SETPRTQ^PSJMUTL(XDESC,XSAVE,XTRTN)
End DoDot:1
GOTO EXIT
PRTQ ;*** Entry when queue to the printer.
+1 DO ^PSJMPRT
+2 ;
+3 ;
EXIT ;
+1 KILL ^TMP($JOB)
+2 DO EXITDEV^PSJMUTL
DO EXIT^PSJMUTL
+3 ;*** Kill var called from ^PSJAC
DO ENKV^PSGSETU
+4 KILL PFLG,PPN,PSGEXPDT,PSGIO,PSGLFD,PSGLOD,PSGLSD,PSGMAR,PSGMARWD,PSGMFOR,PSGMTYPE,PSGOES,PSGON,PSGP,PSGPAT,PSGPG,PSGPLC,PSGPLF,PSGPLO
+5 KILL PSGPLS,PSGRBADM,PSGRBPPN,PSGRETF,PSGS0XT,PSGS0Y,PSGSS,PSGTM,PSGTMALL,PSGTMP,PSGTMP1,PSGWD,PSGWG,PSGWGNM
+6 KILL PSGWN,PSGWN1,PSJACNWP,PSJADT,PSJADT1,PSJADTO,PSJADTME,PSJATME1,PSJATMEO
+7 KILL PSJASTR,PSJATME,PSJATMEO,PSJDOS,PSJHL1,PSJHL2,PSJHL3,PSJHL62,PSJHOLD,PSJLN,PSJMPRN,PSJMR,PSJNEED,PSJONCAL,PSJONETM
+8 KILL PSJPLC,PSJPRB,PSJPRT,PSJPWDN,PSJPWDO,PSJSCHE,PSJSI,PSJSTOP,PSJTOTLN,ZSTOP,ZTQUEUED
+9 QUIT
+10 ;
+11 ;
ASK ;***Prompt for selection creteria. Quit when PSJSTOP=1
+1 ;
+2 if $$PRN^PSJMDIR
QUIT
SET PSJMPRN=Y
+3 if $$STDATE^PSJMDIR
QUIT
SET (X1,PSGTMP)=Y
SET X2=1
DO C^%DTC
SET PSGTMP1=X
SET PSGPLS=Y
+4 if $$ENDATE^PSJMDIR(PSGTMP,PSGTMP1)
QUIT
SET PSGPLF=Y
+5 if $$GWP^PSJMDIR1(1)
QUIT
+6 if $$MEDTYPE^PSJMDIR($GET(PSGWD))
QUIT
SET PSGMTYPE=Y
+7 if $$SELDEV^PSJMUTL
QUIT
+8 QUIT
+9 ;
ENLM ;Enrty Point for PSJ LM MDWS protocol
+1 ;
+2 NEW VADM
SET PSJSTOP=0
KILL ^TMP($JOB)
+3 IF '$DATA(PSGP(0))
SET DFN=PSGP
DO DEM^VADPT
SET PSGP(0)=VADM(1)
KILL VADM
+4 SET PSGSS="P"
SET PPN=PSGP(0)
SET PSGPAT(PPN)=PSGP
SET PSJMDWS=1
+5 if $$PRN^PSJMDIR
QUIT
SET PSJMPRN=Y
+6 if $$STDATE^PSJMDIR
QUIT
SET (X1,PSGTMP)=Y
SET X2=1
DO C^%DTC
SET PSGTMP1=X
SET PSGPLS=Y
+7 if $$ENDATE^PSJMDIR(PSGTMP,PSGTMP1)
QUIT
SET PSGPLF=Y
+8 if $$MEDTYPE^PSJMDIR($GET(PSGWD))
QUIT
SET PSGMTYPE=Y
+9 if $$SELDEV^PSJMUTL
QUIT
+10 GOTO EN
+11 ;
