- DGYMBSRX ;ALB/ABR - REPORT OF G&L ORDERS FROM FILE 42
- ;;5.3;Registration;**59,1015**;Aug 13, 1993;Build 21
- ;
- 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
- DGYMBSRX ;ALB/ABR - REPORT OF G&L ORDERS FROM FILE 42
- +1 ;;5.3;Registration;**59,1015**;Aug 13, 1993;Build 21
- +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
