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

BGP6UTL3.m

Go to the documentation of this file. 
  1. BGP6UTL3 ; IHS/CMI/LAB - 27 Apr 2009 11:01 PM 30 Aug 2009 10:16 AM 30 Jun 2010 4:58 PM 05 Aug 2016 11:40 AM 26 Mar 2016 2:40 PM ;
  1.  ;;16.1;IHS CLINICAL REPORTING;;MAR 22, 2016;Build 170
  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","2016",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^BGP6UTL
  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","2016",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^BGP6UTL
  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.  ;