- 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
- ;
- 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 ;
