DGPMGL1 ;ALB/MRL/LM/MJK - G&L ENTRY POINT CONT.; [ 09/13/2001 3:56 PM ]
;;5.3;Registration;**1005,1015**;Aug 13, 1993;Build 21
;IHS/ANMC/LJF 3/30/2001 changed references to IHS files
; added calls to IHS routines for calculate
; commented out code not needed
;IHS/OIT/LJF 01/05/2006 PATCH 1005 removed 2nd time recalc ran on primary date
;
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 ;IHS/ANMC/LJF 3/30/2001 not needed
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
;
;IHS/ANMC/LJF 3/30/2001 changed reference to IHS file
;I '$D(^DG(41.9,WD,"C",X,0)) W !!,"NO TOTALS EXIST FOR PREVIOUS DAY!!",*7 G WHEN
I '$D(^BDGCWD(+WD,1,X,0)) D G WHEN
. W !!,"NO TOTALS EXIST FOR PREVIOUS DAY!!"
;IHS/ANMC/LJF 3/30/2001 end of code changes
;
I RD=DT,BS W !!," * BED STATUS REPORT WILL NOT BE CALCULATED...TODAY'S ACTIVITY IS INCOMPLETE! *",*7 S BS=0
;
G IHS ;IHS/ANMC/LJF 3/30/2001 skip to line IHS
;
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.",!
;
IHS ; skipped VA code from above and added IHS code;IHS/ANMC/LJF 3/30/2001
I 'BS S RC=0
I BS D RC I $D(%) I %=-1 G Q^DGPMGL
I GL L +^BDGCWD:5 I '$T W !!,"CENSUS FILES LOCKED; SOMEONE ELSE RUNNING RECALC; TRY AGAIN LATER!!" D PAUSE^BDGF D Q^DGPMGL Q
NEW BDGFRM,BDGQUIT W ! D FORMAT^BDGAD0 G:$G(BDGQUIT) Q^DGPMGL
D MSG^BDGF("Printing to HOME puts report into browse mode.",2,1)
;IHS/ANMC/LJF 3/30/2001 end of IHS code
;
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
;
;IHS/ANMC/LJF 3/30/2001 call IHS calculate and print routines
;D:$D(RC) UP43^DGPMBSR,^DGPMBSR D ^DGPMGLG
;
;IHS/OIT/LJF 01/05/2006 PATCH 1005 don't recalc 2nd time into BDGAD1 (DGPMBSR already called BDGAD1)
;D:$D(RC) UP43^DGPMBSR,^DGPMBSR D ^BDGAD1
D:$D(RC) UP43^DGPMBSR,^DGPMBSR S BDGREP=1 D ^BDGAD1
;
D ^BDGADD:BDGFRM="D",^BDGADS:BDGFRM="S" ;detailed vs summary format
;IHS/ANMC/LJF 3/30/2001 end of code changes
;
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
;
;IHS/ANMC/LJF 3/30/2001 reference IHS files
;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
I $O(^DIC(42,"AGL",0)) S WD=$O(^DIC(42,"AGL",$O(^(0)),0)) I '$D(^BDGCWD(+WD,1,RD,0)) S RC=RD,%=1 G RCQ
;IHS/ANMC/LJF 3/30/2001 end of code changes
;
;
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
;
;IHS/ANMC/LJF 3/30/2001 changed prompt
;W !!,"Recalculate BSR" W:TSR "/TSR" W " Totals" S %=2 D YN^DICN G RCQ:%=-1
I $G(BDGREP) S %=2 ;reprint option selected from menu
E W !!,"Recalculate Totals" S %=2 D YN^DICN G RCQ:%=-1 S:%=2 BDGREP=1
;IHS/ANMC/LJF 3/30/2001 end of code changes
;
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)=""
;
S ZTSAVE("BDGFRM")="" ;IHS/ANMC/LJF 3/30/2001 add IHS variable
;
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 ;
DGPMGL1 ;ALB/MRL/LM/MJK - G&L ENTRY POINT CONT.; [ 09/13/2001 3:56 PM ]
+1 ;;5.3;Registration;**1005,1015**;Aug 13, 1993;Build 21
+2 ;IHS/ANMC/LJF 3/30/2001 changed references to IHS files
+3 ; added calls to IHS routines for calculate
+4 ; commented out code not needed
+5 ;IHS/OIT/LJF 01/05/2006 PATCH 1005 removed 2nd time recalc ran on primary date
+6 ;
+7 QUIT
+8 ; 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 ;I TSR,TSRI]"",TSLD S Y=TSLD X:Y]"" ^DD("DD") W !!,"LAST TREATING SPECIALTY REPORT TOTALS EXIST FOR ",Y ;IHS/ANMC/LJF 3/30/2001 not needed
+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 ;
+8 ;IHS/ANMC/LJF 3/30/2001 changed reference to IHS file
+9 ;I '$D(^DG(41.9,WD,"C",X,0)) W !!,"NO TOTALS EXIST FOR PREVIOUS DAY!!",*7 G WHEN
+10 IF '$DATA(^BDGCWD(+WD,1,X,0))
Begin DoDot:1
+11 WRITE !!,"NO TOTALS EXIST FOR PREVIOUS DAY!!"
End DoDot:1
GOTO WHEN
+12 ;IHS/ANMC/LJF 3/30/2001 end of code changes
+13 ;
+14 IF RD=DT
IF BS
WRITE !!," * BED STATUS REPORT WILL NOT BE CALCULATED...TODAY'S ACTIVITY IS INCOMPLETE! *",*7
SET BS=0
+15 ;
+16 ;IHS/ANMC/LJF 3/30/2001 skip to line IHS
GOTO IHS
+17 ;
+18 IF RD=DT
IF TSR
WRITE !!," * THE TSR WILL NOT PRINT...TODAY'S ACTIVITY IS INCOMPLETE! *",*7
SET TSR=0
+19 IF 'GL
IF 'BS
IF 'TSR
GOTO WHEN
+20 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
+21 ; 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 ;
IHS ; skipped VA code from above and added IHS code;IHS/ANMC/LJF 3/30/2001
+1 IF 'BS
SET RC=0
+2 IF BS
DO RC
IF $DATA(%)
IF %=-1
GOTO Q^DGPMGL
+3 IF GL
LOCK +^BDGCWD:5
IF '$TEST
WRITE !!,"CENSUS FILES LOCKED; SOMEONE ELSE RUNNING RECALC; TRY AGAIN LATER!!"
DO PAUSE^BDGF
DO Q^DGPMGL
QUIT
+4 NEW BDGFRM,BDGQUIT
WRITE !
DO FORMAT^BDGAD0
IF $GET(BDGQUIT)
GOTO Q^DGPMGL
+5 DO MSG^BDGF("Printing to HOME puts report into browse mode.",2,1)
+6 ;IHS/ANMC/LJF 3/30/2001 end of IHS code
+7 ;
+8 SET %ZIS="QM"
DO ^%ZIS
IF POP!(IO="")
GOTO Q
IF $DATA(IO("Q"))
KILL IO("Q")
DO QUE
GOTO Q
+9 USE IO
+10 ;
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 ;
+3 ;IHS/ANMC/LJF 3/30/2001 call IHS calculate and print routines
+4 ;D:$D(RC) UP43^DGPMBSR,^DGPMBSR D ^DGPMGLG
+5 ;
+6 ;IHS/OIT/LJF 01/05/2006 PATCH 1005 don't recalc 2nd time into BDGAD1 (DGPMBSR already called BDGAD1)
+7 ;D:$D(RC) UP43^DGPMBSR,^DGPMBSR D ^BDGAD1
+8 IF $DATA(RC)
DO UP43^DGPMBSR
DO ^DGPMBSR
SET BDGREP=1
DO ^BDGAD1
+9 ;
+10 ;detailed vs summary format
IF BDGFRM="D"
DO ^BDGADD
IF BDGFRM="S"
DO ^BDGADS
+11 ;IHS/ANMC/LJF 3/30/2001 end of code changes
+12 ;
+13 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 ;
+6 ;IHS/ANMC/LJF 3/30/2001 reference IHS files
+7 ;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
+8 IF $ORDER(^DIC(42,"AGL",0))
SET WD=$ORDER(^DIC(42,"AGL",$ORDER(^(0)),0))
IF '$DATA(^BDGCWD(+WD,1,RD,0))
SET RC=RD
SET %=1
GOTO RCQ
+9 ;IHS/ANMC/LJF 3/30/2001 end of code changes
+10 ;
+11 ;
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 ;
+4 ;IHS/ANMC/LJF 3/30/2001 changed prompt
+5 ;W !!,"Recalculate BSR" W:TSR "/TSR" W " Totals" S %=2 D YN^DICN G RCQ:%=-1
+6 ;reprint option selected from menu
IF $GET(BDGREP)
SET %=2
+7 IF '$TEST
WRITE !!,"Recalculate Totals"
SET %=2
DO YN^DICN
IF %=-1
GOTO RCQ
IF %=2
SET BDGREP=1
+8 ;IHS/ANMC/LJF 3/30/2001 end of code changes
+9 ;
+10 IF %
SET RC=$SELECT(%=2:0,'CD:RD,CD<RD:CD,1:RD)
GOTO RCQ
+11 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 ;
+3 ;IHS/ANMC/LJF 3/30/2001 add IHS variable
SET ZTSAVE("BDGFRM")=""
+4 ;
+5 DO ^%ZTLOAD
QUIT
+6 ;
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 ;
