DGPMGL1 ;ALB/MRL/LM/MJK - G&L ENTRY POINT CONT.; 1 FEB 89
;;5.3;Registration;;Aug 13, 1993
;
Q
; Continuation from DGPMGL
A S REM=0 I BS!(GL) S Y=LD X:Y]"" ^DD("DD") W !!,"LAST BED STATUS REPORT TOTALS EXIST FOR ",Y
I TSR,TSRI]"",TSLD S Y=TSLD X:Y]"" ^DD("DD") W !!,"LAST TREATING SPECIALTY REPORT TOTALS EXIST FOR ",Y
S X1=DT,X2=-1 D C^%DTC S YD=X
; Updating last date G&L generated
I LD'=YD S X1=LD,X2=1 D C^%DTC S (LD,Y)=X X ^DD("DD")
I LD=YD S LD=DT
K ^UTILITY($J)
S DD=Y
;
WHEN ; Asking when to print report/s
W !!,"PRINT REPORT",$S(GL&BS:"S",1:"")," FOR WHICH DATE: ",DD,"// " R X:DTIME
G Q:X["^"!('$T) S:X="" X=DD S %DT="EPX" D ^%DT G WHEN:Y<0
S (RD,X1)=+Y,X2=-1 D C^%DTC S PD=X
I Y<DGPM("G") S Y=+DGPM("G") X ^DD("DD") W !!,"EARLIEST DATE ALLOWED IS ",Y,".",*7 G WHEN
I Y>DT S Y=DT X ^DD("DD") W !!,"CHOOSE A DATE ON OR BEFORE ",Y,".",*7 G WHEN
I Y<LD S X1=Y,X2=-1 D C^%DTC
I '$D(^DG(41.9,WD,"C",X,0)) W !!,"NO TOTALS EXIST FOR PREVIOUS DAY!!",*7 G WHEN
I RD=DT,BS W !!," * BED STATUS REPORT WILL NOT BE CALCULATED...TODAY'S ACTIVITY IS INCOMPLETE! *",*7 S BS=0
I RD=DT,TSR W !!," * THE TSR WILL NOT PRINT...TODAY'S ACTIVITY IS INCOMPLETE! *",*7 S TSR=0
I 'GL,'BS,'TSR G WHEN
I TSR I TSRI]"" I RD<TSRI S Y=+TSRI X ^DD("DD") W !!,"EARLIEST DATE FOR TREATING SPECIALTY REPORT IS ",Y,".",*7,!!,"TREATING SPECIALTY REPORT WILL NOT BE PRINTED FOR THE DATE SELECTED!" I 'BS,'GL G WHEN
I RD=YD,$D(^DG(43,1,"NOT")),$P(^("NOT"),"^",8) D ^DGABUL ; Transmit Overdue Absence Bulletin
ADC I BS D ^DGPMGL2
I 'BS&('TSR) S RC=0 D ^DGPMGL2
I BS!(TSR) D RC I $D(%) G:%=-1 Q^DGPMGL I '$D(RCCK) G:%=2 Q^DGPMGL
W !!,"Note: This output should be printed at a column width of 132.",!
S %ZIS="QM" D ^%ZIS G Q:POP!(IO="") I $D(IO("Q")) K IO("Q") D QUE G Q
U IO
;
GO D CLEAN^DGPMGLG
D NOW^%DTC S Y=$E(%,1,12) X ^DD("DD") S DGNOW=Y ; used to print date/time of report
D:$D(RC) UP43^DGPMBSR,^DGPMBSR D ^DGPMGLG
S DIE="^DG(43,",DA=1,DR="54////@;55////@;56////@" D ^DIE
Q G DONE^DGPMGLG
;
RC ; G&L corrections
S RC=$S($P(DGPM("G"),"^",7)>+DGPM("G"):$P(DGPM("G"),"^",7),1:+DGPM("G")),CD=$O(^DGS(43.5,"AGL",RC-1))
I CD,CD'>RD S Y=CD X ^DD("DD") W !!,"G&L corrections exist from ",Y,"."
S X1=DT,X2=-7 D C^%DTC S LW=X ; Last Week
I CD>LW,CD'>RD S RC=CD,%=1 W !,"SINCE G&L CORRECTIONS ARE RECENT (WITHIN LAST WEEK) RECALCULATION WILL OCCUR",!,"AUTOMATICALLY AS THE "_$S('TSR:"BED STATUS REPORT",'BS:"TREATING SPECIALTY REPORT",1:"BSR AND TSR")_" IS COMPUTED!" G RCQ
I $O(^DIC(42,"AGL",0)) S WD=$O(^DIC(42,"AGL",$O(^(0)),0)) I '$D(^DG(41.9,WD,"C",RD,0)) S RC=RD,%=1 G RCQ
;
RC1 D RCCK^DGPMBSAR ; Check for ReCalc already running
I '$D(RCCK) I $P(DGPM("GLS"),"^",5) I $D(%) I %=2!(%=-1) Q
I $D(RCR) S RC=0 Q
W !!,"Recalculate BSR" W:TSR "/TSR" W " Totals" S %=2 D YN^DICN G RCQ:%=-1
I % S RC=$S(%=2:0,'CD:RD,CD<RD:CD,1:RD) G RCQ
I '% W !?4,"Answer YES to recalculate totals to insure accurancy or NO to simply print",!?4,"report with existing CENSUS file totals." G RC1
RCQ K LW Q
;
QUE S ZTIO=ION_";"_$S($D(IOST)#2:IOST,1:"")_";"_$S($D(IOM)#2:IOM,1:"")_";"_$S($D(IOSL)#2:IOSL,1:""),ZTDESC=$S(GL&(BS):"G&L AND BSR",GL:"G&L",1:"BSR")_" GENERATION",ZTRTN="GO^DGPMGL1"
F I="DUZ","DIV","RD","TSR","TSRI","BS","GL","DGPM(""G"")","DGPM(""GL"")","DUZ","REM","PD","RC","RM","SS","MT","TS","CP","OS","SNM","VN","SF","TSD" S ZTSAVE(I)=""
D ^%ZTLOAD Q
;
VAR ; REM=Recalc Patient Days ; LD=Last Date G&L was run ; YD=YesterDay ;
; RD=Report Date ; PD=Previous Date ; CD= Correction Date ;
; RC=ReCalc from date ;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPMGL1 3602 printed Sep 23, 2025@20:25:25 Page 2
DGPMGL1 ;ALB/MRL/LM/MJK - G&L ENTRY POINT CONT.; 1 FEB 89
+1 ;;5.3;Registration;;Aug 13, 1993
+2 ;
+3 QUIT
+4 ; Continuation from DGPMGL
A SET REM=0
IF BS!(GL)
SET Y=LD
if Y]""
XECUTE ^DD("DD")
WRITE !!,"LAST BED STATUS REPORT TOTALS EXIST FOR ",Y
+1 IF TSR
IF TSRI]""
IF TSLD
SET Y=TSLD
if Y]""
XECUTE ^DD("DD")
WRITE !!,"LAST TREATING SPECIALTY REPORT TOTALS EXIST FOR ",Y
+2 SET X1=DT
SET X2=-1
DO C^%DTC
SET YD=X
+3 ; Updating last date G&L generated
+4 IF LD'=YD
SET X1=LD
SET X2=1
DO C^%DTC
SET (LD,Y)=X
XECUTE ^DD("DD")
+5 IF LD=YD
SET LD=DT
+6 KILL ^UTILITY($JOB)
+7 SET DD=Y
+8 ;
WHEN ; Asking when to print report/s
+1 WRITE !!,"PRINT REPORT",$SELECT(GL&BS:"S",1:"")," FOR WHICH DATE: ",DD,"// "
READ X:DTIME
+2 if X["^"!('$TEST)
GOTO Q
if X=""
SET X=DD
SET %DT="EPX"
DO ^%DT
if Y<0
GOTO WHEN
+3 SET (RD,X1)=+Y
SET X2=-1
DO C^%DTC
SET PD=X
+4 IF Y<DGPM("G")
SET Y=+DGPM("G")
XECUTE ^DD("DD")
WRITE !!,"EARLIEST DATE ALLOWED IS ",Y,".",*7
GOTO WHEN
+5 IF Y>DT
SET Y=DT
XECUTE ^DD("DD")
WRITE !!,"CHOOSE A DATE ON OR BEFORE ",Y,".",*7
GOTO WHEN
+6 IF Y<LD
SET X1=Y
SET X2=-1
DO C^%DTC
+7 IF '$DATA(^DG(41.9,WD,"C",X,0))
WRITE !!,"NO TOTALS EXIST FOR PREVIOUS DAY!!",*7
GOTO WHEN
+8 IF RD=DT
IF BS
WRITE !!," * BED STATUS REPORT WILL NOT BE CALCULATED...TODAY'S ACTIVITY IS INCOMPLETE! *",*7
SET BS=0
+9 IF RD=DT
IF TSR
WRITE !!," * THE TSR WILL NOT PRINT...TODAY'S ACTIVITY IS INCOMPLETE! *",*7
SET TSR=0
+10 IF 'GL
IF 'BS
IF 'TSR
GOTO WHEN
+11 IF TSR
IF TSRI]""
IF RD<TSRI
SET Y=+TSRI
XECUTE ^DD("DD")
WRITE !!,"EARLIEST DATE FOR TREATING SPECIALTY REPORT IS ",Y,".",*7,!!,"TREATING SPECIALTY REPORT WILL NOT BE PRINTED FOR THE DATE SELECTED!"
IF 'BS
IF 'GL
GOTO WHEN
+12 ; Transmit Overdue Absence Bulletin
IF RD=YD
IF $DATA(^DG(43,1,"NOT"))
IF $PIECE(^("NOT"),"^",8)
DO ^DGABUL
ADC IF BS
DO ^DGPMGL2
+1 IF 'BS&('TSR)
SET RC=0
DO ^DGPMGL2
+2 IF BS!(TSR)
DO RC
IF $DATA(%)
if %=-1
GOTO Q^DGPMGL
IF '$DATA(RCCK)
if %=2
GOTO Q^DGPMGL
+3 WRITE !!,"Note: This output should be printed at a column width of 132.",!
+4 SET %ZIS="QM"
DO ^%ZIS
if POP!(IO="")
GOTO Q
IF $DATA(IO("Q"))
KILL IO("Q")
DO QUE
GOTO Q
+5 USE IO
+6 ;
GO DO CLEAN^DGPMGLG
+1 ; used to print date/time of report
DO NOW^%DTC
SET Y=$EXTRACT(%,1,12)
XECUTE ^DD("DD")
SET DGNOW=Y
+2 if $DATA(RC)
DO UP43^DGPMBSR
DO ^DGPMBSR
DO ^DGPMGLG
+3 SET DIE="^DG(43,"
SET DA=1
SET DR="54////@;55////@;56////@"
DO ^DIE
Q GOTO DONE^DGPMGLG
+1 ;
RC ; G&L corrections
+1 SET RC=$SELECT($PIECE(DGPM("G"),"^",7)>+DGPM("G"):$PIECE(DGPM("G"),"^",7),1:+DGPM("G"))
SET CD=$ORDER(^DGS(43.5,"AGL",RC-1))
+2 IF CD
IF CD'>RD
SET Y=CD
XECUTE ^DD("DD")
WRITE !!,"G&L corrections exist from ",Y,"."
+3 ; Last Week
SET X1=DT
SET X2=-7
DO C^%DTC
SET LW=X
+4 IF CD>LW
IF CD'>RD
SET RC=CD
SET %=1
WRITE !,"SINCE G&L CORRECTIONS ARE RECENT (WITHIN LAST WEEK) RECALCULATION WILL OCCUR",!,"AUTOMATICALLY AS THE "_$SELECT('TSR:"BED STATUS REPORT",'BS:"TREATING SPECIALTY REPORT",1:"BSR AND TSR")_" IS COMPUTED!"
GOTO RCQ
+5 IF $ORDER(^DIC(42,"AGL",0))
SET WD=$ORDER(^DIC(42,"AGL",$ORDER(^(0)),0))
IF '$DATA(^DG(41.9,WD,"C",RD,0))
SET RC=RD
SET %=1
GOTO RCQ
+6 ;
RC1 ; Check for ReCalc already running
DO RCCK^DGPMBSAR
+1 IF '$DATA(RCCK)
IF $PIECE(DGPM("GLS"),"^",5)
IF $DATA(%)
IF %=2!(%=-1)
QUIT
+2 IF $DATA(RCR)
SET RC=0
QUIT
+3 WRITE !!,"Recalculate BSR"
if TSR
WRITE "/TSR"
WRITE " Totals"
SET %=2
DO YN^DICN
if %=-1
GOTO RCQ
+4 IF %
SET RC=$SELECT(%=2:0,'CD:RD,CD<RD:CD,1:RD)
GOTO RCQ
+5 IF '%
WRITE !?4,"Answer YES to recalculate totals to insure accurancy or NO to simply print",!?4,"report with existing CENSUS file totals."
GOTO RC1
RCQ KILL LW
QUIT
+1 ;
QUE SET ZTIO=ION_";"_$SELECT($DATA(IOST)#2:IOST,1:"")_";"_$SELECT($DATA(IOM)#2:IOM,1:"")_";"_$SELECT($DATA(IOSL)#2:IOSL,1:"")
SET ZTDESC=$SELECT(GL&(BS):"G&L AND BSR",GL:"G&L",1:"BSR")_" GENERATION"
SET ZTRTN="GO^DGPMGL1"
+1 FOR I="DUZ","DIV","RD","TSR","TSRI","BS","GL","DGPM(""G"")","DGPM(""GL"")","DUZ","REM","PD","RC","RM","SS","MT","TS","CP","OS","SNM","VN","SF","TSD"
SET ZTSAVE(I)=""
+2 DO ^%ZTLOAD
QUIT
+3 ;
VAR ; REM=Recalc Patient Days ; LD=Last Date G&L was run ; YD=YesterDay ;
+1 ; RD=Report Date ; PD=Previous Date ; CD= Correction Date ;
+2 ; RC=ReCalc from date ;
