Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BGP8UTL3

BGP8UTL3.m

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