PSGCAP.m

PSGCAP ;BIR/CML3-ACTION PROFILE (#2) ;04 APR 96 / 1:10 PM

 ;;5.0; INPATIENT MEDICATIONS ;**111**;16 DEC 97

 N PSJNEW,PSGPTMP,PPAGE S PSJNEW=1

 ;

 D ENCV^PSGSETU I $D(XQUIT) Q

 ;

START ;

 S (PSGAP,PSGP,PSGAPWD,PSGAPWG)=0,(PSGAPWDN,PSGAPWGN)="",PSGSSH="AP" S PSGPTMP=0,PPAGE=1

 D ^PSGSEL G:PSGSS="^"!(PSGSS="") DONE D @PSGSS I (Y'="^OTHER"),(Y'>0) W !!?3,"No patient(s) selected.  Option terminated." G START

 ;

ORS I '$G(PSGAPWG) S PSGAPS="P" G ORS1

 S PSGAPS="T" I $S(PSGSS'="P":1,1:PSGPAT>1) F  W !!,"Sort Action Profiles by (T)eam or Treating (P)rovider? T// " R PSGAPS:DTIME D Q1 Q:PSGAPS]""

ORS1 G:PSGAPS="^" START D NOW^%DTC S PSGDT=% F N="START","STOP" D GDT G:$D(DIRUT) START

 F  W !!,"Print (A)ll active orders, or (E)xpiring orders only? A// " R PSGAPO:DTIME D Q2 Q:PSGAPO]""

 G:PSGAPO="^" START

 G:$$MEDTYPE^PSJMDIR($G(PSGWD)) START S PSGMTYPE=Y

 K ZTSAVE F X="PSGAPS","PSGAPO","PSGAPSD","PSGAPFD","PSGMTYPE","PSGP","PSGSS","PSGAPWD","PSGAPWG","PSGAPWDN","PSGAPWGN","PSGPAT(","PSGPTMP","PPAGE" S ZTSAVE(X)=""

 S PSGTIR="ENQ^PSGCAP0",ZTDESC="ACTION PROFILE" D ENDEV^PSGTI G:POP START G:$D(IO("Q")) DONE

 W !,"...this may take a few minutes...(you really should QUEUE this report)..." D ENQ^PSGCAP0

 ;

 ;

DONE ;

 D ENKV^PSGSETU K CA,CNTR,DIAG,DO,DRG,FD,LQ,N,NF,ND,ND2,PSJJORD,PAGE,PDOB,PN,PND,PSEX,PSGAP,PSGAPWD,PSGAPWDN,PSGAPWG,PSGAPWGN,PSGDICA,PSGPAT,PSGSS

 K PSGSSH,RB,RTE,SD,SI,SM,ST,STRT,STP,STT,WS,WT,S1,ZTOUT,PSGAPFD,PSGAPSD,PSGAPS,PSGAPO,PSJACNWP,PSJDLW,PSJOPC,PSJPWDO,PSGWD

 K PSGADR,PSGALG,PSGEXPDT,PSGMTYPE,PSJSI,PSJSTOP,PSJTEAM,PST,QST

 K ^TMP($J)

 Q

 ;

GDT ;

 K DIR NEW MINDT S:N="START" MINDT=PSGDT-.0001,DIR("B")="NOW" S:N="STOP" MINDT=PSGAPSD,DIR("B")=$$ENDD^PSGMI(PSGAPSD)

 S DIR(0)="DA^"_MINDT_":9999999.9999:EFTX",DIR("?")="^D DTM^PSGCAP",DIR("A")="Enter "_$S(N["R":"START",1:"STOP")_" date/time: " D ^DIR K DIR Q:$D(DIRUT)

 I X'="^" S:N["R" PSGAPSD=$S(Y'>0:PSGDT,Y#1:+$E(Y,1,12),1:Y+.0001) S:N["O" PSGAPFD=$S(Y'>0:9999999,Y#1:+$E(Y,1,12),1:Y+.24)

  Q

 ;

G ; get ward group

 S DIC="^PS(57.5,",DIC(0)="QEAMZ",DIC("A")="Select WARD GROUP: " W ! D ^DIC K DIC S:Y>0 PSGAPWG=+Y,PSGAPWGN=Y(0,0) I Y<0,X="^OTHER" D

 . S (Y,PSGAPWG,PSGAPWGN)="^OTHER",(PSGAPWD,PSGAPWDN)="zz"

 Q

 ;

C ;

 K DIR S DIR(0)="FAO",DIR("A")="Select CLINIC: "

 S DIR("?")="^D CDIC^PSGVBW" W ! D ^DIR

CDIC ;

 K DIC S DIC="^SC(",DIC(0)="QEMIZ" D ^DIC K DIC S:+Y>0 CL=+Y

 W:X["?" !!,"Enter the clinic you want to use to select patients for processing.",!

 Q

L ;

 K DIR S DIR(0)="FAO",DIR("A")="Select CLINIC GROUP: "

 S DIR("?")="^D LDIC^PSGVBW" W ! D ^DIR

LDIC ;

 K DIC S DIC="^PS(57.8,",DIC(0)="QEMI" D ^DIC K DIC S:+Y>0 CG=+Y

 W:X["?" !!,"Enter the name of the clinic group you want to use to select patients for processing."

 Q

W ; get ward

 S DIC="^DIC(42,",DIC(0)="QEAMZ",DIC("A")="Select WARD: " W ! D ^DIC K DIC S:Y>0 (PSGWD,PSGAPWD)=+Y,PSGAPWDN=Y(0,0) Q

 ;

P ; get patient

 K PSGPAT,PSJPWDO,PSGWD

 S PSGPAT=0 F CNTR=1:1 S:CNTR>1 PSGDICA="another" D ENP^PSGGAO Q:PSGP'>0  S PSGPAT(PSGP)="",PSGPAT=PSGPAT+1 S:'$G(PSJPWDO) (PSGWD,PSJPWDO)=PSJPWD S PSGWD=$S('$G(PSGWD):0,PSJPWDO=PSJPWD:PSJPWD,1:0)

 S Y=$S(PSGPAT:1,1:-1) K PSGDICA Q

 ;

DTM ;

 S Y=PSGDT D D^DIQ S T=$P(Y,"@",2),Y=$P(Y,",")

 W !!?2,"Enter a ",N," date.  If a time is not entered for the ",N," date, the",!,$S(N["R":"beginning",1:"end")," of the day is assumed and used."

 W !?2,"If you wish to enter a ",$S(N["R":"start",1:"stop")," date of ",Y,", you must enter a TIME of day",!,"of ",T," or greater.  Any date after ",Y," does not need time entered.",! S Y=-1 Q

 ;

Q1 ;

 W:'$T $C(7) S:'$T PSGAPS="^" Q:PSGAPS="^"

 I PSGAPS="" S PSGAPS="T" W "  (TEAM)" Q

 I PSGAPS?.E1C.E S PSGAPS="" W $C(7),"  ??" Q

 I PSGAPS?1."?" W !!?2,"Enter 'T' (or press RETURN) to sort and print patients by TEAM.  Enter 'P'",!,"to sort and print patients by treating PROVIDER." S PSGAPS="" Q

 F Q=1:1:$L(PSGAPS) I $E(PSGAPS,Q)?1L S PSGAPS=$E(PSGAPS,1,Q-1)_$C($A($E(PSGAPS,Q))-32)_$E(PSGAPS,Q+1,$L(PSGAPS))

 F X="TEAM","PROVIDER" I $P(X,PSGAPS)="" W $P(X,PSGAPS,2) S PSGAPS=$E(X) Q

 E  W $C(7),"  ??" S PSGAPS=""

 Q

 ;

Q2 ;

 W:'$T $C(7) S:'$T PSGAPO="^" Q:PSGAPO="^"

 I PSGAPO="" S PSGAPO="A" W "  (ALL)" Q

 I PSGAPO?.E1C.E S PSGAPO="" W $C(7),"  ??" Q

 I PSGAPO?1."?" W !!?2,"Enter 'A' (or press RETURN) to print ALL ACTIVE orders for the patient(s)",!,"selected.  Enter 'E' to print only orders that will EXPIRE within the date",!,"range selected for the patient(s) selected." S PSGAPO="" Q

 F Q=1:1:$L(PSGAPO) I $E(PSGAPO,Q)?1L S PSGAPO=$E(PSGAPO,1,Q-1)_$C($A($E(PSGAPO,Q))-32)_$E(PSGAPO,Q+1,$L(PSGAPO))

 F X="ALL","EXPIRING" I $P(X,PSGAPO)="" W $P(X,PSGAPO,2) S PSGAPO=$E(X) Q

 E  W $C(7),"  ??" S PSGPAS=""

 Q

ENLM ;Entry point for PSJ LM AP2 protocol

 N PSJNEW,PSGPTMP,PPAGE S PSJNEW=1

 S PSGPTMP=0,PPAGE=1

 D ENCV^PSGSETU I $D(XQUIT) Q

 S PSGPAT=PSGP,PSGPAT(DFN)="",(PSGAPWD,PSGAPWG)=0,(PSGAPWDN,PSGAPWGN)="",PSGSS="P",PSGAPS="T" D ORS1

 S PSJNKF=1 G DONE

PSGCAP    ;BIR/CML3-ACTION PROFILE (#2) ;04 APR 96 / 1:10 PM

 +1       ;;5.0; INPATIENT MEDICATIONS ;**111**;16 DEC 97

 +2        NEW PSJNEW,PSGPTMP,PPAGE

           SET PSJNEW=1

 +3       ;

 +4        DO ENCV^PSGSETU

           IF $DATA(XQUIT)

               QUIT 

 +5       ;

START     ;

 +1        SET (PSGAP,PSGP,PSGAPWD,PSGAPWG)=0

           SET (PSGAPWDN,PSGAPWGN)=""

           SET PSGSSH="AP"

           SET PSGPTMP=0

           SET PPAGE=1

 +2        DO ^PSGSEL

           IF PSGSS="^"!(PSGSS="")

               GOTO DONE

           DO @PSGSS

           IF (Y'="^OTHER")

               IF (Y'>0)

                   WRITE !!?3,"No patient(s) selected.  Option terminated."

                   GOTO START

 +3       ;

ORS        IF '$GET(PSGAPWG)

               SET PSGAPS="P"

               GOTO ORS1

 +1        SET PSGAPS="T"

           IF $SELECT(PSGSS'="P":1,1:PSGPAT>1)

               FOR 

                   WRITE !!,"Sort Action Profiles by (T)eam or Treating (P)rovider? T// "

                   READ PSGAPS:DTIME

                   DO Q1

                   IF PSGAPS]""

                       QUIT 

ORS1       IF PSGAPS="^"

               GOTO START

           DO NOW^%DTC

           SET PSGDT=%

           FOR N="START","STOP"

               DO GDT

               IF $DATA(DIRUT)

                   GOTO START

 +1        FOR 

               WRITE !!,"Print (A)ll active orders, or (E)xpiring orders only? A// "

               READ PSGAPO:DTIME

               DO Q2

               IF PSGAPO]""

                   QUIT 

 +2        IF PSGAPO="^"

               GOTO START

 +3        IF $$MEDTYPE^PSJMDIR($GET(PSGWD))

               GOTO START

           SET PSGMTYPE=Y

 +4        KILL ZTSAVE

           FOR X="PSGAPS","PSGAPO","PSGAPSD","PSGAPFD","PSGMTYPE","PSGP","PSGSS","PSGAPWD","PSGAPWG","PSGAPWDN","PSGAPWGN","PSGPAT(","PSGPTMP","PPAGE"

               SET ZTSAVE(X)=""

 +5        SET PSGTIR="ENQ^PSGCAP0"

           SET ZTDESC="ACTION PROFILE"

           DO ENDEV^PSGTI

           IF POP

               GOTO START

           IF $DATA(IO("Q"))

               GOTO DONE

 +6        WRITE !,"...this may take a few minutes...(you really should QUEUE this report)..."

           DO ENQ^PSGCAP0

 +7       ;

 +8       ;

DONE      ;

 +1        DO ENKV^PSGSETU

           KILL CA,CNTR,DIAG,DO,DRG,FD,LQ,N,NF,ND,ND2,PSJJORD,PAGE,PDOB,PN,PND,PSEX,PSGAP,PSGAPWD,PSGAPWDN,PSGAPWG,PSGAPWGN,PSGDICA,PSGPAT,PSGSS

 +2        KILL PSGSSH,RB,RTE,SD,SI,SM,ST,STRT,STP,STT,WS,WT,S1,ZTOUT,PSGAPFD,PSGAPSD,PSGAPS,PSGAPO,PSJACNWP,PSJDLW,PSJOPC,PSJPWDO,PSGWD

 +3        KILL PSGADR,PSGALG,PSGEXPDT,PSGMTYPE,PSJSI,PSJSTOP,PSJTEAM,PST,QST

 +4        KILL ^TMP($JOB)

 +5        QUIT 

 +6       ;

GDT       ;

 +1        KILL DIR

           NEW MINDT

           IF N="START"

               SET MINDT=PSGDT-.0001

               SET DIR("B")="NOW"

           IF N="STOP"

               SET MINDT=PSGAPSD

               SET DIR("B")=$$ENDD^PSGMI(PSGAPSD)

 +2        SET DIR(0)="DA^"_MINDT_":9999999.9999:EFTX"

           SET DIR("?")="^D DTM^PSGCAP"

           SET DIR("A")="Enter "_$SELECT(N["R":"START",1:"STOP")_" date/time: "

           DO ^DIR

           KILL DIR

           IF $DATA(DIRUT)

               QUIT 

 +3        IF X'="^"

               IF N["R"

                   SET PSGAPSD=$SELECT(Y'>0:PSGDT,Y#1:+$EXTRACT(Y,1,12),1:Y+.0001)

               IF N["O"

                   SET PSGAPFD=$SELECT(Y'>0:9999999,Y#1:+$EXTRACT(Y,1,12),1:Y+.24)

 +4        QUIT 

 +5       ;

G         ; get ward group

 +1        SET DIC="^PS(57.5,"

           SET DIC(0)="QEAMZ"

           SET DIC("A")="Select WARD GROUP: "

           WRITE !

           DO ^DIC

           KILL DIC

           IF Y>0

               SET PSGAPWG=+Y

               SET PSGAPWGN=Y(0,0)

           IF Y<0

               IF X="^OTHER"

                   Begin DoDot:1

 +2                    SET (Y,PSGAPWG,PSGAPWGN)="^OTHER"

                       SET (PSGAPWD,PSGAPWDN)="zz"

                   End DoDot:1

 +3        QUIT 

 +4       ;

C         ;

 +1        KILL DIR

           SET DIR(0)="FAO"

           SET DIR("A")="Select CLINIC: "

 +2        SET DIR("?")="^D CDIC^PSGVBW"

           WRITE !

           DO ^DIR

CDIC      ;

 +1        KILL DIC

           SET DIC="^SC("

           SET DIC(0)="QEMIZ"

           DO ^DIC

           KILL DIC

           IF +Y>0

               SET CL=+Y

 +2        IF X["?"

               WRITE !!,"Enter the clinic you want to use to select patients for processing.",!

 +3        QUIT 

L         ;

 +1        KILL DIR

           SET DIR(0)="FAO"

           SET DIR("A")="Select CLINIC GROUP: "

 +2        SET DIR("?")="^D LDIC^PSGVBW"

           WRITE !

           DO ^DIR

LDIC      ;

 +1        KILL DIC

           SET DIC="^PS(57.8,"

           SET DIC(0)="QEMI"

           DO ^DIC

           KILL DIC

           IF +Y>0

               SET CG=+Y

 +2        IF X["?"

               WRITE !!,"Enter the name of the clinic group you want to use to select patients for processing."

 +3        QUIT 

W         ; get ward

 +1        SET DIC="^DIC(42,"

           SET DIC(0)="QEAMZ"

           SET DIC("A")="Select WARD: "

           WRITE !

           DO ^DIC

           KILL DIC

           IF Y>0

               SET (PSGWD,PSGAPWD)=+Y

               SET PSGAPWDN=Y(0,0)

           QUIT 

 +2       ;

P         ; get patient

 +1        KILL PSGPAT,PSJPWDO,PSGWD

 +2        SET PSGPAT=0

           FOR CNTR=1:1

               IF CNTR>1

                   SET PSGDICA="another"

               DO ENP^PSGGAO

               IF PSGP'>0

                   QUIT 

               SET PSGPAT(PSGP)=""

               SET PSGPAT=PSGPAT+1

               IF '$GET(PSJPWDO)

                   SET (PSGWD,PSJPWDO)=PSJPWD

               SET PSGWD=$SELECT('$GET(PSGWD):0,PSJPWDO=PSJPWD:PSJPWD,1:0)

 +3        SET Y=$SELECT(PSGPAT:1,1:-1)

           KILL PSGDICA

           QUIT 

 +4       ;

DTM       ;

 +1        SET Y=PSGDT

           DO D^DIQ

           SET T=$PIECE(Y,"@",2)

           SET Y=$PIECE(Y,",")

 +2        WRITE !!?2,"Enter a ",N," date.  If a time is not entered for the ",N," date, the",!,$SELECT(N["R":"beginning",1:"end")," of the day is assumed and used."

 +3        WRITE !?2,"If you wish to enter a ",$SELECT(N["R":"start",1:"stop")," date of ",Y,", you must enter a TIME of day",!,"of ",T," or greater.  Any date after ",Y," does not need time entered.",!

           SET Y=-1

           QUIT 

 +4       ;

Q1        ;

 +1        IF '$TEST

               WRITE $CHAR(7)

           IF '$TEST

               SET PSGAPS="^"

           IF PSGAPS="^"

               QUIT 

 +2        IF PSGAPS=""

               SET PSGAPS="T"

               WRITE "  (TEAM)"

               QUIT 

 +3        IF PSGAPS?.E1C.E

               SET PSGAPS=""

               WRITE $CHAR(7),"  ??"

               QUIT 

 +4        IF PSGAPS?1."?"

               WRITE !!?2,"Enter 'T' (or press RETURN) to sort and print patients by TEAM.  Enter 'P'",!,"to sort and print patients by treating PROVIDER."

               SET PSGAPS=""

               QUIT 

 +5        FOR Q=1:1:$LENGTH(PSGAPS)

               IF $EXTRACT(PSGAPS,Q)?1L

                   SET PSGAPS=$EXTRACT(PSGAPS,1,Q-1)_$CHAR($ASCII($EXTRACT(PSGAPS,Q))-32)_$EXTRACT(PSGAPS,Q+1,$LENGTH(PSGAPS))

 +6        FOR X="TEAM","PROVIDER"

               IF $PIECE(X,PSGAPS)=""

                   WRITE $PIECE(X,PSGAPS,2)

                   SET PSGAPS=$EXTRACT(X)

                   QUIT 

 +7       IF '$TEST

               WRITE $CHAR(7),"  ??"

               SET PSGAPS=""

 +8        QUIT 

 +9       ;

Q2        ;

 +1        IF '$TEST

               WRITE $CHAR(7)

           IF '$TEST

               SET PSGAPO="^"

           IF PSGAPO="^"

               QUIT 

 +2        IF PSGAPO=""

               SET PSGAPO="A"

               WRITE "  (ALL)"

               QUIT 

 +3        IF PSGAPO?.E1C.E

               SET PSGAPO=""

               WRITE $CHAR(7),"  ??"

               QUIT 

 +4        IF PSGAPO?1."?"

               WRITE !!?2,"Enter 'A' (or press RETURN) to print ALL ACTIVE orders for the patient(s)",!,"selected.  Enter 'E' to print only orders that will EXPIRE within the date",!,"range selected for the patient(s) selected."

               SET PSGAPO=""

               QUIT 

 +5        FOR Q=1:1:$LENGTH(PSGAPO)

               IF $EXTRACT(PSGAPO,Q)?1L

                   SET PSGAPO=$EXTRACT(PSGAPO,1,Q-1)_$CHAR($ASCII($EXTRACT(PSGAPO,Q))-32)_$EXTRACT(PSGAPO,Q+1,$LENGTH(PSGAPO))

 +6        FOR X="ALL","EXPIRING"

               IF $PIECE(X,PSGAPO)=""

                   WRITE $PIECE(X,PSGAPO,2)

                   SET PSGAPO=$EXTRACT(X)

                   QUIT 

 +7       IF '$TEST

               WRITE $CHAR(7),"  ??"

               SET PSGPAS=""

 +8        QUIT 

ENLM      ;Entry point for PSJ LM AP2 protocol

 +1        NEW PSJNEW,PSGPTMP,PPAGE

           SET PSJNEW=1

 +2        SET PSGPTMP=0

           SET PPAGE=1

 +3        DO ENCV^PSGSETU

           IF $DATA(XQUIT)

               QUIT 

 +4        SET PSGPAT=PSGP

           SET PSGPAT(DFN)=""

           SET (PSGAPWD,PSGAPWG)=0

           SET (PSGAPWDN,PSGAPWGN)=""

           SET PSGSS="P"

           SET PSGAPS="T"

           DO ORS1

 +5        SET PSJNKF=1

           GOTO DONE