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
Q
;
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)
Q
;
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
Q
;
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
Q
;
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
Q
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)
Q
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.",!
Q
;
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)
Q
;
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
Q
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)
Q
;
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
Q
;
STOP() ;
;
S PSJSTOP=$S($D(DTOUT):1,$D(DUOUT):1,$D(DIRUT):1,1:0)
Q PSJSTOP
;
DONE ;
K DA,DIC,DIK
Q
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
