- BGP8UTL3 ; IHS/CMI/LAB - UTILITIES ;
- ;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66
- ;
- ONN4 ;EP
- K BGPEXCT
- S Y=$$OPEN^%ZISH(BGPUF,BGPFONN4,"W")
- I Y=1 W:'$D(ZTQUEUED) !!,"Cannot open host file." Q
- U IO
- S BGPP=0,BGPY=$O(^BGPCTRL("B","2018",0)),BGPX="",BGPEC=$P(^BGPCTRL(BGPY,0),U,25)
- F S BGPP=$O(^BGPCTRL(BGPY,86,BGPP)) Q:BGPP'=+BGPP D
- .S BGPPP1=$P(^BGPCTRL(BGPY,86,BGPP,0),U,1)
- .S BGPZ=$P(^BGPCTRL(BGPY,86,BGPP,0),U,2)
- .S $P(BGPX,U,BGPPP1)=BGPZ
- W BGPX,!
- K BGPX
- S BGPX="" S P=11 F S $P(BGPX,U,P)="Current",P=P+9 Q:P>(BGPEC-8)
- S P=14 F S $P(BGPX,U,P)="Previous",P=P+9 Q:P>(BGPEC-5)
- S P=17 F S $P(BGPX,U,P)="Baseline",P=P+9 Q:P>(BGPEC+1)
- W BGPX,!
- K BGPX
- D SETHDR^BGP8UTL
- S P=11 F S $P(BGPX,U,P)="Num",P=P+3 Q:P>(BGPEC-2)
- S P=12 F S $P(BGPX,U,P)="Den",P=P+3 Q:P>(BGPEC-1)
- S P=13 F S $P(BGPX,U,P)="%",P=P+3 Q:P>BGPEC
- W BGPX,!
- S BGPX=0 F S BGPX=$O(BGPONN4(BGPX)) Q:BGPX'=+BGPX W BGPONN4(BGPX),!
- K BGPONN4
- D ^%ZISC
- Q
- ONN5 ;
- K BGPEXCT
- S Y=$$OPEN^%ZISH(BGPUF,BGPFONN5,"W")
- I Y=1 W:'$D(ZTQUEUED) !!,"Cannot open host file." Q
- U IO
- S BGPP=0,BGPY=$O(^BGPCTRL("B","2018",0)),BGPX="",BGPEC=$P(^BGPCTRL(BGPY,0),U,26)
- F S BGPP=$O(^BGPCTRL(BGPY,87,BGPP)) Q:BGPP'=+BGPP D
- .S BGPPP1=$P(^BGPCTRL(BGPY,87,BGPP,0),U,1)
- .S BGPZ=$P(^BGPCTRL(BGPY,87,BGPP,0),U,2)
- .S $P(BGPX,U,BGPPP1)=BGPZ
- W BGPX,!
- K BGPX
- S BGPX="" S P=11 F S $P(BGPX,U,P)="Current",P=P+9 Q:P>(BGPEC-8)
- S P=14 F S $P(BGPX,U,P)="Previous",P=P+9 Q:P>(BGPEC-5)
- S P=17 F S $P(BGPX,U,P)="Baseline",P=P+9 Q:P>(BGPEC+1)
- W BGPX,!
- K BGPX
- D SETHDR^BGP8UTL
- S P=11 F S $P(BGPX,U,P)="Num",P=P+3 Q:P>(BGPEC-2)
- S P=12 F S $P(BGPX,U,P)="Den",P=P+3 Q:P>(BGPEC-1)
- S P=13 F S $P(BGPX,U,P)="%",P=P+3 Q:P>BGPEC
- W BGPX,!
- S BGPX=0 F S BGPX=$O(BGPONN5(BGPX)) Q:BGPX'=+BGPX W BGPONN5(BGPX),!
- K BGPONN5
- ONNC D ^%ZISC ;close host file
- Q
- AGEDATE(BIAGRG,BISVDT,BIBEGDT,BIENDDT,BIERR) ;EP
- ;---> Given an Age Range in months or years and a Survey Date,
- ;---> return the beginning and ending dates in Fileman format.
- ;---> Use to search patients by DOB.
- ;---> Parameters:
- ; 1 - BIAGRG (req) Age Range^Mth/Yr (e.g.,50-64^1)
- ; (See description at linelable AGERNG above.)
- ; 2 - BISVDT (req) Survey/Forecast Date (date from which to
- ; calculate age).
- ; 3 - BIBEGDT (ret) Beginning Date.
- ; 4 - BIENDDT (ret) Ending Date.
- ; 5 - BIERR (ret) Error.
- ;
- ;---> Set begin and end dates for search through PATIENT File.
- I "ALL"[$G(BIAGRG) S BIBEGDT=0,BIENDDT=9999999 Q
- I '$G(BISVDT) S BISVDT=$G(DT)
- ;I '$G(BISVDT) S BIBEGDT=0,BIENDDT=9999999 Q
- ;S:BISVDT>DT BISVDT=DT
- ;
- ;---> If X=one age only, set it in the form X-X and quit.
- ;---> If Age Range is passed in years, convert to months.
- D
- .N Y S Y=$P(BIAGRG,U)
- .;---> If Y=one age only, set it in the form Y-Y.
- .I Y?1N.N S Y=Y_"-"_Y
- .I '$P(BIAGRG,U,2) S BIAGRG=Y Q
- .S BIAGRG=(12*$P(Y,"-"))_"-"_(12*$P(Y,"-",2)+11)
- ;
- N BIAGRG1,BIAGRG2
- S BIAGRG1=+$P(BIAGRG,"-",1),BIAGRG2=+$P(BIAGRG,"-",2)
- ;I (BIAGRG1'?1N.N)!(BIAGRG2'?1N.N) D ERRCD^BIUTL2(676,.BIERR) Q
- ;
- ;D PASTMTH(BISVDT,($P(BIAGRG,"-",2)+1),.BIBEGDT)
- D PASTMTH(BISVDT,(BIAGRG2+1),.BIBEGDT)
- ;
- ;---> Now, set Beginning Day to be one day AFTER the patient would
- ;---> be too old and out of the selected Age Range.
- ;---> In other words, come forward one day to include only patients
- ;---> whose age is ONE DAY LESS THAN a month (or year) after the
- ;---> maximum limit of the selected Age Range.
- ;---> For example, Age Range=24-36 includes patients whose age
- ;---> is between [24months] and [37months-1day].
- N X,X1,X2 S X1=BIBEGDT,X2=1 D C^%DTC S BIBEGDT=X
- ;
- ;D PASTMTH(BISVDT,$P(BIAGRG,"-",1),.BIENDDT)
- D PASTMTH(BISVDT,BIAGRG1,.BIENDDT)
- Q
- ;
- ;
- ;----------
- PASTMTH(BIDTI,BIMTHS,BIDTO,BIYR) ;EP
- ;---> Return the date BIMTHS months/years prior the input date.
- ;---> Parameters:
- ; 1 - BIDTI (req) Date in.
- ; 2 - BIMTHS (req) Number of months in the past to calculate.
- ; 3 - BIDTO (ret) Date out (BIMTHS prior to BIDTI).
- ; 4 - BIYR (opt) If BIYR=1, input is in years; multiply BIMTHSx12.
- ;
- Q:'$G(BIDTI)
- I '$G(BIMTHS) S BIDTO=BIDTI Q
- I $G(BIYR)=1 S BIMTHS=(BIMTHS*12)
- N YYY,MM,DD
- S YYY=$E(BIDTI,1,3),MM=+$E(BIDTI,4,5),DD=+$E(BIDTI,6,7)
- D
- .I MM>BIMTHS S MM=MM-BIMTHS Q
- .N I,Q S Q=0
- .F I=12:12 D Q:Q
- ..I BIMTHS-MM<I S MM=I-(BIMTHS-MM),YYY=YYY-(I/12),Q=1
- ;
- S:MM<10 MM="0"_MM
- S:DD<10 DD="0"_DD
- S BIDTO=YYY_MM_DD
- Q
- ;
- TESTDR ;
- TP ;
- W !!,"for testing purposes only, please enter DATE RANGE AND YEAR",!
- S (BGPBD,BGPED,BGPTP)=""
- S DIR(0)="S^1:January 1 - December 31;2:April 1 - March 31;3:July 1 - June 30;4:October 1 - September 30;5:User-Defined Report Period",DIR("A")="Enter the date range for your report" KILL DA D ^DIR KILL DIR
- I $D(DIRUT) Q
- S BGPQTR=Y
- I BGPQTR=5 D ENDDATE^BGP8DGPU
- I BGPQTR'=5 D F
- I BGPPER="" W !,"Year not entered.",! G TP
- I BGPQTR=1 S BGPBD=$E(BGPPER,1,3)_"0101",BGPED=$E(BGPPER,1,3)_"1231"
- I BGPQTR=2 S BGPBD=($E(BGPPER,1,3)-1)_"0401",BGPED=$E(BGPPER,1,3)_"0331"
- I BGPQTR=3 S BGPBD=($E(BGPPER,1,3)-1)_"0701",BGPED=$E(BGPPER,1,3)_"0630"
- I BGPQTR=4 S BGPBD=($E(BGPPER,1,3)-1)_"1001",BGPED=$E(BGPPER,1,3)_"0930"
- ;I BGPQTR=5 S D=$$FMADD^XLFDT(BGPPER,1) S BGPBD=($E(BGPPER,1,3)-1)_$E(D,4,7),BGPED=BGPPER,BGPPER=$E(BGPED,1,3)_"0000"
- I BGPQTR=5 D
- .S D=$$FMADD^XLFDT(BGPPER,1)
- .I $E(BGPPER,4,7)'=1231 S BGPBD=($E(BGPPER,1,3)-1)_$E(D,4,7),BGPED=BGPPER,BGPPER=$E(BGPED,1,3)_"0000"
- .I $E(BGPPER,4,7)=1231 S BGPBD=$E(BGPPER,1,3)_$E(D,4,7),BGPED=BGPPER,BGPPER=$E(BGPED,1,3)_"0000"
- I BGPED>DT D G:BGPDO=1 TP
- .W !!,"You have selected Current Report period ",$$FMTE^XLFDT(BGPBD)," through ",$$FMTE^XLFDT(BGPED),"."
- .W !,"The end date of this report is in the future; your data will not be",!,"complete.",!
- .K DIR S BGPDO=0 S DIR(0)="Y",DIR("A")="Do you want to change your Current Report Dates",DIR("B")="N" KILL DA D ^DIR KILL DIR
- .I $D(DIRUT) S BGPDO=1 Q
- .I Y S BGPDO=1 Q
- .Q
- BY ;get baseline year
- S BGPVDT=""
- W !!,"Enter the Baseline Year to compare data to.",!,"Use a 4 digit year, e.g. 2010"
- S DIR(0)="D^::EP"
- S DIR("A")="Enter Year (e.g. 2010)"
- D ^DIR KILL DIR
- I $D(DIRUT) G TP
- I $D(DUOUT) S DIRUT=1 G TP
- S BGPVDT=Y
- I $E(Y,4,7)'="0000" W !!,"Please enter a year only!",! G BY
- S X=$E(BGPPER,1,3)-$E(BGPVDT,1,3)
- S X=X_"0000"
- S BGPBBD=BGPBD-X,BGPBBD=$E(BGPBBD,1,3)_$E(BGPBD,4,7)
- S BGPBED=BGPED-X,BGPBED=$E(BGPBED,1,3)_$E(BGPED,4,7)
- S BGPPBD=($E(BGPBD,1,3)-1)_$E(BGPBD,4,7)
- S BGPPED=($E(BGPED,1,3)-1)_$E(BGPED,4,7)
- ;W !!,"The date ranges for this report are:"
- ;W !?5,"Report Period: ",?31,$$FMTE^XLFDT(BGPBD)," to ",?31,$$FMTE^XLFDT(BGPED)
- ;W !?5,"Previous Year Period: ",?31,$$FMTE^XLFDT(BGPPBD)," to ",?31,$$FMTE^XLFDT(BGPPED)
- ;W !?5,"Baseline Period: ",?31,$$FMTE^XLFDT(BGPBBD)," to ",?31,$$FMTE^XLFDT(BGPBED)
- I BGPPBD=BGPBBD,BGPPED=BGPBED K Y D CHKY^BGP8DL I Y K BGPBBD,BGPBED,BGPPBD,BGPPED G BY
- Q
- F ;calendar year
- S (BGPPER,BGPVDT)=""
- W !!,"Enter the Calendar Year for the report END date. Use a 4 digit",!,"year, e.g. 2018"
- S DIR(0)="D^::EP"
- S DIR("A")="Enter Year"
- S DIR("?")="This report is compiled for a period. Enter a valid date."
- D ^DIR KILL DIR
- I $D(DIRUT) Q
- I $D(DUOUT) S DIRUT=1 Q
- S BGPVDT=Y
- I $E(Y,4,7)'="0000" W !!,"Please enter a year only!",! G F
- S BGPPER=BGPVDT
- Q
- BGP8UTL3 ; IHS/CMI/LAB - UTILITIES ;
- +1 ;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66
- +2 ;
- ONN4 ;EP
- +1 KILL BGPEXCT
- +2 SET Y=$$OPEN^%ZISH(BGPUF,BGPFONN4,"W")
- +3 IF Y=1
- IF '$DATA(ZTQUEUED)
- WRITE !!,"Cannot open host file."
- QUIT
- +4 USE IO
- +5 SET BGPP=0
- SET BGPY=$ORDER(^BGPCTRL("B","2018",0))
- SET BGPX=""
- SET BGPEC=$PIECE(^BGPCTRL(BGPY,0),U,25)
- +6 FOR
- SET BGPP=$ORDER(^BGPCTRL(BGPY,86,BGPP))
- IF BGPP'=+BGPP
- QUIT
- Begin DoDot:1
- +7 SET BGPPP1=$PIECE(^BGPCTRL(BGPY,86,BGPP,0),U,1)
- +8 SET BGPZ=$PIECE(^BGPCTRL(BGPY,86,BGPP,0),U,2)
- +9 SET $PIECE(BGPX,U,BGPPP1)=BGPZ
- End DoDot:1
- +10 WRITE BGPX,!
- +11 KILL BGPX
- +12 SET BGPX=""
- SET P=11
- FOR
- SET $PIECE(BGPX,U,P)="Current"
- SET P=P+9
- IF P>(BGPEC-8)
- QUIT
- +13 SET P=14
- FOR
- SET $PIECE(BGPX,U,P)="Previous"
- SET P=P+9
- IF P>(BGPEC-5)
- QUIT
- +14 SET P=17
- FOR
- SET $PIECE(BGPX,U,P)="Baseline"
- SET P=P+9
- IF P>(BGPEC+1)
- QUIT
- +15 WRITE BGPX,!
- +16 KILL BGPX
- +17 DO SETHDR^BGP8UTL
- +18 SET P=11
- FOR
- SET $PIECE(BGPX,U,P)="Num"
- SET P=P+3
- IF P>(BGPEC-2)
- QUIT
- +19 SET P=12
- FOR
- SET $PIECE(BGPX,U,P)="Den"
- SET P=P+3
- IF P>(BGPEC-1)
- QUIT
- +20 SET P=13
- FOR
- SET $PIECE(BGPX,U,P)="%"
- SET P=P+3
- IF P>BGPEC
- QUIT
- +21 WRITE BGPX,!
- +22 SET BGPX=0
- FOR
- SET BGPX=$ORDER(BGPONN4(BGPX))
- IF BGPX'=+BGPX
- QUIT
- WRITE BGPONN4(BGPX),!
- +23 KILL BGPONN4
- +24 DO ^%ZISC
- +25 QUIT
- ONN5 ;
- +1 KILL BGPEXCT
- +2 SET Y=$$OPEN^%ZISH(BGPUF,BGPFONN5,"W")
- +3 IF Y=1
- IF '$DATA(ZTQUEUED)
- WRITE !!,"Cannot open host file."
- QUIT
- +4 USE IO
- +5 SET BGPP=0
- SET BGPY=$ORDER(^BGPCTRL("B","2018",0))
- SET BGPX=""
- SET BGPEC=$PIECE(^BGPCTRL(BGPY,0),U,26)
- +6 FOR
- SET BGPP=$ORDER(^BGPCTRL(BGPY,87,BGPP))
- IF BGPP'=+BGPP
- QUIT
- Begin DoDot:1
- +7 SET BGPPP1=$PIECE(^BGPCTRL(BGPY,87,BGPP,0),U,1)
- +8 SET BGPZ=$PIECE(^BGPCTRL(BGPY,87,BGPP,0),U,2)
- +9 SET $PIECE(BGPX,U,BGPPP1)=BGPZ
- End DoDot:1
- +10 WRITE BGPX,!
- +11 KILL BGPX
- +12 SET BGPX=""
- SET P=11
- FOR
- SET $PIECE(BGPX,U,P)="Current"
- SET P=P+9
- IF P>(BGPEC-8)
- QUIT
- +13 SET P=14
- FOR
- SET $PIECE(BGPX,U,P)="Previous"
- SET P=P+9
- IF P>(BGPEC-5)
- QUIT
- +14 SET P=17
- FOR
- SET $PIECE(BGPX,U,P)="Baseline"
- SET P=P+9
- IF P>(BGPEC+1)
- QUIT
- +15 WRITE BGPX,!
- +16 KILL BGPX
- +17 DO SETHDR^BGP8UTL
- +18 SET P=11
- FOR
- SET $PIECE(BGPX,U,P)="Num"
- SET P=P+3
- IF P>(BGPEC-2)
- QUIT
- +19 SET P=12
- FOR
- SET $PIECE(BGPX,U,P)="Den"
- SET P=P+3
- IF P>(BGPEC-1)
- QUIT
- +20 SET P=13
- FOR
- SET $PIECE(BGPX,U,P)="%"
- SET P=P+3
- IF P>BGPEC
- QUIT
- +21 WRITE BGPX,!
- +22 SET BGPX=0
- FOR
- SET BGPX=$ORDER(BGPONN5(BGPX))
- IF BGPX'=+BGPX
- QUIT
- WRITE BGPONN5(BGPX),!
- +23 KILL BGPONN5
- ONNC ;close host file
- DO ^%ZISC
- +1 QUIT
- AGEDATE(BIAGRG,BISVDT,BIBEGDT,BIENDDT,BIERR) ;EP
- +1 ;---> Given an Age Range in months or years and a Survey Date,
- +2 ;---> return the beginning and ending dates in Fileman format.
- +3 ;---> Use to search patients by DOB.
- +4 ;---> Parameters:
- +5 ; 1 - BIAGRG (req) Age Range^Mth/Yr (e.g.,50-64^1)
- +6 ; (See description at linelable AGERNG above.)
- +7 ; 2 - BISVDT (req) Survey/Forecast Date (date from which to
- +8 ; calculate age).
- +9 ; 3 - BIBEGDT (ret) Beginning Date.
- +10 ; 4 - BIENDDT (ret) Ending Date.
- +11 ; 5 - BIERR (ret) Error.
- +12 ;
- +13 ;---> Set begin and end dates for search through PATIENT File.
- +14 IF "ALL"[$GET(BIAGRG)
- SET BIBEGDT=0
- SET BIENDDT=9999999
- QUIT
- +15 IF '$GET(BISVDT)
- SET BISVDT=$GET(DT)
- +16 ;I '$G(BISVDT) S BIBEGDT=0,BIENDDT=9999999 Q
- +17 ;S:BISVDT>DT BISVDT=DT
- +18 ;
- +19 ;---> If X=one age only, set it in the form X-X and quit.
- +20 ;---> If Age Range is passed in years, convert to months.
- +21 Begin DoDot:1
- +22 NEW Y
- SET Y=$PIECE(BIAGRG,U)
- +23 ;---> If Y=one age only, set it in the form Y-Y.
- +24 IF Y?1N.N
- SET Y=Y_"-"_Y
- +25 IF '$PIECE(BIAGRG,U,2)
- SET BIAGRG=Y
- QUIT
- +26 SET BIAGRG=(12*$PIECE(Y,"-"))_"-"_(12*$PIECE(Y,"-",2)+11)
- End DoDot:1
- +27 ;
- +28 NEW BIAGRG1,BIAGRG2
- +29 SET BIAGRG1=+$PIECE(BIAGRG,"-",1)
- SET BIAGRG2=+$PIECE(BIAGRG,"-",2)
- +30 ;I (BIAGRG1'?1N.N)!(BIAGRG2'?1N.N) D ERRCD^BIUTL2(676,.BIERR) Q
- +31 ;
- +32 ;D PASTMTH(BISVDT,($P(BIAGRG,"-",2)+1),.BIBEGDT)
- +33 DO PASTMTH(BISVDT,(BIAGRG2+1),.BIBEGDT)
- +34 ;
- +35 ;---> Now, set Beginning Day to be one day AFTER the patient would
- +36 ;---> be too old and out of the selected Age Range.
- +37 ;---> In other words, come forward one day to include only patients
- +38 ;---> whose age is ONE DAY LESS THAN a month (or year) after the
- +39 ;---> maximum limit of the selected Age Range.
- +40 ;---> For example, Age Range=24-36 includes patients whose age
- +41 ;---> is between [24months] and [37months-1day].
- +42 NEW X,X1,X2
- SET X1=BIBEGDT
- SET X2=1
- DO C^%DTC
- SET BIBEGDT=X
- +43 ;
- +44 ;D PASTMTH(BISVDT,$P(BIAGRG,"-",1),.BIENDDT)
- +45 DO PASTMTH(BISVDT,BIAGRG1,.BIENDDT)
- +46 QUIT
- +47 ;
- +48 ;
- +49 ;----------
- PASTMTH(BIDTI,BIMTHS,BIDTO,BIYR) ;EP
- +1 ;---> Return the date BIMTHS months/years prior the input date.
- +2 ;---> Parameters:
- +3 ; 1 - BIDTI (req) Date in.
- +4 ; 2 - BIMTHS (req) Number of months in the past to calculate.
- +5 ; 3 - BIDTO (ret) Date out (BIMTHS prior to BIDTI).
- +6 ; 4 - BIYR (opt) If BIYR=1, input is in years; multiply BIMTHSx12.
- +7 ;
- +8 IF '$GET(BIDTI)
- QUIT
- +9 IF '$GET(BIMTHS)
- SET BIDTO=BIDTI
- QUIT
- +10 IF $GET(BIYR)=1
- SET BIMTHS=(BIMTHS*12)
- +11 NEW YYY,MM,DD
- +12 SET YYY=$EXTRACT(BIDTI,1,3)
- SET MM=+$EXTRACT(BIDTI,4,5)
- SET DD=+$EXTRACT(BIDTI,6,7)
- +13 Begin DoDot:1
- +14 IF MM>BIMTHS
- SET MM=MM-BIMTHS
- QUIT
- +15 NEW I,Q
- SET Q=0
- +16 FOR I=12:12
- Begin DoDot:2
- +17 IF BIMTHS-MM<I
- SET MM=I-(BIMTHS-MM)
- SET YYY=YYY-(I/12)
- SET Q=1
- End DoDot:2
- IF Q
- QUIT
- End DoDot:1
- +18 ;
- +19 IF MM<10
- SET MM="0"_MM
- +20 IF DD<10
- SET DD="0"_DD
- +21 SET BIDTO=YYY_MM_DD
- +22 QUIT
- +23 ;
- TESTDR ;
- TP ;
- +1 WRITE !!,"for testing purposes only, please enter DATE RANGE AND YEAR",!
- +2 SET (BGPBD,BGPED,BGPTP)=""
- +3 SET DIR(0)="S^1:January 1 - December 31;2:April 1 - March 31;3:July 1 - June 30;4:October 1 - September 30;5:User-Defined Report Period"
- SET DIR("A")="Enter the date range for your report"
- KILL DA
- DO ^DIR
- KILL DIR
- +4 IF $DATA(DIRUT)
- QUIT
- +5 SET BGPQTR=Y
- +6 IF BGPQTR=5
- DO ENDDATE^BGP8DGPU
- +7 IF BGPQTR'=5
- DO F
- +8 IF BGPPER=""
- WRITE !,"Year not entered.",!
- GOTO TP
- +9 IF BGPQTR=1
- SET BGPBD=$EXTRACT(BGPPER,1,3)_"0101"
- SET BGPED=$EXTRACT(BGPPER,1,3)_"1231"
- +10 IF BGPQTR=2
- SET BGPBD=($EXTRACT(BGPPER,1,3)-1)_"0401"
- SET BGPED=$EXTRACT(BGPPER,1,3)_"0331"
- +11 IF BGPQTR=3
- SET BGPBD=($EXTRACT(BGPPER,1,3)-1)_"0701"
- SET BGPED=$EXTRACT(BGPPER,1,3)_"0630"
- +12 IF BGPQTR=4
- SET BGPBD=($EXTRACT(BGPPER,1,3)-1)_"1001"
- SET BGPED=$EXTRACT(BGPPER,1,3)_"0930"
- +13 ;I BGPQTR=5 S D=$$FMADD^XLFDT(BGPPER,1) S BGPBD=($E(BGPPER,1,3)-1)_$E(D,4,7),BGPED=BGPPER,BGPPER=$E(BGPED,1,3)_"0000"
- +14 IF BGPQTR=5
- Begin DoDot:1
- +15 SET D=$$FMADD^XLFDT(BGPPER,1)
- +16 IF $EXTRACT(BGPPER,4,7)'=1231
- SET BGPBD=($EXTRACT(BGPPER,1,3)-1)_$EXTRACT(D,4,7)
- SET BGPED=BGPPER
- SET BGPPER=$EXTRACT(BGPED,1,3)_"0000"
- +17 IF $EXTRACT(BGPPER,4,7)=1231
- SET BGPBD=$EXTRACT(BGPPER,1,3)_$EXTRACT(D,4,7)
- SET BGPED=BGPPER
- SET BGPPER=$EXTRACT(BGPED,1,3)_"0000"
- End DoDot:1
- +18 IF BGPED>DT
- Begin DoDot:1
- +19 WRITE !!,"You have selected Current Report period ",$$FMTE^XLFDT(BGPBD)," through ",$$FMTE^XLFDT(BGPED),"."
- +20 WRITE !,"The end date of this report is in the future; your data will not be",!,"complete.",!
- +21 KILL DIR
- SET BGPDO=0
- SET DIR(0)="Y"
- SET DIR("A")="Do you want to change your Current Report Dates"
- SET DIR("B")="N"
- KILL DA
- DO ^DIR
- KILL DIR
- +22 IF $DATA(DIRUT)
- SET BGPDO=1
- QUIT
- +23 IF Y
- SET BGPDO=1
- QUIT
- +24 QUIT
- End DoDot:1
- IF BGPDO=1
- GOTO TP
- BY ;get baseline year
- +1 SET BGPVDT=""
- +2 WRITE !!,"Enter the Baseline Year to compare data to.",!,"Use a 4 digit year, e.g. 2010"
- +3 SET DIR(0)="D^::EP"
- +4 SET DIR("A")="Enter Year (e.g. 2010)"
- +5 DO ^DIR
- KILL DIR
- +6 IF $DATA(DIRUT)
- GOTO TP
- +7 IF $DATA(DUOUT)
- SET DIRUT=1
- GOTO TP
- +8 SET BGPVDT=Y
- +9 IF $EXTRACT(Y,4,7)'="0000"
- WRITE !!,"Please enter a year only!",!
- GOTO BY
- +10 SET X=$EXTRACT(BGPPER,1,3)-$EXTRACT(BGPVDT,1,3)
- +11 SET X=X_"0000"
- +12 SET BGPBBD=BGPBD-X
- SET BGPBBD=$EXTRACT(BGPBBD,1,3)_$EXTRACT(BGPBD,4,7)
- +13 SET BGPBED=BGPED-X
- SET BGPBED=$EXTRACT(BGPBED,1,3)_$EXTRACT(BGPED,4,7)
- +14 SET BGPPBD=($EXTRACT(BGPBD,1,3)-1)_$EXTRACT(BGPBD,4,7)
- +15 SET BGPPED=($EXTRACT(BGPED,1,3)-1)_$EXTRACT(BGPED,4,7)
- +16 ;W !!,"The date ranges for this report are:"
- +17 ;W !?5,"Report Period: ",?31,$$FMTE^XLFDT(BGPBD)," to ",?31,$$FMTE^XLFDT(BGPED)
- +18 ;W !?5,"Previous Year Period: ",?31,$$FMTE^XLFDT(BGPPBD)," to ",?31,$$FMTE^XLFDT(BGPPED)
- +19 ;W !?5,"Baseline Period: ",?31,$$FMTE^XLFDT(BGPBBD)," to ",?31,$$FMTE^XLFDT(BGPBED)
- +20 IF BGPPBD=BGPBBD
- IF BGPPED=BGPBED
- KILL Y
- DO CHKY^BGP8DL
- IF Y
- KILL BGPBBD,BGPBED,BGPPBD,BGPPED
- GOTO BY
- +21 QUIT
- F ;calendar year
- +1 SET (BGPPER,BGPVDT)=""
- +2 WRITE !!,"Enter the Calendar Year for the report END date. Use a 4 digit",!,"year, e.g. 2018"
- +3 SET DIR(0)="D^::EP"
- +4 SET DIR("A")="Enter Year"
- +5 SET DIR("?")="This report is compiled for a period. Enter a valid date."
- +6 DO ^DIR
- KILL DIR
- +7 IF $DATA(DIRUT)
- QUIT
- +8 IF $DATA(DUOUT)
- SET DIRUT=1
- QUIT
- +9 SET BGPVDT=Y
- +10 IF $EXTRACT(Y,4,7)'="0000"
- WRITE !!,"Please enter a year only!",!
- GOTO F
- +11 SET BGPPER=BGPVDT
- +12 QUIT