Routine: PSJPDIR

PSJPDIR ;BIR/MLM-PATIENT PROFILE CALLS ;10 MAY 96 / 9:56 AM

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

 ; Reference to ^DIC is supported by DBIA 10006

 ; Reference to ^DIR is supported by DBIA 10026

 ; Reference to ^VADPT is supported by DBIA 10061

GWP ; Ask for seletion by WARD GROUP,WARD or PATIENT.

 K PSJSEL,DIR S PSJSTOP="",DIR(0)="SAO^G:Ward Group;W:Ward;P:Patient",DIR("A")="Select by WARD GROUP (G), WARD (W), or PATIENT (P): "

 S DIR("?")="To select by PATIENT, enter a 'P'."

 S DIR("?",1)="To select the entire WARD GROUP, enter a 'G'."

 S DIR("?",2)="To select a single WARD, enter a 'W'."

 W !! D ^DIR K DIR S PSJSTOP=$S(Y="":1,Y<0:1,$$STOP:1,1:0)

 I 'PSJSTOP S PSJSEL("SELECT")=Y D @Y Q:($G(PSJSEL("WG"))="^OTHER")  G:PSJSTOP GWP D:PSJSEL("SELECT")'="P" RBPPN G:PSJSTOP GWP

P ;*** Select by Patient

 N PSJACNWP,PSGDICA,PSGPAT S PSJACNWP=""

 F PFLG=0:1 S:PFLG PSGDICA="another" D ^PSJP Q:PSGP<0  S PSJSEL("P",PSGP(0),PSGP)="" S:'$G(PSJPWDO) (PSGWD,PSJPWDO)=PSJPWD S PSGWD=$S('$G(PSGWD):0,PSJPWDO=PSJPWD:PSJPWD,1:0)

 S PSJSTOP=$S($D(DTOUT):1,$D(DUOUT):1,(Y<0)&'$D(PSGDICA):1,1:0)

W ;*** Select by WARD

 K DIC S DIC="^DIC(42,",DIC(0)="QEAMIZ",DIC("A")="Select a Ward: " W !! D ^DIC

 S PSJSTOP=$S(Y="":1,Y<0:1,$$STOP:1,1:0)

 I 'PSJSTOP S PSJSEL("W")=Y D ADMTM

G ;***Select by WARD GROUP

 K DIC S DIC="^PS(57.5,",DIC(0)="QEAMI",DIC("A")="Select a Ward Group: " W !! D ^DIC

 S PSJSTOP=$S(X="^OTHER":2,Y="":1,Y<0:1,$$STOP:1,1:0)

 ;I PSJSTOP=2 S PSJSTOP=0,PSJSEL("WG")="^OTHER" Q

 I PSJSTOP=2 S PSJSEL("WG")="^OTHER" Q

 I 'PSJSTOP S PSJSEL("WG")=Y

ADMTM ;*** Askif user want to sort by admin team

 N DIR S DIR(0)="YO",DIR("A")="Do you want to sort by Administration Team (Y/N)",DIR("B")="NO",DIR("?")="Enter ""YES"" to sort this report by Administration Team." W !! D ^DIR Q:$$STOP!'+Y

 ;*** Because "ALL" is not a team, must use DIR to include "ALL"

 ;    default and then call DIC to look up the selected team

 F  Q:$$STOP!(X="")!$D(PSJSEL("TM","ALL"))  D ADMTM2

ADMTM2 ;

 K DIR S DIR(0)="FAO",DIR("A")="Select Administration Team: ",DIR("B")="ALL",DIR("?")="^D TM2HLP^PSJPDIR,DICTM^PSJPDIR"

 W !! D ^DIR Q:$$STOP  I Y="ALL" S PSJSEL("TM","ALL")="" Q

 D DICTM

 S PSJSTOP=$S($D(DTOUT):1,$D(DUOUT):1,(Y<0)&'$D(PFLG):1,1:0)

TM2HLP W !!,"Enter the name of an Administration Team that you want",!,"to include on the report."," Enter ""ALL"" (or accept the",!,"default) to include all teams on the report.",!

DICTM ;*** LooK up a team.

 K DIC S DIC="^PS(57.7,"_+PSJSEL("W")_",1,",DIC(0)="QEMIZ"

 F PFLG=0:1 D ^DIC Q:Y<0  I PFLG S DIC(0)=DIC(0)_"A",DIC("A")="Select another Administration Team: " S PSJSEL("TM",+Y)=Y(0,0)

RBPPN ;*** Sort by ROOM-BED or PATIENT

 K DIR S DIR(0)="SAO^R:Room-Bed;P:Patient",DIR("A")="Do you wish to sort by Room-Bed (R), Patient (P): ",DIR("B")="Patient"

 W !! D ^DIR Q:$$STOP  S PSJSEL("RBP")=Y

ENL ;

 F  W !!,"SHORT, LONG, or NO Profile?  ",$S('$D(PSJPWD):"SHORT",PSJPWD:"SHORT",1:"LONG"),"// " R PSJOL:DTIME W:'$T $C(7) S:'$T PSJOL="^" Q:PSJOL="^"  D LCHK Q:"^SLN"[PSJOL&($L(PSJOL)=1)

LCHK ;

 I PSJOL?1."?" D LM Q

 I PSJOL="" S PSJOL=$S('$D(PSJPWD):"S",PSJPWD:"S",1:"L") W $P("  SHORT^  LONG","^",PSJOL="L"+1) Q

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

 I PSJOL?.ANP F X="NO PROFILE","LONG","SHORT" I $P(X,PSJOL)="" W $P(X,PSJOL,2) S PSJOL=$E(PSJOL) Q

 W:'$T $C(7),"  ??" Q

LM ;Profile Type

 W !!?2,"Enter 'SHORT' (or 'S', or press the RETURN key) to exclude this patient's",!,"discontinued and expired orders in the following profile.  Enter 'LONG' (or 'L') to include those orders."

 W "  Enter 'NO' (or 'N') to bypass the profile com-",!,"pletely.  Enter '^' if you wish to go no further with this patient." Q

ENDPT ;*** get patient ***

 K DIC,PSGP,Y W !!,"Select "_$S($D(PSGDICA):PSGDICA_" ",1:"")_"PATIENT: " R X:DTIME I "^"[X S (Y,PSGP)=-1 G DONE

 D EN^PSJDPT

 I Y'>0 G ENDPT

 K DIC

CHK ;*** Check patient status ***

 S PPN=$P(Y,U,2),(DFN,PSGP)=+Y,VA200=1 D INP^VADPT Q:VAIN(4)

 S PSJPCAF="",VAIP("D")="L" D IN5^VADPT I 'VAIP(13,1) W $C(7),!!?3,"PATIENT HAS NEVER BEEN ADMITTED." G ENDPT

 S X=+VAIP(4)=12!(+VAIP(4)=38) W $C(7),!!?3,"PATIENT IS FOUND TO BE D",$P("ISCHARG^ECEAS",U,X+1),"ED AS OF ",$$ENDTC^PSGMI(+VAIP(3)),"." G ENDPT

STOP() ;

 S PSJSTOP=$S($D(DTOUT):1,$D(DUOUT):1,$D(DIRUT):1,1:0)

 Q PSJSTOP

DONE ;

 K DA,DIC,DIK

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSJPDIR   4554     printed  Apr 23, 2025@18:23:15                                                                                                                                                                                                     Page 2

PSJPDIR   ;BIR/MLM-PATIENT PROFILE CALLS ;10 MAY 96 / 9:56 AM

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

 +2       ;

 +3       ; Reference to ^DIC is supported by DBIA 10006

 +4       ; Reference to ^DIR is supported by DBIA 10026

 +5       ; Reference to ^VADPT is supported by DBIA 10061

 +6       ;

GWP       ; Ask for seletion by WARD GROUP,WARD or PATIENT.

 +1        KILL PSJSEL,DIR

           SET PSJSTOP=""

           SET DIR(0)="SAO^G:Ward Group;W:Ward;P:Patient"

           SET DIR("A")="Select by WARD GROUP (G), WARD (W), or PATIENT (P): "

 +2        SET DIR("?")="To select by PATIENT, enter a 'P'."

 +3        SET DIR("?",1)="To select the entire WARD GROUP, enter a 'G'."

 +4        SET DIR("?",2)="To select a single WARD, enter a 'W'."

 +5        WRITE !!

           DO ^DIR

           KILL DIR

           SET PSJSTOP=$SELECT(Y="":1,Y<0:1,$$STOP:1,1:0)

 +6        IF 'PSJSTOP

               SET PSJSEL("SELECT")=Y

               DO @Y

               if ($GET(PSJSEL("WG"))="^OTHER")

                   QUIT

               if PSJSTOP

                   GOTO GWP

               if PSJSEL("SELECT")'="P"

                   DO RBPPN

               if PSJSTOP

                   GOTO GWP

 +7        QUIT

 +8       ;

P         ;*** Select by Patient

 +1        NEW PSJACNWP,PSGDICA,PSGPAT

           SET PSJACNWP=""

 +2        FOR PFLG=0:1

               if PFLG

                   SET PSGDICA="another"

               DO ^PSJP

               if PSGP<0

                   QUIT

               SET PSJSEL("P",PSGP(0),PSGP)=""

               if '$GET(PSJPWDO)

                   SET (PSGWD,PSJPWDO)=PSJPWD

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

 +3        SET PSJSTOP=$SELECT($DATA(DTOUT):1,$DATA(DUOUT):1,(Y<0)&'$DATA(PSGDICA):1,1:0)

 +4        QUIT

 +5       ;

W         ;*** Select by WARD

 +1        KILL DIC

           SET DIC="^DIC(42,"

           SET DIC(0)="QEAMIZ"

           SET DIC("A")="Select a Ward: "

           WRITE !!

           DO ^DIC

 +2        SET PSJSTOP=$SELECT(Y="":1,Y<0:1,$$STOP:1,1:0)

 +3        IF 'PSJSTOP

               SET PSJSEL("W")=Y

               DO ADMTM

 +4        QUIT

 +5       ;

G         ;***Select by WARD GROUP

 +1        KILL DIC

           SET DIC="^PS(57.5,"

           SET DIC(0)="QEAMI"

           SET DIC("A")="Select a Ward Group: "

           WRITE !!

           DO ^DIC

 +2        SET PSJSTOP=$SELECT(X="^OTHER":2,Y="":1,Y<0:1,$$STOP:1,1:0)

 +3       ;I PSJSTOP=2 S PSJSTOP=0,PSJSEL("WG")="^OTHER" Q

 +4        IF PSJSTOP=2

               SET PSJSEL("WG")="^OTHER"

               QUIT

 +5        IF 'PSJSTOP

               SET PSJSEL("WG")=Y

 +6        QUIT

 +7       ;

ADMTM     ;*** Askif user want to sort by admin team

 +1        NEW DIR

           SET DIR(0)="YO"

           SET DIR("A")="Do you want to sort by Administration Team (Y/N)"

           SET DIR("B")="NO"

           SET DIR("?")="Enter ""YES"" to sort this report by Administration Team."

           WRITE !!

           DO ^DIR

           if $$STOP!'+Y

               QUIT

 +2       ;

 +3       ;*** Because "ALL" is not a team, must use DIR to include "ALL"

 +4       ;    default and then call DIC to look up the selected team

 +5       ;

 +6        FOR

               if $$STOP!(X="")!$DATA(PSJSEL("TM","ALL"))

                   QUIT

               DO ADMTM2

 +7        QUIT

ADMTM2    ;

 +1        KILL DIR

           SET DIR(0)="FAO"

           SET DIR("A")="Select Administration Team: "

           SET DIR("B")="ALL"

           SET DIR("?")="^D TM2HLP^PSJPDIR,DICTM^PSJPDIR"

 +2        WRITE !!

           DO ^DIR

           if $$STOP

               QUIT

           IF Y="ALL"

               SET PSJSEL("TM","ALL")=""

               QUIT

 +3        DO DICTM

 +4        SET PSJSTOP=$SELECT($DATA(DTOUT):1,$DATA(DUOUT):1,(Y<0)&'$DATA(PFLG):1,1:0)

 +5        QUIT

TM2HLP     WRITE !!,"Enter the name of an Administration Team that you want",!,"to include on the report."," Enter ""ALL"" (or accept the",!,"default) to include all teams on the report.",!

 +1        QUIT

 +2       ;

DICTM     ;*** LooK up a team.

 +1       ;

 +2        KILL DIC

           SET DIC="^PS(57.7,"_+PSJSEL("W")_",1,"

           SET DIC(0)="QEMIZ"

 +3        FOR PFLG=0:1

               DO ^DIC

               if Y<0

                   QUIT

               IF PFLG

                   SET DIC(0)=DIC(0)_"A"

                   SET DIC("A")="Select another Administration Team: "

                   SET PSJSEL("TM",+Y)=Y(0,0)

 +4        QUIT

 +5       ;

RBPPN     ;*** Sort by ROOM-BED or PATIENT

 +1       ;

 +2        KILL DIR

           SET DIR(0)="SAO^R:Room-Bed;P:Patient"

           SET DIR("A")="Do you wish to sort by Room-Bed (R), Patient (P): "

           SET DIR("B")="Patient"

 +3        WRITE !!

           DO ^DIR

           if $$STOP

               QUIT

           SET PSJSEL("RBP")=Y

 +4        QUIT

ENL       ;

 +1        FOR

               WRITE !!,"SHORT, LONG, or NO Profile?  ",$SELECT('$DATA(PSJPWD):"SHORT",PSJPWD:"SHORT",1:"LONG"),"// "

               READ PSJOL:DTIME

               if '$TEST

                   WRITE $CHAR(7)

               if '$TEST

                   SET PSJOL="^"

               if PSJOL="^"

                   QUIT

               DO LCHK

               if "^SLN"[PSJOL&($LENGTH(PSJOL)=1)

                   QUIT

 +2        QUIT

 +3       ;

LCHK      ;

 +1        IF PSJOL?1."?"

               DO LM

               QUIT

 +2        IF PSJOL=""

               SET PSJOL=$SELECT('$DATA(PSJPWD):"S",PSJPWD:"S",1:"L")

               WRITE $PIECE("  SHORT^  LONG","^",PSJOL="L"+1)

               QUIT

 +3        IF PSJOL?.ANP

               IF PSJOL?.E1L.E

                   FOR Q=1:1:$LENGTH(PSJOL)

                       IF $EXTRACT(PSJOL,Q)?.L

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

 +4        IF PSJOL?.ANP

               FOR X="NO PROFILE","LONG","SHORT"

                   IF $PIECE(X,PSJOL)=""

                       WRITE $PIECE(X,PSJOL,2)

                       SET PSJOL=$EXTRACT(PSJOL)

                       QUIT

 +5        if '$TEST

               WRITE $CHAR(7),"  ??"

           QUIT

 +6       ;

LM        ;Profile Type

 +1        WRITE !!?2,"Enter 'SHORT' (or 'S', or press the RETURN key) to exclude this patient's",!,"discontinued and expired orders in the following profile.  Enter 'LONG' (or 'L') to include those orders."

 +2        WRITE "  Enter 'NO' (or 'N') to bypass the profile com-",!,"pletely.  Enter '^' if you wish to go no further with this patient."

           QUIT

ENDPT     ;*** get patient ***

 +1        KILL DIC,PSGP,Y

           WRITE !!,"Select "_$SELECT($DATA(PSGDICA):PSGDICA_" ",1:"")_"PATIENT: "

           READ X:DTIME

           IF "^"[X

               SET (Y,PSGP)=-1

               GOTO DONE

 +2        DO EN^PSJDPT

 +3        IF Y'>0

               GOTO ENDPT

 +4        KILL DIC

 +5       ;

CHK       ;*** Check patient status ***

 +1        SET PPN=$PIECE(Y,U,2)

           SET (DFN,PSGP)=+Y

           SET VA200=1

           DO INP^VADPT

           if VAIN(4)

               QUIT

 +2        SET PSJPCAF=""

           SET VAIP("D")="L"

           DO IN5^VADPT

           IF 'VAIP(13,1)

               WRITE $CHAR(7),!!?3,"PATIENT HAS NEVER BEEN ADMITTED."

               GOTO ENDPT

 +3        SET X=+VAIP(4)=12!(+VAIP(4)=38)

           WRITE $CHAR(7),!!?3,"PATIENT IS FOUND TO BE D",$PIECE("ISCHARG^ECEAS",U,X+1),"ED AS OF ",$$ENDTC^PSGMI(+VAIP(3)),"."

           GOTO ENDPT

 +4        QUIT

 +5       ;

STOP()    ;

 +1       ;

 +2        SET PSJSTOP=$SELECT($DATA(DTOUT):1,$DATA(DUOUT):1,$DATA(DIRUT):1,1:0)

 +3        QUIT PSJSTOP

 +4       ;

DONE      ;

 +1        KILL DA,DIC,DIK

 +2        QUIT

PSJPDIR.m