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

BKMSTID1.m

Go to the documentation of this file. 
  1. BKMSTID1 ;PRXM/HC/ALA-STI Display ; 20 Mar 2007  2:23 PM
  1.  ;;2.1;HIV MANAGEMENT SYSTEM;;Feb 07, 2011
  1.  ;
  1. EN(BKMDFN,RPSDT,RPEDT,BKTYPE,BKARRAY,BKSTIY) ;
  1.  ; Input parameters
  1.  ;   BKMDFN  - Patient internal entry number
  1.  ;   RPSDT   - Report start date in FileMan date format
  1.  ;   RPEDT   - Report end date in FileMan date format
  1.  ;   BKTYPE  - Type of STI data, defaults to 'Key'
  1.  ;   BKARRAY - Array to return raw data
  1.  ;   BKSTIY  - Array to return data by totals
  1.  ;
  1.  NEW DIR,Y,X,DTOUT,DUOUT,DFN,SEX,SSN,PTNAME,AGE,AUPNDAYS,AUPNDOB
  1.  NEW AUPNPAT,AUPNDOD,AUPNSEX,SIEN,STINM,STI,NIN,DDATA,RSTI,NSTI,RSTINM
  1.  NEW RSTNM,RSIEN,NSIEN,NRSCR,HVDFL,BKTYPE,NCT,NSCR,RFL,SCREEN,LR,NTSCR,QFL,SSCREEN
  1.  NEW TOT,BKIN,BKN,HSCR,POP,INC,SDAT,STYP,BKBDT,BKEDT,CT,BKMARRAY
  1.  NEW TOTIN,INCD,INCS
  1.  ;
  1.  S BKTYPE=$G(BKTYPE,"KEY"),HVDFL=0,AUPNPAT=BKMDFN
  1.  K BKARRAY,BKSTIN,BKSTIY S QFL=0
  1.  S BKBDT=$$FMADD^XLFDT(RPSDT,-60),BKEDT=$$FMADD^XLFDT(RPSDT,300)
  1.  D EN^BKMSTI(AUPNPAT,BKBDT,BKEDT,BKTYPE,.BKARRAY,.HVDFL)
  1.  I '$D(BKARRAY) S BKSTIY(0)=0 Q
  1.  I $D(BKARRAY) D
  1.  . NEW STI
  1.  . S STI=""
  1.  . F  S STI=$O(BKARRAY(STI)) Q:STI=""  D  Q:QFL
  1.  .. I $G(BKARRAY(STI,"DEN"))'=0 S QFL=1 Q
  1.  I 'QFL K BKARRAY S BKSTIY(0)=0 Q
  1.  D INC
  1.  ;  clean up extras values not needed
  1.  S INC=0
  1.  F  S INC=$O(BKSTIN(INC)) Q:INC=""  D
  1.  . S STYP=""
  1.  . F  S STYP=$O(BKSTIN(INC,STYP)) Q:STYP=""  D
  1.  .. S SDAT="",CT=0
  1.  .. F  S SDAT=$O(BKSTIN(INC,STYP,SDAT)) Q:SDAT=""  D
  1.  ... S CT=CT+1
  1.  ... I CT>1 K BKSTIN(INC,STYP,SDAT)
  1.  ;
  1.  S INC=0
  1.  F  S INC=$O(BKSTIN(INC)) Q:INC=""  D
  1.  . K REC,NBREC,NREC
  1.  . S TOTIN=0
  1.  . S TYP="" F  S TYP=$O(BKSTIN(INC,TYP)) Q:TYP=""  D
  1.  .. S DAT=""
  1.  .. F  S DAT=$O(BKSTIN(INC,TYP,DAT)) Q:DAT=""  D
  1.  ... S RC=""
  1.  ... F  S RC=$O(BKARRAY(TYP,"NUM",RC)) Q:RC=""  D
  1.  .... I +$G(BKSTIN(INC,TYP,DAT,RC))=0 D
  1.  ..... I $D(BKSTIN(INC,RC)) Q
  1.  ..... I HVDFL,RC="HIV" Q
  1.  ..... S BKSTIN(INC,TYP,DAT,RC)=$G(BKARRAY(TYP,"NUM",RC,DAT))
  1.  ..... ;S:BKSTIN(INC,TYP,DAT,RC)="" BKSTIN(INC,TYP,DAT,RC)=0
  1.  ... ;
  1.  ... S RC=""
  1.  ... F  S RC=$O(BKARRAY(TYP,"REF",RC)) Q:RC=""  D
  1.  .... I +$G(BKSTIN(INC,TYP,DAT,RC))=0 D
  1.  ..... I $D(BKSTIN(INC,RC)) Q
  1.  ..... I HVDFL,RC="HIV" Q
  1.  ..... S BKSTIN(INC,TYP,DAT,RC)=$S($G(BKARRAY(TYP,"REF",RC,DAT))="":0,1:1_U_$G(BKARRAY(TYP,"REF",RC,DAT)))
  1.  ..... I $G(BKARRAY(TYP,"REF",RC,DAT))'="" S REF(BKARRAY(TYP,"REF",RC,DAT))=""
  1.  ..... ;S:BKSTIN(INC,TYP,DAT,RC)="" BKSTIN(INC,TYP,DAT,RC)=0
  1.  ;
  1.  S INC=0
  1.  F  S INC=$O(BKSTIN(INC)) Q:INC=""  D
  1.  . S TYP="" F  S TYP=$O(BKSTIN(INC,TYP)) Q:TYP=""  D
  1.  .. S $P(BKSTIY(INC,0),U,1)=$P($G(BKSTIY(INC,0)),U,1)+1
  1.  .. S DAT="" F  S DAT=$O(BKSTIN(INC,TYP,DAT)) Q:DAT=""  D
  1.  ... S INCD=$$FMTE^XLFDT(DAT,"2Z")_" "_BKSTIN(INC,TYP,DAT)
  1.  ... S $P(BKSTIY(INC,TYP,0),U,1)=$P($G(BKSTIY(INC,TYP,0)),U,1)+1
  1.  ... S $P(BKSTIY(INC,TYP,0),U,5)=INCD
  1.  ... ;S $P(BKSTIY(INC,0),U,5)=$P(BKSTIY(INC,0),U,5)_INCD_"; "
  1.  ... S RC="" F  S RC=$O(BKSTIN(INC,TYP,DAT,RC)) Q:RC=""  D
  1.  .... S BKSTIY("Z",INC,RC,DAT)=BKSTIN(INC,TYP,DAT,RC)
  1.  .... Q
  1.  ;
  1.  K NS,SD,RF
  1.  S INC=0
  1.  F  S INC=$O(BKSTIY(INC)) Q:INC=""  D
  1.  . S RC=""
  1.  . F  S RC=$O(BKSTIY("Z",INC,RC)) Q:RC=""  D
  1.  .. S DAT=""
  1.  .. F  S DAT=$O(BKSTIY("Z",INC,RC,DAT)) Q:DAT=""  D
  1.  ... S NS(INC,RC)=$G(NS(INC,RC))+1
  1.  ... I $P(BKSTIY("Z",INC,RC,DAT),U,1)=1 S SD(INC,RC)=$G(SD(INC,RC))+1,INCD(INC,RC)=$G(INCD(INC,RC))_$P(BKSTIY("Z",INC,RC,DAT),U,2)_"; "
  1.  ... I $P(BKSTIY("Z",INC,RC,DAT),U,2)["REF " S RF(INC,RC)=$G(RF(INC,RC))+1
  1.  ... S:$G(SD(INC,RC))="" SD(INC,RC)=0
  1.  ... S:$G(RF(INC,RC))="" RF(INC,RC)=0
  1.  ;
  1.  K BKSTIY("Z")
  1.  ;
  1.  S INC=0
  1.  F  S INC=$O(NS(INC)) Q:INC=""  D
  1.  . S RC=""
  1.  . F  S RC=$O(NS(INC,RC)) Q:RC=""  D
  1.  .. S $P(BKSTIY(INC,RC),U,1)=NS(INC,RC)
  1.  ;
  1.  S INC=0
  1.  F  S INC=$O(SD(INC)) Q:INC=""  D
  1.  . S RC=""
  1.  . F  S RC=$O(SD(INC,RC)) Q:RC=""  D
  1.  .. S $P(BKSTIY(INC,RC),U,2)=SD(INC,RC)
  1.  ;
  1.  S INC=0
  1.  F  S INC=$O(RF(INC)) Q:INC=""  D
  1.  . S RC=""
  1.  . F  S RC=$O(RF(INC,RC)) Q:RC=""  D
  1.  .. S $P(BKSTIY(INC,RC),U,3)=RF(INC,RC)
  1.  ;
  1.  S INC=0
  1.  F  S INC=$O(INCD(INC)) Q:INC=""  D
  1.  . S RC=""
  1.  . F  S RC=$O(INCD(INC,RC)) Q:RC=""  D
  1.  .. S $P(BKSTIY(INC,RC),U,4)=INCD(INC,RC)
  1.  ;
  1.  S TOTIN=0,TOTNS=0,TOTSD=0,TOTRF=0
  1.  S INC=0
  1.  F  S INC=$O(BKSTIY(INC)) Q:INC=""  D
  1.  . S TOTIN=TOTIN+$P(BKSTIY(INC,0),U,1)
  1.  . S TYP=0 F  S TYP=$O(BKSTIY(INC,TYP)) Q:TYP=""  D
  1.  .. I $G(BKSTIY(INC,TYP,0))'="" Q
  1.  .. ;F TI=1:1:3 S:$P(BKSTIY(INC,TYP),U,TI)="" $P(BKSTIY(INC,TYP),U,TI)=0
  1.  .. S TOTNS=TOTNS+$P(BKSTIY(INC,TYP),U,1)
  1.  .. S TOTSD=TOTSD+$P(BKSTIY(INC,TYP),U,2)
  1.  .. S TOTRF=TOTRF+$P(BKSTIY(INC,TYP),U,3)
  1.  ;
  1.  S BKSTIY(0)=TOTIN_U_TOTNS_U_TOTSD_U_TOTRF
  1.  K BKARRAY,BKSTIN
  1.  Q
  1.  ;
  1. INC ;EP - Determine multiple incidences
  1.  NEW TYP,DAT,INC,PDAT,NXDT,NTYP,DTDIF
  1.  K MBKARAY,BKSTIN
  1.  S TYP=""
  1.  F  S TYP=$O(BKARRAY(TYP)) Q:TYP=""  D
  1.  . S DAT=""
  1.  . F  S DAT=$O(BKARRAY(TYP,"DEN",DAT)) Q:DAT=""  D
  1.  .. S MBKARAY(DAT,TYP)=BKARRAY(TYP,"DEN",DAT)
  1.  S INC=0,DAT="",PDAT=""
  1.  F  S DAT=$O(MBKARAY(DAT)) Q:DAT=""  D
  1.  . S INC=INC+1 D SDT(DAT) K MBKARAY(DAT)
  1.  . S DTDIF=$$FMADD^XLFDT(DAT,60)
  1.  . S NXDT=DAT F  S NXDT=$O(MBKARAY(NXDT)) Q:NXDT=""  D
  1.  .. I NXDT<DTDIF D
  1.  ... D SDT(NXDT)
  1.  ... K MBKARAY(NXDT)
  1.  Q
  1.  ;
  1. SDT(VDT) ;EP - Same date, multiple types
  1.  S TYP=""
  1.  F  S TYP=$O(MBKARAY(VDT,TYP)) Q:TYP=""  D
  1.  . S BKSTIN(INC,TYP,VDT)=MBKARAY(VDT,TYP)
  1.  Q