DGYMBSRX ;ALB/ABR - REPORT OF G&L ORDERS FROM FILE 42
;;5.3;Registration;**59**;Aug 13, 1993
;
EN ;set up temp global based on G&L ORDER
W !!,"WARD LOCATION FILE DIAGNOSTIC ROUTINE",!!
S ZTDESC="Diagnostic List for WARD LOCATION file",ZTRTN="EN1^DGYMBSRX"
D ZIS^DGUTQ
I 'POP D EN1^DGYMBSRX
Q K I,POP,X,ZTDESC,ZTIO,ZTRTN,ZTSK
D CLOSE^DGUTQ
Q
;
EN1 ;
D KILL
S DGGDATE=$$HTE^XLFDT($H)
N PAGE,FLAG,LINE S (PAGE,FLAG)=0
D HEADER I FLAG Q
F I=0:0 S I=$O(^DIC(42,I)) Q:'I S DGGL=+$G(^DIC(42,I,"ORDER")) S ^TMP("DG59",$J,DGGL)=$G(^TMP("DG59",$J,DGGL))+1,^(DGGL,I)="" D LVL
D NOGLO I FLAG G KILL
D SAMEGLO I FLAG G KILL
D LEVEL I FLAG G KILL
W:$E(IOST,1,2)="C-" !!,">> DONE!"
;
KILL K I,J,DGGL,DGGDATE,DGNO,DGLVL,DGOLVL,SAGL,^TMP("DG59",$J)
Q
;
LVL ; check for sequential TOTALS
N DGLVL,DGOLVL
F DGLVL=0:0 S DGOLVL=DGLVL,DGLVL=$O(^DIC(42,I,1,DGLVL)) Q:'DGLVL I DGLVL-DGOLVL'=1 S ^TMP("DG59",$J,"DGLVL",I)=$P(^DIC(42,I,0),"^")
K DGLVL,DGOLVL
Q
;
NOGLO ;LOCATIONS W/ NO G&L ORDER
I '$G(^TMP("DG59",$J,0)) Q
S $P(LINE,"=",31)=""
W !!,"**The following ward locations have no G&L order, ",!,"and do not appear on the G&L Sheet or Bed Status Report."
W !!,"IEN",?10,"Ward Location",!,LINE
F DGNO=0:0 S DGNO=$O(^TMP("DG59",$J,0,DGNO)) Q:'DGNO D Q:FLAG
.I $Y>(IOSL-4) D HEADER I FLAG Q
.W !,DGNO,?10,$P(^DIC(42,DGNO,0),"^")
W !
Q
;
SAMEGLO ;shared g&l orders
N DGCHK S DGCHK=1
F I=0:0 S I=$O(^TMP("DG59",$J,I)) Q:'I I ^(I)>1 D
.I DGCHK,$Y>(IOSL-8) D HEADER I FLAG Q
.I DGCHK W !!,"*SHARED G&L ORDERS*",!,"===================" S DGCHK=0
. W !!,"The following locations all have the G&L ORDER = ",I
. F SAGL=0:0 S SAGL=$O(^TMP("DG59",$J,I,SAGL)) Q:'SAGL D Q:FLAG
..I $Y>(IOSL-4) D HEADER I FLAG Q
..W !,"IEN = ",SAGL,?12,"WARD LOCATION = ",$P(^DIC(42,SAGL,0),"^")
. W !?15,"*** ONLY THE LAST OF THIS GROUP WILL APPEAR ON THE BSR ***"
W !
Q
;
LEVEL ; list wards with problem TOTALS
S $P(LINE,"=",31)=""
I '$O(^TMP("DG59",$J,"DGLVL",0)) Q
W !!,"**The following locations are missing lower level TOTALS:",!
W !,"IEN",?10,"Ward Location",!,LINE
F DGLVL=0:0 S DGLVL=$O(^TMP("DG59",$J,"DGLVL",DGLVL)) Q:'DGLVL W !,DGLVL,?10,^(DGLVL)
Q
;
N DIR,DIRUT,DTOUT,DUOUT,LINE2,X,Y,I
S PAGE=PAGE+1,$P(LINE2,"=",80)=""
I $E(IOST,1,2)="C-",(PAGE>1) S DIR(0)="E" D ^DIR S FLAG='Y I FLAG Q
W @IOF,!,"WARD LOCATION FILE Diagnostics Report",?70,"PAGE: ",$J(PAGE,2)
W !,DGGDATE
W !,LINE2
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGYMBSRX 2535 printed Sep 23, 2025@20:36:10 Page 2
DGYMBSRX ;ALB/ABR - REPORT OF G&L ORDERS FROM FILE 42
+1 ;;5.3;Registration;**59**;Aug 13, 1993
+2 ;
EN ;set up temp global based on G&L ORDER
+1 WRITE !!,"WARD LOCATION FILE DIAGNOSTIC ROUTINE",!!
+2 SET ZTDESC="Diagnostic List for WARD LOCATION file"
SET ZTRTN="EN1^DGYMBSRX"
+3 DO ZIS^DGUTQ
+4 IF 'POP
DO EN1^DGYMBSRX
Q KILL I,POP,X,ZTDESC,ZTIO,ZTRTN,ZTSK
+1 DO CLOSE^DGUTQ
+2 QUIT
+3 ;
EN1 ;
+1 DO KILL
+2 SET DGGDATE=$$HTE^XLFDT($HOROLOG)
+3 NEW PAGE,FLAG,LINE
SET (PAGE,FLAG)=0
+4 DO HEADER
IF FLAG
QUIT
+5 FOR I=0:0
SET I=$ORDER(^DIC(42,I))
if 'I
QUIT
SET DGGL=+$GET(^DIC(42,I,"ORDER"))
SET ^TMP("DG59",$JOB,DGGL)=$GET(^TMP("DG59",$JOB,DGGL))+1
SET ^(DGGL,I)=""
DO LVL
+6 DO NOGLO
IF FLAG
GOTO KILL
+7 DO SAMEGLO
IF FLAG
GOTO KILL
+8 DO LEVEL
IF FLAG
GOTO KILL
+9 if $EXTRACT(IOST,1,2)="C-"
WRITE !!,">> DONE!"
+10 ;
KILL KILL I,J,DGGL,DGGDATE,DGNO,DGLVL,DGOLVL,SAGL,^TMP("DG59",$JOB)
+1 QUIT
+2 ;
LVL ; check for sequential TOTALS
+1 NEW DGLVL,DGOLVL
+2 FOR DGLVL=0:0
SET DGOLVL=DGLVL
SET DGLVL=$ORDER(^DIC(42,I,1,DGLVL))
if 'DGLVL
QUIT
IF DGLVL-DGOLVL'=1
SET ^TMP("DG59",$JOB,"DGLVL",I)=$PIECE(^DIC(42,I,0),"^")
+3 KILL DGLVL,DGOLVL
+4 QUIT
+5 ;
NOGLO ;LOCATIONS W/ NO G&L ORDER
+1 IF '$GET(^TMP("DG59",$JOB,0))
QUIT
+2 SET $PIECE(LINE,"=",31)=""
+3 WRITE !!,"**The following ward locations have no G&L order, ",!,"and do not appear on the G&L Sheet or Bed Status Report."
+4 WRITE !!,"IEN",?10,"Ward Location",!,LINE
+5 FOR DGNO=0:0
SET DGNO=$ORDER(^TMP("DG59",$JOB,0,DGNO))
if 'DGNO
QUIT
Begin DoDot:1
+6 IF $Y>(IOSL-4)
DO HEADER
IF FLAG
QUIT
+7 WRITE !,DGNO,?10,$PIECE(^DIC(42,DGNO,0),"^")
End DoDot:1
if FLAG
QUIT
+8 WRITE !
+9 QUIT
+10 ;
SAMEGLO ;shared g&l orders
+1 NEW DGCHK
SET DGCHK=1
+2 FOR I=0:0
SET I=$ORDER(^TMP("DG59",$JOB,I))
if 'I
QUIT
IF ^(I)>1
Begin DoDot:1
+3 IF DGCHK
IF $Y>(IOSL-8)
DO HEADER
IF FLAG
QUIT
+4 IF DGCHK
WRITE !!,"*SHARED G&L ORDERS*",!,"==================="
SET DGCHK=0
+5 WRITE !!,"The following locations all have the G&L ORDER = ",I
+6 FOR SAGL=0:0
SET SAGL=$ORDER(^TMP("DG59",$JOB,I,SAGL))
if 'SAGL
QUIT
Begin DoDot:2
+7 IF $Y>(IOSL-4)
DO HEADER
IF FLAG
QUIT
+8 WRITE !,"IEN = ",SAGL,?12,"WARD LOCATION = ",$PIECE(^DIC(42,SAGL,0),"^")
End DoDot:2
if FLAG
QUIT
+9 WRITE !?15,"*** ONLY THE LAST OF THIS GROUP WILL APPEAR ON THE BSR ***"
End DoDot:1
+10 WRITE !
+11 QUIT
+12 ;
LEVEL ; list wards with problem TOTALS
+1 SET $PIECE(LINE,"=",31)=""
+2 IF '$ORDER(^TMP("DG59",$JOB,"DGLVL",0))
QUIT
+3 WRITE !!,"**The following locations are missing lower level TOTALS:",!
+4 WRITE !,"IEN",?10,"Ward Location",!,LINE
+5 FOR DGLVL=0:0
SET DGLVL=$ORDER(^TMP("DG59",$JOB,"DGLVL",DGLVL))
if 'DGLVL
QUIT
WRITE !,DGLVL,?10,^(DGLVL)
+6 QUIT
+7 ;
+1 NEW DIR,DIRUT,DTOUT,DUOUT,LINE2,X,Y,I
+2 SET PAGE=PAGE+1
SET $PIECE(LINE2,"=",80)=""
+3 IF $EXTRACT(IOST,1,2)="C-"
IF (PAGE>1)
SET DIR(0)="E"
DO ^DIR
SET FLAG='Y
IF FLAG
QUIT
+4 WRITE @IOF,!,"WARD LOCATION FILE Diagnostics Report",?70,"PAGE: ",$JUSTIFY(PAGE,2)
+5 WRITE !,DGGDATE
+6 WRITE !,LINE2
+7 QUIT
