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

BKMSTIDS.m

Go to the documentation of this file. 
  1. BKMSTIDS ;VNGT/HS/ALA-STI Incidences ; 20 Jun 2011  4:41 PM
  1.  ;;2.2;HIV MANAGEMENT SYSTEM;**1**;Apr 01, 2015;Build 17
  1.  ;
  1. EN(BKMDFN,RPSDT,RPEDT,BKTYPE,BKARRAY,BKSTIY,MUL) ; PEP
  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.  ;   MUL     - Multiple HIV events okay if 1 (default is 0 or no)
  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
  1.  NEW TOT,BKIN,BKN,HSCR,POP,INC,SDAT,STYP,BKBDT,BKEDT,CT,BKMARRAY,BSN
  1.  NEW TOTIN,INCD,INCS,TOTNS,TOTRF,TOTSD,RC,TVALN,QFL,SSCREEN,BKSTY,BN
  1.  NEW ZARRAY,NDEN,NNUM,TOTGD,TOTGN,FLAG,COLDTM,CPT,DAT,PRNM,TXN,TYP,NREF,TOTGR
  1.  NEW HNUM,IHVDFL,NKREF,RDT,RF,NKNUM,NKSTY,MTYP
  1.  ;
  1.  S BKTYPE=$G(BKTYPE,"KEY"),HVDFL=0,AUPNPAT=BKMDFN,MUL=$G(MUL,0)
  1.  K BKARRAY,BKSTIN,BKSTIY S QFL=0
  1.  ;S BKBDT=$$FMADD^XLFDT(RPSDT,-60),BKEDT=$$FMADD^XLFDT(RPSDT,300)
  1.  S BKBDT=$$FMADD^XLFDT(RPSDT,-(30.4167*2)),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,HNUM=0
  1.  F  S INC=$O(BKSTIN(INC)) Q:INC=""  D
  1.  . S STYP="",NDEN(INC)=0,NNUM(INC)=0,QFL=0
  1.  . F  S STYP=$O(BKSTIN(INC,STYP)) Q:STYP=""  D
  1.  .. I STYP="HIV" S HNUM=HNUM+1
  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.  ... I 'MUL,HNUM>1,STYP="HIV" K BKSTIN(INC,STYP,SDAT)
  1.  ;
  1. CMP ; Compile raw data
  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 BKN=$O(^BKM(90454,"D",TYP,""))
  1.  ... S BKSTIY(INC,TYP,0)=1_"^^^^"_$$FMTE^XLFDT(DAT,"2Z")_" "_BKSTIN(INC,TYP,DAT),TOTIN=TOTIN+1
  1.  ... S BN=0
  1.  ... F  S BN=$O(^BKM(90454,BKN,10,BN)) Q:'BN  D
  1.  .... S BSN=$P(^BKM(90454,BKN,10,BN,0),"^",1)
  1.  .... S BKSTY=$P(^BKM(90454,BSN,0),"^",3),HVDFL=0
  1.  .... I $D(BKSTIY(INC,BKSTY))>0 Q
  1.  .... I $D(BKSTIN(INC,BKSTY))>0 Q
  1.  .... I BKSTY="HIV" D
  1.  ..... NEW HKDATE,HEDATE,HSRDT
  1.  ..... S HKDATE="",HEDATE=DAT
  1.  ..... S HVDFL=$$HIVS^BKMRMDR(.BKMDFN,.HKDATE,.HEDATE)
  1.  ..... I +HVDFL=1 D
  1.  ...... I HVDFL["POV" S BKSTIY(INC,BKSTY)="0^0^^"_$P(HVDFL,U,2),IHVDFL=1 Q
  1.  ...... S HSRDT=$$FMADD^XLFDT(BKBDT,-(30.4167*1))
  1.  ...... I $P(HVDFL,U,3)<HSRDT D
  1.  ....... I $G(BKARRAY(TYP,"NUM",BKSTY,DAT))="" S BKSTIY(INC,BKSTY)="1^0^^" Q
  1.  ....... S BKSTIY(INC,BKSTY)=$G(BKARRAY(TYP,"NUM",BKSTY,DAT))
  1.  ...... S BKSTIY(INC,BKSTY)="1^1^^"_$P(HVDFL,U,2)
  1.  ..... ;I +HVDFL=1 S IHVDFL=1 Q
  1.  ..... I +HVDFL=0 S BKSTIY(INC,BKSTY)=$G(BKARRAY(TYP,"NUM",BKSTY,DAT))
  1.  .... I +HVDFL=1 Q
  1.  .... S BKSTIY(INC,BKSTY)=1
  1.  .... I $G(BKARRAY(TYP,"NUM",BKSTY,DAT))'="" D
  1.  ..... S $P(BKSTIY(INC,BKSTY),"^",2)=1
  1.  ..... S $P(BKSTIY(INC,BKSTY),"^",4)=$P(BKARRAY(TYP,"NUM",BKSTY,DAT),"^",2)
  1.  .... I $G(BKARRAY(TYP,"REF",BKSTY,DAT))'="" D
  1.  ..... ;S $P(BKSTIY(INC,BKSTY),"^",2)=1
  1.  ..... S $P(BKSTIY(INC,BKSTY),"^",3)=1
  1.  ..... I $G(BKARRAY(TYP,"NUM",BKSTY,DAT))="" S $P(BKSTIY(INC,BKSTY),"^",4)=$P(BKARRAY(TYP,"REF",BKSTY,DAT),"^",1)
  1.  ..... I $G(BKARRAY(TYP,"NUM",BKSTY,DAT))'="" S $P(BKSTIY(INC,BKSTY),"^",3)=0
  1.  .. D NG(INC,TYP)
  1.  . S BKSTIY(INC,0)=TOTIN
  1.  ;
  1.  S TOTIN=0,TOTNS=0,TOTSD=0,TOTRF=0,TOTGD=0,TOTGN=0,TOTGR=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 TOTGD=TOTGD+NDEN(INC),TOTGN=TOTGN+NNUM(INC)
  1.  . S TOTGD=TOTGD+1,TOTGN=TOTGN+NNUM(INC),TOTGR=TOTGR+NREF(INC)
  1.  . S TYP=0 F  S TYP=$O(BKSTIY(INC,TYP)) Q:TYP=""  D
  1.  .. I $G(BKSTIY(INC,TYP,0))'="" Q
  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_U_TOTGD_U_TOTGN_U_TOTGR
  1.  K BKSTIN
  1.  ;TOTIN = Total number of incidences
  1.  ;TOTNS = Total number of screenings needed
  1.  ;TOTSD = Total number of screenings done
  1.  ;TOTRF = Total number of refusals
  1.  ;TOTGD = Total number of 'grouped' denominators
  1.  ;TOTGN = Total number of 'grouped' numerators
  1.  ;TOTGR = Total number of 'grouped' refusals
  1.  Q
  1.  ;
  1. INC ;EP - Determine multiple incidences
  1.  NEW TYP,DAT,INC,PDAT,NXDT,NTYP,DTDIF,NM
  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 NNUM=0,NM=""
  1.  .. F  S NM=$O(BKARRAY(TYP,"NUM",NM)) Q:NM=""  I $G(BKARRAY(TYP,"NUM",NM))'=0 S NNUM=NNUM+1
  1.  .. S ZARRAY("ZN",DAT,TYP)=NNUM
  1.  .. S RF=""
  1.  .. F  S RF=$O(BKARRAY(TYP,"REF",RF)) Q:RF=""  S RDT="" F  S RDT=$O(BKARRAY(TYP,"REF",RF,RDT)) Q:RDT=""  S ZARRAY("ZR",RDT,RF)=0
  1.  ;
  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 DTDIF=$$FMADD^XLFDT(DAT,(30.4167*2))
  1.  . S NXDT=DAT F  S NXDT=$O(MBKARAY(NXDT)) Q:NXDT=""  D
  1.  .. I NXDT<DTDIF D
  1.  ... S MTYP=$O(BKSTIN(INC,""))
  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.  . I $G(MTYP)'="",MTYP=TYP Q
  1.  . I $G(MTYP)'="",MTYP'=TYP S INC=INC+1
  1.  . S BKSTIN(INC,TYP,VDT)=MBKARAY(VDT,TYP)
  1.  Q
  1.  ;
  1. NG(NIN,NTYP) ;
  1.  NEW BKN,BN,BSN,NKSTY,NKNUM,NKREF
  1.  S BKN=$O(^BKM(90454,"D",NTYP,""))
  1.  S BN=0,NKNUM=0,NKREF=0
  1.  I $G(IHVDFL)=1 S NKNUM=1
  1.  F  S BN=$O(^BKM(90454,BKN,10,BN)) Q:'BN  D
  1.  . S BSN=$P(^BKM(90454,BKN,10,BN,0),"^",1)
  1.  . S NKSTY=$P(^BKM(90454,BSN,0),"^",3)
  1.  . S NKNUM=$P($G(BKSTIY(NIN,NKSTY)),"^",2)+NKNUM
  1.  . S NKREF=$P($G(BKSTIY(NIN,NKSTY)),"^",3)+NKREF
  1.  S NNUM(NIN)=$S(NKNUM=3:1,1:0)
  1.  S NREF(NIN)=$S(NKREF>0&((NKREF+NKNUM)=3):1,1:0)
  1.  Q