BKMSTID1 ;PRXM/HC/ALA-STI Display ; 20 Mar 2007 2:23 PM
;;2.1;HIV MANAGEMENT SYSTEM;;Feb 07, 2011
;
EN(BKMDFN,RPSDT,RPEDT,BKTYPE,BKARRAY,BKSTIY) ;
; Input parameters
; BKMDFN - Patient internal entry number
; RPSDT - Report start date in FileMan date format
; RPEDT - Report end date in FileMan date format
; BKTYPE - Type of STI data, defaults to 'Key'
; BKARRAY - Array to return raw data
; BKSTIY - Array to return data by totals
;
NEW DIR,Y,X,DTOUT,DUOUT,DFN,SEX,SSN,PTNAME,AGE,AUPNDAYS,AUPNDOB
NEW AUPNPAT,AUPNDOD,AUPNSEX,SIEN,STINM,STI,NIN,DDATA,RSTI,NSTI,RSTINM
NEW RSTNM,RSIEN,NSIEN,NRSCR,HVDFL,BKTYPE,NCT,NSCR,RFL,SCREEN,LR,NTSCR,QFL,SSCREEN
NEW TOT,BKIN,BKN,HSCR,POP,INC,SDAT,STYP,BKBDT,BKEDT,CT,BKMARRAY
NEW TOTIN,INCD,INCS
;
S BKTYPE=$G(BKTYPE,"KEY"),HVDFL=0,AUPNPAT=BKMDFN
K BKARRAY,BKSTIN,BKSTIY S QFL=0
S BKBDT=$$FMADD^XLFDT(RPSDT,-60),BKEDT=$$FMADD^XLFDT(RPSDT,300)
D EN^BKMSTI(AUPNPAT,BKBDT,BKEDT,BKTYPE,.BKARRAY,.HVDFL)
I '$D(BKARRAY) S BKSTIY(0)=0 Q
I $D(BKARRAY) D
. NEW STI
. S STI=""
. F S STI=$O(BKARRAY(STI)) Q:STI="" D Q:QFL
.. I $G(BKARRAY(STI,"DEN"))'=0 S QFL=1 Q
I 'QFL K BKARRAY S BKSTIY(0)=0 Q
D INC
; clean up extras values not needed
S INC=0
F S INC=$O(BKSTIN(INC)) Q:INC="" D
. S STYP=""
. F S STYP=$O(BKSTIN(INC,STYP)) Q:STYP="" D
.. S SDAT="",CT=0
.. F S SDAT=$O(BKSTIN(INC,STYP,SDAT)) Q:SDAT="" D
... S CT=CT+1
... I CT>1 K BKSTIN(INC,STYP,SDAT)
;
S INC=0
F S INC=$O(BKSTIN(INC)) Q:INC="" D
. K REC,NBREC,NREC
. S TOTIN=0
. S TYP="" F S TYP=$O(BKSTIN(INC,TYP)) Q:TYP="" D
.. S DAT=""
.. F S DAT=$O(BKSTIN(INC,TYP,DAT)) Q:DAT="" D
... S RC=""
... F S RC=$O(BKARRAY(TYP,"NUM",RC)) Q:RC="" D
.... I +$G(BKSTIN(INC,TYP,DAT,RC))=0 D
..... I $D(BKSTIN(INC,RC)) Q
..... I HVDFL,RC="HIV" Q
..... S BKSTIN(INC,TYP,DAT,RC)=$G(BKARRAY(TYP,"NUM",RC,DAT))
..... ;S:BKSTIN(INC,TYP,DAT,RC)="" BKSTIN(INC,TYP,DAT,RC)=0
... ;
... S RC=""
... F S RC=$O(BKARRAY(TYP,"REF",RC)) Q:RC="" D
.... I +$G(BKSTIN(INC,TYP,DAT,RC))=0 D
..... I $D(BKSTIN(INC,RC)) Q
..... I HVDFL,RC="HIV" Q
..... S BKSTIN(INC,TYP,DAT,RC)=$S($G(BKARRAY(TYP,"REF",RC,DAT))="":0,1:1_U_$G(BKARRAY(TYP,"REF",RC,DAT)))
..... I $G(BKARRAY(TYP,"REF",RC,DAT))'="" S REF(BKARRAY(TYP,"REF",RC,DAT))=""
..... ;S:BKSTIN(INC,TYP,DAT,RC)="" BKSTIN(INC,TYP,DAT,RC)=0
;
S INC=0
F S INC=$O(BKSTIN(INC)) Q:INC="" D
. S TYP="" F S TYP=$O(BKSTIN(INC,TYP)) Q:TYP="" D
.. S $P(BKSTIY(INC,0),U,1)=$P($G(BKSTIY(INC,0)),U,1)+1
.. S DAT="" F S DAT=$O(BKSTIN(INC,TYP,DAT)) Q:DAT="" D
... S INCD=$$FMTE^XLFDT(DAT,"2Z")_" "_BKSTIN(INC,TYP,DAT)
... S $P(BKSTIY(INC,TYP,0),U,1)=$P($G(BKSTIY(INC,TYP,0)),U,1)+1
... S $P(BKSTIY(INC,TYP,0),U,5)=INCD
... ;S $P(BKSTIY(INC,0),U,5)=$P(BKSTIY(INC,0),U,5)_INCD_"; "
... S RC="" F S RC=$O(BKSTIN(INC,TYP,DAT,RC)) Q:RC="" D
.... S BKSTIY("Z",INC,RC,DAT)=BKSTIN(INC,TYP,DAT,RC)
.... Q
;
K NS,SD,RF
S INC=0
F S INC=$O(BKSTIY(INC)) Q:INC="" D
. S RC=""
. F S RC=$O(BKSTIY("Z",INC,RC)) Q:RC="" D
.. S DAT=""
.. F S DAT=$O(BKSTIY("Z",INC,RC,DAT)) Q:DAT="" D
... S NS(INC,RC)=$G(NS(INC,RC))+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)_"; "
... I $P(BKSTIY("Z",INC,RC,DAT),U,2)["REF " S RF(INC,RC)=$G(RF(INC,RC))+1
... S:$G(SD(INC,RC))="" SD(INC,RC)=0
... S:$G(RF(INC,RC))="" RF(INC,RC)=0
;
K BKSTIY("Z")
;
S INC=0
F S INC=$O(NS(INC)) Q:INC="" D
. S RC=""
. F S RC=$O(NS(INC,RC)) Q:RC="" D
.. S $P(BKSTIY(INC,RC),U,1)=NS(INC,RC)
;
S INC=0
F S INC=$O(SD(INC)) Q:INC="" D
. S RC=""
. F S RC=$O(SD(INC,RC)) Q:RC="" D
.. S $P(BKSTIY(INC,RC),U,2)=SD(INC,RC)
;
S INC=0
F S INC=$O(RF(INC)) Q:INC="" D
. S RC=""
. F S RC=$O(RF(INC,RC)) Q:RC="" D
.. S $P(BKSTIY(INC,RC),U,3)=RF(INC,RC)
;
S INC=0
F S INC=$O(INCD(INC)) Q:INC="" D
. S RC=""
. F S RC=$O(INCD(INC,RC)) Q:RC="" D
.. S $P(BKSTIY(INC,RC),U,4)=INCD(INC,RC)
;
S TOTIN=0,TOTNS=0,TOTSD=0,TOTRF=0
S INC=0
F S INC=$O(BKSTIY(INC)) Q:INC="" D
. S TOTIN=TOTIN+$P(BKSTIY(INC,0),U,1)
. S TYP=0 F S TYP=$O(BKSTIY(INC,TYP)) Q:TYP="" D
.. I $G(BKSTIY(INC,TYP,0))'="" Q
.. ;F TI=1:1:3 S:$P(BKSTIY(INC,TYP),U,TI)="" $P(BKSTIY(INC,TYP),U,TI)=0
.. S TOTNS=TOTNS+$P(BKSTIY(INC,TYP),U,1)
.. S TOTSD=TOTSD+$P(BKSTIY(INC,TYP),U,2)
.. S TOTRF=TOTRF+$P(BKSTIY(INC,TYP),U,3)
;
S BKSTIY(0)=TOTIN_U_TOTNS_U_TOTSD_U_TOTRF
K BKARRAY,BKSTIN
Q
;
INC ;EP - Determine multiple incidences
NEW TYP,DAT,INC,PDAT,NXDT,NTYP,DTDIF
K MBKARAY,BKSTIN
S TYP=""
F S TYP=$O(BKARRAY(TYP)) Q:TYP="" D
. S DAT=""
. F S DAT=$O(BKARRAY(TYP,"DEN",DAT)) Q:DAT="" D
.. S MBKARAY(DAT,TYP)=BKARRAY(TYP,"DEN",DAT)
S INC=0,DAT="",PDAT=""
F S DAT=$O(MBKARAY(DAT)) Q:DAT="" D
. S INC=INC+1 D SDT(DAT) K MBKARAY(DAT)
. S DTDIF=$$FMADD^XLFDT(DAT,60)
. S NXDT=DAT F S NXDT=$O(MBKARAY(NXDT)) Q:NXDT="" D
.. I NXDT<DTDIF D
... D SDT(NXDT)
... K MBKARAY(NXDT)
Q
;
SDT(VDT) ;EP - Same date, multiple types
S TYP=""
F S TYP=$O(MBKARAY(VDT,TYP)) Q:TYP="" D
. S BKSTIN(INC,TYP,VDT)=MBKARAY(VDT,TYP)
Q
BKMSTID1 ;PRXM/HC/ALA-STI Display ; 20 Mar 2007 2:23 PM
+1 ;;2.1;HIV MANAGEMENT SYSTEM;;Feb 07, 2011
+2 ;
EN(BKMDFN,RPSDT,RPEDT,BKTYPE,BKARRAY,BKSTIY) ;
+1 ; Input parameters
+2 ; BKMDFN - Patient internal entry number
+3 ; RPSDT - Report start date in FileMan date format
+4 ; RPEDT - Report end date in FileMan date format
+5 ; BKTYPE - Type of STI data, defaults to 'Key'
+6 ; BKARRAY - Array to return raw data
+7 ; BKSTIY - Array to return data by totals
+8 ;
+9 NEW DIR,Y,X,DTOUT,DUOUT,DFN,SEX,SSN,PTNAME,AGE,AUPNDAYS,AUPNDOB
+10 NEW AUPNPAT,AUPNDOD,AUPNSEX,SIEN,STINM,STI,NIN,DDATA,RSTI,NSTI,RSTINM
+11 NEW RSTNM,RSIEN,NSIEN,NRSCR,HVDFL,BKTYPE,NCT,NSCR,RFL,SCREEN,LR,NTSCR,QFL,SSCREEN
+12 NEW TOT,BKIN,BKN,HSCR,POP,INC,SDAT,STYP,BKBDT,BKEDT,CT,BKMARRAY
+13 NEW TOTIN,INCD,INCS
+14 ;
+15 SET BKTYPE=$GET(BKTYPE,"KEY")
SET HVDFL=0
SET AUPNPAT=BKMDFN
+16 KILL BKARRAY,BKSTIN,BKSTIY
SET QFL=0
+17 SET BKBDT=$$FMADD^XLFDT(RPSDT,-60)
SET BKEDT=$$FMADD^XLFDT(RPSDT,300)
+18 DO EN^BKMSTI(AUPNPAT,BKBDT,BKEDT,BKTYPE,.BKARRAY,.HVDFL)
+19 IF '$DATA(BKARRAY)
SET BKSTIY(0)=0
QUIT
+20 IF $DATA(BKARRAY)
Begin DoDot:1
+21 NEW STI
+22 SET STI=""
+23 FOR
SET STI=$ORDER(BKARRAY(STI))
IF STI=""
QUIT
Begin DoDot:2
+24 IF $GET(BKARRAY(STI,"DEN"))'=0
SET QFL=1
QUIT
End DoDot:2
IF QFL
QUIT
End DoDot:1
+25 IF 'QFL
KILL BKARRAY
SET BKSTIY(0)=0
QUIT
+26 DO INC
+27 ; clean up extras values not needed
+28 SET INC=0
+29 FOR
SET INC=$ORDER(BKSTIN(INC))
IF INC=""
QUIT
Begin DoDot:1
+30 SET STYP=""
+31 FOR
SET STYP=$ORDER(BKSTIN(INC,STYP))
IF STYP=""
QUIT
Begin DoDot:2
+32 SET SDAT=""
SET CT=0
+33 FOR
SET SDAT=$ORDER(BKSTIN(INC,STYP,SDAT))
IF SDAT=""
QUIT
Begin DoDot:3
+34 SET CT=CT+1
+35 IF CT>1
KILL BKSTIN(INC,STYP,SDAT)
End DoDot:3
End DoDot:2
End DoDot:1
+36 ;
+37 SET INC=0
+38 FOR
SET INC=$ORDER(BKSTIN(INC))
IF INC=""
QUIT
Begin DoDot:1
+39 KILL REC,NBREC,NREC
+40 SET TOTIN=0
+41 SET TYP=""
FOR
SET TYP=$ORDER(BKSTIN(INC,TYP))
IF TYP=""
QUIT
Begin DoDot:2
+42 SET DAT=""
+43 FOR
SET DAT=$ORDER(BKSTIN(INC,TYP,DAT))
IF DAT=""
QUIT
Begin DoDot:3
+44 SET RC=""
+45 FOR
SET RC=$ORDER(BKARRAY(TYP,"NUM",RC))
IF RC=""
QUIT
Begin DoDot:4
+46 IF +$GET(BKSTIN(INC,TYP,DAT,RC))=0
Begin DoDot:5
+47 IF $DATA(BKSTIN(INC,RC))
QUIT
+48 IF HVDFL
IF RC="HIV"
QUIT
+49 SET BKSTIN(INC,TYP,DAT,RC)=$GET(BKARRAY(TYP,"NUM",RC,DAT))
+50 ;S:BKSTIN(INC,TYP,DAT,RC)="" BKSTIN(INC,TYP,DAT,RC)=0
End DoDot:5
End DoDot:4
+51 ;
+52 SET RC=""
+53 FOR
SET RC=$ORDER(BKARRAY(TYP,"REF",RC))
IF RC=""
QUIT
Begin DoDot:4
+54 IF +$GET(BKSTIN(INC,TYP,DAT,RC))=0
Begin DoDot:5
+55 IF $DATA(BKSTIN(INC,RC))
QUIT
+56 IF HVDFL
IF RC="HIV"
QUIT
+57 SET BKSTIN(INC,TYP,DAT,RC)=$SELECT($GET(BKARRAY(TYP,"REF",RC,DAT))="":0,1:1_U_$GET(BKARRAY(TYP,"REF",RC,DAT)))
+58 IF $GET(BKARRAY(TYP,"REF",RC,DAT))'=""
SET REF(BKARRAY(TYP,"REF",RC,DAT))=""
+59 ;S:BKSTIN(INC,TYP,DAT,RC)="" BKSTIN(INC,TYP,DAT,RC)=0
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+60 ;
+61 SET INC=0
+62 FOR
SET INC=$ORDER(BKSTIN(INC))
IF INC=""
QUIT
Begin DoDot:1
+63 SET TYP=""
FOR
SET TYP=$ORDER(BKSTIN(INC,TYP))
IF TYP=""
QUIT
Begin DoDot:2
+64 SET $PIECE(BKSTIY(INC,0),U,1)=$PIECE($GET(BKSTIY(INC,0)),U,1)+1
+65 SET DAT=""
FOR
SET DAT=$ORDER(BKSTIN(INC,TYP,DAT))
IF DAT=""
QUIT
Begin DoDot:3
+66 SET INCD=$$FMTE^XLFDT(DAT,"2Z")_" "_BKSTIN(INC,TYP,DAT)
+67 SET $PIECE(BKSTIY(INC,TYP,0),U,1)=$PIECE($GET(BKSTIY(INC,TYP,0)),U,1)+1
+68 SET $PIECE(BKSTIY(INC,TYP,0),U,5)=INCD
+69 ;S $P(BKSTIY(INC,0),U,5)=$P(BKSTIY(INC,0),U,5)_INCD_"; "
+70 SET RC=""
FOR
SET RC=$ORDER(BKSTIN(INC,TYP,DAT,RC))
IF RC=""
QUIT
Begin DoDot:4
+71 SET BKSTIY("Z",INC,RC,DAT)=BKSTIN(INC,TYP,DAT,RC)
+72 QUIT
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+73 ;
+74 KILL NS,SD,RF
+75 SET INC=0
+76 FOR
SET INC=$ORDER(BKSTIY(INC))
IF INC=""
QUIT
Begin DoDot:1
+77 SET RC=""
+78 FOR
SET RC=$ORDER(BKSTIY("Z",INC,RC))
IF RC=""
QUIT
Begin DoDot:2
+79 SET DAT=""
+80 FOR
SET DAT=$ORDER(BKSTIY("Z",INC,RC,DAT))
IF DAT=""
QUIT
Begin DoDot:3
+81 SET NS(INC,RC)=$GET(NS(INC,RC))+1
+82 IF $PIECE(BKSTIY("Z",INC,RC,DAT),U,1)=1
SET SD(INC,RC)=$GET(SD(INC,RC))+1
SET INCD(INC,RC)=$GET(INCD(INC,RC))_$PIECE(BKSTIY("Z",INC,RC,DAT),U,2)_"; "
+83 IF $PIECE(BKSTIY("Z",INC,RC,DAT),U,2)["REF "
SET RF(INC,RC)=$GET(RF(INC,RC))+1
+84 IF $GET(SD(INC,RC))=""
SET SD(INC,RC)=0
+85 IF $GET(RF(INC,RC))=""
SET RF(INC,RC)=0
End DoDot:3
End DoDot:2
End DoDot:1
+86 ;
+87 KILL BKSTIY("Z")
+88 ;
+89 SET INC=0
+90 FOR
SET INC=$ORDER(NS(INC))
IF INC=""
QUIT
Begin DoDot:1
+91 SET RC=""
+92 FOR
SET RC=$ORDER(NS(INC,RC))
IF RC=""
QUIT
Begin DoDot:2
+93 SET $PIECE(BKSTIY(INC,RC),U,1)=NS(INC,RC)
End DoDot:2
End DoDot:1
+94 ;
+95 SET INC=0
+96 FOR
SET INC=$ORDER(SD(INC))
IF INC=""
QUIT
Begin DoDot:1
+97 SET RC=""
+98 FOR
SET RC=$ORDER(SD(INC,RC))
IF RC=""
QUIT
Begin DoDot:2
+99 SET $PIECE(BKSTIY(INC,RC),U,2)=SD(INC,RC)
End DoDot:2
End DoDot:1
+100 ;
+101 SET INC=0
+102 FOR
SET INC=$ORDER(RF(INC))
IF INC=""
QUIT
Begin DoDot:1
+103 SET RC=""
+104 FOR
SET RC=$ORDER(RF(INC,RC))
IF RC=""
QUIT
Begin DoDot:2
+105 SET $PIECE(BKSTIY(INC,RC),U,3)=RF(INC,RC)
End DoDot:2
End DoDot:1
+106 ;
+107 SET INC=0
+108 FOR
SET INC=$ORDER(INCD(INC))
IF INC=""
QUIT
Begin DoDot:1
+109 SET RC=""
+110 FOR
SET RC=$ORDER(INCD(INC,RC))
IF RC=""
QUIT
Begin DoDot:2
+111 SET $PIECE(BKSTIY(INC,RC),U,4)=INCD(INC,RC)
End DoDot:2
End DoDot:1
+112 ;
+113 SET TOTIN=0
SET TOTNS=0
SET TOTSD=0
SET TOTRF=0
+114 SET INC=0
+115 FOR
SET INC=$ORDER(BKSTIY(INC))
IF INC=""
QUIT
Begin DoDot:1
+116 SET TOTIN=TOTIN+$PIECE(BKSTIY(INC,0),U,1)
+117 SET TYP=0
FOR
SET TYP=$ORDER(BKSTIY(INC,TYP))
IF TYP=""
QUIT
Begin DoDot:2
+118 IF $GET(BKSTIY(INC,TYP,0))'=""
QUIT
+119 ;F TI=1:1:3 S:$P(BKSTIY(INC,TYP),U,TI)="" $P(BKSTIY(INC,TYP),U,TI)=0
+120 SET TOTNS=TOTNS+$PIECE(BKSTIY(INC,TYP),U,1)
+121 SET TOTSD=TOTSD+$PIECE(BKSTIY(INC,TYP),U,2)
+122 SET TOTRF=TOTRF+$PIECE(BKSTIY(INC,TYP),U,3)
End DoDot:2
End DoDot:1
+123 ;
+124 SET BKSTIY(0)=TOTIN_U_TOTNS_U_TOTSD_U_TOTRF
+125 KILL BKARRAY,BKSTIN
+126 QUIT
+127 ;
INC ;EP - Determine multiple incidences
+1 NEW TYP,DAT,INC,PDAT,NXDT,NTYP,DTDIF
+2 KILL MBKARAY,BKSTIN
+3 SET TYP=""
+4 FOR
SET TYP=$ORDER(BKARRAY(TYP))
IF TYP=""
QUIT
Begin DoDot:1
+5 SET DAT=""
+6 FOR
SET DAT=$ORDER(BKARRAY(TYP,"DEN",DAT))
IF DAT=""
QUIT
Begin DoDot:2
+7 SET MBKARAY(DAT,TYP)=BKARRAY(TYP,"DEN",DAT)
End DoDot:2
End DoDot:1
+8 SET INC=0
SET DAT=""
SET PDAT=""
+9 FOR
SET DAT=$ORDER(MBKARAY(DAT))
IF DAT=""
QUIT
Begin DoDot:1
+10 SET INC=INC+1
DO SDT(DAT)
KILL MBKARAY(DAT)
+11 SET DTDIF=$$FMADD^XLFDT(DAT,60)
+12 SET NXDT=DAT
FOR
SET NXDT=$ORDER(MBKARAY(NXDT))
IF NXDT=""
QUIT
Begin DoDot:2
+13 IF NXDT<DTDIF
Begin DoDot:3
+14 DO SDT(NXDT)
+15 KILL MBKARAY(NXDT)
End DoDot:3
End DoDot:2
End DoDot:1
+16 QUIT
+17 ;
SDT(VDT) ;EP - Same date, multiple types
+1 SET TYP=""
+2 FOR
SET TYP=$ORDER(MBKARAY(VDT,TYP))
IF TYP=""
QUIT
Begin DoDot:1
+3 SET BKSTIN(INC,TYP,VDT)=MBKARAY(VDT,TYP)
End DoDot:1
+4 QUIT
