PSJMDIR1.m

PSJMDIR1 ;BIR/MV-MED DUE WORKSHEET DIR CALLS CONT. ;17 JUN 96 / 1:40 PM

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

 ;

GWP(PSJMDWS) ;*** Ask for seletion from WARD GROUP,WARD,PATIENT

 ;PSJMDWS=1 when called by Med Due Work Sheet function.

 K DIR S 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 S PSJSTOP=$S(Y="":1,Y<0:1,$$STOP:1,1:0)

 I 'PSJSTOP S PSGSS=Y D @Y

 Q PSJSTOP

 ;

P ;*** Select by Patient

 ;

 N PSJACNWP,PSGDICA,PAGPAT S PSJACNWP=""

 F PFLG=0:1 S:PFLG PSGDICA="another" D ^PSJMP Q:PSGP<0  S PSGPAT(PPN)=PSGP I $G(PSJMDWS) 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 PSGWD=+Y,PSGWN=Y(0,0) D ADMTM^PSJMDIR D:'PSJSTOP&(PSJMDWS) RBADM^PSJMDIR

 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

 I Y<0,X="^OTHER" S PSJSTOP=0,PSGSS="C",(PSGWN,PSGWGNM)="OTHER" D:PSJMDWS RBADM^PSJMDIR Q

 Q:$$STOP

 S PSGWG=+Y,PSGWGNM=$P(Y,U,2) D:PSJMDWS RBADM^PSJMDIR

 Q

 ;

 ;

STOP() ;

 ;

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

 Q PSJSTOP

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---PSJMDIR1   1572     printed  Apr 09, 2024@21:03:50                                                                                                                                                                                                    Page 2

PSJMDIR1  ;BIR/MV-MED DUE WORKSHEET DIR CALLS CONT. ;17 JUN 96 / 1:40 PM

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

 +2       ;

GWP(PSJMDWS) ;*** Ask for seletion from WARD GROUP,WARD,PATIENT

 +1       ;PSJMDWS=1 when called by Med Due Work Sheet function.

 +2        KILL DIR

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

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

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

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

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

 +6        WRITE !!

           DO ^DIR

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

 +7        IF 'PSJSTOP

               SET PSGSS=Y

               DO @Y

 +8        QUIT PSJSTOP

 +9       ;

P         ;*** Select by Patient

 +1       ;

 +2        NEW PSJACNWP,PSGDICA,PAGPAT

           SET PSJACNWP=""

 +3        FOR PFLG=0:1

               if PFLG

                   SET PSGDICA="another"

               DO ^PSJMP

               if PSGP<0

                   QUIT 

               SET PSGPAT(PPN)=PSGP

               IF $GET(PSJMDWS)

                   if '$GET(PSJPWDO)

                       SET (PSGWD,PSJPWDO)=PSJPWD

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

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

 +5        QUIT 

 +6       ;

W         ;*** Select by WARD

 +1       ;

 +2        KILL DIC

           SET DIC="^DIC(42,"

           SET DIC(0)="QEAMIZ"

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

           WRITE !!

           DO ^DIC

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

 +4        IF 'PSJSTOP

               SET PSGWD=+Y

               SET PSGWN=Y(0,0)

               DO ADMTM^PSJMDIR

               if 'PSJSTOP&(PSJMDWS)

                   DO RBADM^PSJMDIR

 +5        QUIT 

 +6       ;

G         ;***Select by WARD GROUP

 +1       ;

 +2        KILL DIC

           SET DIC="^PS(57.5,"

           SET DIC(0)="QEAMI"

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

           WRITE !!

 +3        DO ^DIC

 +4        IF Y<0

               IF X="^OTHER"

                   SET PSJSTOP=0

                   SET PSGSS="C"

                   SET (PSGWN,PSGWGNM)="OTHER"

                   if PSJMDWS

                       DO RBADM^PSJMDIR

                   QUIT 

 +5        if $$STOP

               QUIT 

 +6        SET PSGWG=+Y

           SET PSGWGNM=$PIECE(Y,U,2)

           if PSJMDWS

               DO RBADM^PSJMDIR

 +7        QUIT 

 +8       ;

 +9       ;

STOP()    ;

 +1       ;

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

 +3        QUIT PSJSTOP