BKMSTID2 ;PRXM/HC/ALA-STI Display ; 20 Mar 2007 2:23 PM
;;2.1;HIV MANAGEMENT SYSTEM;;Feb 07, 2011
;
PAT ; Get patient
NEW DIR,RPSDT,RPEDT,Y,X,DTOUT,DUOUT,DFN,SEX,SSN,PTNAME,AGE,AUPNDAYS,AUPNDOB
NEW AUPNDOD,AUPNPAT,AUPNSEX,BKARRAY,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
W !!
D PLK^BKMPLKP
I $G(AUPNPAT)="" Q
S DIR("A")="Enter Report Start Date"
S DIR("B")=$$FMTE^XLFDT(3060101,1)
S DIR(0)="D"
D ^DIR
I $D(DTOUT)!$D(DUOUT) Q
S RPSDT=Y
;
S DIR("A")="Enter Report End Date"
S DIR("B")=$$FMTE^XLFDT($$FMADD^XLFDT(RPSDT,365),1)
S DIR(0)="D"
D ^DIR
I $D(DTOUT)!$D(DUOUT) Q
S RPEDT=Y
;
K DIR
S DIR("A")="Enter STI type"
S DIR(0)="S^K:KEY;O:OTHER;A:ALL"
D ^DIR
I $D(DTOUT)!$D(DUOUT) Q
;
PRT K %ZIS,IOP,IOC,ZTIO
S %ZIS="M" D ^%ZIS Q:POP ; ask device
I $D(IO("Q")) D EN^DDIOL("Cannot queue this") G PRT
;
U IO
;
I IOST'["C-" W !,?10,"HRN: "_$$HRN^AUPNPAT3(AUPNPAT,DUZ(2)),?40,"Date Range: "_$$FMTE^XLFDT(RPSDT,"2Z")_" - "_$$FMTE^XLFDT(RPEDT,"2Z")
S X=$$UP^XLFSTR(X)
S BKTYPE=$S(X="K":"KEY",X="O":"OTHER",1:""),HVDFL=0
K BKARRAY S QFL=0
; Set beginning date to 2 months (60 days) prior to CRS report period begin date
; through the first 300 days of the CRS report period
S BKBDT=$$FMADD^XLFDT(RPSDT,-60),BKEDT=$$FMADD^XLFDT(RPSDT,300)
D EN^BKMSTI(AUPNPAT,BKBDT,BKEDT,BKTYPE,.BKARRAY,.HVDFL)
I '$D(BKARRAY) W !,"Patient has no STI diagnoses" D ^%ZISC G PAT
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 W !!!,"Patient has no STI diagnoses" D ^%ZISC G PAT
D INC
; clean up extras
S INC=0
F S INC=$O(BKSTIY(INC)) Q:INC="" D
. S STYP=""
. F S STYP=$O(BKSTIY(INC,STYP)) Q:STYP="" D
.. S SDAT="",CT=0
.. F S SDAT=$O(BKSTIY(INC,STYP,"DEN",SDAT)) Q:SDAT="" D
... S CT=CT+1
... I CT>1 K BKSTIY(INC,STYP,"DEN",SDAT)
;
S INC=0
F S INC=$O(BKSTIY(INC)) Q:INC="" D
. W !!,?5,"Diagnosis Incident: ",INC
. K REC,NBREC,NREC
. S TYP="" F S TYP=$O(BKSTIY(INC,TYP)) Q:TYP="" D
.. S DAT=""
.. F S DAT=$O(BKSTIY(INC,TYP,"DEN",DAT)) Q:DAT="" D
... W !,?10,$$FMTE^XLFDT(DAT,"2Z")," ",TYP," ",BKSTIY(INC,TYP,"DEN",DAT)
... S RC=""
... F S RC=$O(BKARRAY(TYP,"NUM",RC)) Q:RC="" D
.... I $G(REC(RC))="" S REC(RC)=$P($G(BKARRAY(TYP,"NUM",RC,DAT)),U,2),NREC(RC)=""
.... I RC="HIV" D
..... NEW HKDATE,HEDATE
..... S HKDATE="",HEDATE=DAT
..... S HVDFL=$$HIVS^BKMRMDR(AUPNPAT,.HKDATE,.HEDATE)
..... ; HIV Diagnosis takes precedence over HIV screening
..... I +HVDFL=0 S NREC(RC)=$P($G(BKARRAY(TYP,"NUM",RC)),U,2) Q
..... I +HVDFL=1 S NREC(RC)=$P(HVDFL,U,2)
.... ;I HVDFL,RC="HIV" S NREC(RC)=$P(BKARRAY(TYP,"NUM",RC),U,2)
.... I $G(NREC(RC))="" D
..... I $G(BKARRAY(RC,"DEN",DAT))'="" S NREC(RC)=$$FMTE^XLFDT(DAT,"2Z")_" "_$G(BKARRAY(RC,"DEN",DAT)) Q
..... NEW BDATE,EDATE,DDT,QFL
..... S EDATE=$$FMADD^XLFDT(DAT,60),BDATE=$$FMADD^XLFDT(DAT,-30)
..... S DDT="",QFL=0
..... F S DDT=$O(BKARRAY(RC,"DEN",DDT)) Q:DDT="" D Q:QFL
...... I DDT'<BDATE,DDT'>EDATE S NREC(RC)=$$FMTE^XLFDT(DDT,"2Z")_" "_$G(BKARRAY(RC,"DEN",DDT)),QFL=1
..... I $G(BKMARRAY(RC,"DEN"))="" D
...... D EN^BKMSTI(DFN,BDATE,EDATE,RC,.BKDXN,.HVDFL)
...... I $P(BKDXN(RC,"DEN"),U,1)'=0 S NREC(RC)=$P($P(BKDXN(RC,"DEN"),U,2),";",1)
...... K BKDXN
.... I $G(NREC(RC))="",$G(BKARRAY(TYP,"REF",RC,DAT))'="" S REC(RC)=$P($G(BKARRAY(TYP,"REF",RC,DAT)),U,1)
. W !,?5,"Recommended Screenings: "
. S RC="" F S RC=$O(REC(RC)) Q:RC="" W !,?10,"1 "_RC
. W !,?5,"Needed Screenings: "
. S RC="" F S RC=$O(NREC(RC)) Q:RC="" D
.. S NUM=$S(NREC(RC)="":1,1:0)
.. S SUMNREC(RC)=$G(SUMNREC(RC))+NUM
.. I NREC(RC)="" W !,?10,NUM_" "_RC Q
.. W !,?10,NUM_" "_RC_" "_NREC(RC)
. W !,?5,"Need-based Screenings Performed: "
. S RC="" F S RC=$O(REC(RC)) Q:RC="" D
.. I $G(NREC(RC))'="" Q
.. S NUM=$S($G(REC(RC))="":0,1:1)
.. S SUMNBRC(RC)=$G(SUMNBRC(RC))+NUM
.. I $G(REC(RC))="" W !,?10,NUM_" "_RC Q
.. W !,?10,NUM_" "_RC_" "_REC(RC)
W !!,?5,"Summary",!
W !,?5,"Needed Screenings: "
S RC=""
F S RC=$O(SUMNREC(RC)) Q:RC="" W !,?10,SUMNREC(RC)_" "_RC
;
W !,?5,"Need-Based Screenings Performed: "
S RC=""
F S RC=$O(SUMNBRC(RC)) Q:RC="" D
. S NUM=SUMNBRC(RC),NPR=SUMNREC(RC)
. I NPR'=0 S PER=$J((NUM/NPR)*100,3,0)
. I NPR=0 S PER=0
. W !,?10,SUMNBRC(RC)_" "_RC_" "_PER_"%"
D ^%ZISC
K REC,NREC,NBREC,SUMNBRC,SUMNREC,MBKARAY,BKSTIY,DAT,INC,NPR,NUM,PER,RC,TYP
G PAT
;
INC ;EP - Determine multiple incidences
NEW TYP,DAT,INC,PDAT,NXDT,NTYP,DTDIF
K MBKARAY,BKSTIY
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 BKSTIY(INC,TYP,"DEN",VDT)=MBKARAY(VDT,TYP)
Q
BKMSTID2 ;PRXM/HC/ALA-STI Display ; 20 Mar 2007 2:23 PM
+1 ;;2.1;HIV MANAGEMENT SYSTEM;;Feb 07, 2011
+2 ;
PAT ; Get patient
+1 NEW DIR,RPSDT,RPEDT,Y,X,DTOUT,DUOUT,DFN,SEX,SSN,PTNAME,AGE,AUPNDAYS,AUPNDOB
+2 NEW AUPNDOD,AUPNPAT,AUPNSEX,BKARRAY,SIEN,STINM,STI,NIN,DDATA,RSTI,NSTI,RSTINM
+3 NEW RSTNM,RSIEN,NSIEN,NRSCR,HVDFL,BKTYPE,NCT,NSCR,RFL,SCREEN,LR,NTSCR,QFL,SSCREEN
+4 NEW TOT,BKIN,BKN,HSCR,POP,INC,SDAT,STYP,BKBDT,BKEDT,CT,BKMARRAY
+5 WRITE !!
+6 DO PLK^BKMPLKP
+7 IF $GET(AUPNPAT)=""
QUIT
+8 SET DIR("A")="Enter Report Start Date"
+9 SET DIR("B")=$$FMTE^XLFDT(3060101,1)
+10 SET DIR(0)="D"
+11 DO ^DIR
+12 IF $DATA(DTOUT)!$DATA(DUOUT)
QUIT
+13 SET RPSDT=Y
+14 ;
+15 SET DIR("A")="Enter Report End Date"
+16 SET DIR("B")=$$FMTE^XLFDT($$FMADD^XLFDT(RPSDT,365),1)
+17 SET DIR(0)="D"
+18 DO ^DIR
+19 IF $DATA(DTOUT)!$DATA(DUOUT)
QUIT
+20 SET RPEDT=Y
+21 ;
+22 KILL DIR
+23 SET DIR("A")="Enter STI type"
+24 SET DIR(0)="S^K:KEY;O:OTHER;A:ALL"
+25 DO ^DIR
+26 IF $DATA(DTOUT)!$DATA(DUOUT)
QUIT
+27 ;
PRT KILL %ZIS,IOP,IOC,ZTIO
+1 ; ask device
SET %ZIS="M"
DO ^%ZIS
IF POP
QUIT
+2 IF $DATA(IO("Q"))
DO EN^DDIOL("Cannot queue this")
GOTO PRT
+3 ;
+4 USE IO
+5 ;
+6 IF IOST'["C-"
WRITE !,?10,"HRN: "_$$HRN^AUPNPAT3(AUPNPAT,DUZ(2)),?40,"Date Range: "_$$FMTE^XLFDT(RPSDT,"2Z")_" - "_$$FMTE^XLFDT(RPEDT,"2Z")
+7 SET X=$$UP^XLFSTR(X)
+8 SET BKTYPE=$SELECT(X="K":"KEY",X="O":"OTHER",1:"")
SET HVDFL=0
+9 KILL BKARRAY
SET QFL=0
+10 ; Set beginning date to 2 months (60 days) prior to CRS report period begin date
+11 ; through the first 300 days of the CRS report period
+12 SET BKBDT=$$FMADD^XLFDT(RPSDT,-60)
SET BKEDT=$$FMADD^XLFDT(RPSDT,300)
+13 DO EN^BKMSTI(AUPNPAT,BKBDT,BKEDT,BKTYPE,.BKARRAY,.HVDFL)
+14 IF '$DATA(BKARRAY)
WRITE !,"Patient has no STI diagnoses"
DO ^%ZISC
GOTO PAT
+15 IF $DATA(BKARRAY)
Begin DoDot:1
+16 NEW STI
+17 SET STI=""
+18 FOR
SET STI=$ORDER(BKARRAY(STI))
IF STI=""
QUIT
Begin DoDot:2
+19 IF $GET(BKARRAY(STI,"DEN"))'=0
SET QFL=1
QUIT
End DoDot:2
IF QFL
QUIT
End DoDot:1
+20 IF 'QFL
WRITE !!!,"Patient has no STI diagnoses"
DO ^%ZISC
GOTO PAT
+21 DO INC
+22 ; clean up extras
+23 SET INC=0
+24 FOR
SET INC=$ORDER(BKSTIY(INC))
IF INC=""
QUIT
Begin DoDot:1
+25 SET STYP=""
+26 FOR
SET STYP=$ORDER(BKSTIY(INC,STYP))
IF STYP=""
QUIT
Begin DoDot:2
+27 SET SDAT=""
SET CT=0
+28 FOR
SET SDAT=$ORDER(BKSTIY(INC,STYP,"DEN",SDAT))
IF SDAT=""
QUIT
Begin DoDot:3
+29 SET CT=CT+1
+30 IF CT>1
KILL BKSTIY(INC,STYP,"DEN",SDAT)
End DoDot:3
End DoDot:2
End DoDot:1
+31 ;
+32 SET INC=0
+33 FOR
SET INC=$ORDER(BKSTIY(INC))
IF INC=""
QUIT
Begin DoDot:1
+34 WRITE !!,?5,"Diagnosis Incident: ",INC
+35 KILL REC,NBREC,NREC
+36 SET TYP=""
FOR
SET TYP=$ORDER(BKSTIY(INC,TYP))
IF TYP=""
QUIT
Begin DoDot:2
+37 SET DAT=""
+38 FOR
SET DAT=$ORDER(BKSTIY(INC,TYP,"DEN",DAT))
IF DAT=""
QUIT
Begin DoDot:3
+39 WRITE !,?10,$$FMTE^XLFDT(DAT,"2Z")," ",TYP," ",BKSTIY(INC,TYP,"DEN",DAT)
+40 SET RC=""
+41 FOR
SET RC=$ORDER(BKARRAY(TYP,"NUM",RC))
IF RC=""
QUIT
Begin DoDot:4
+42 IF $GET(REC(RC))=""
SET REC(RC)=$PIECE($GET(BKARRAY(TYP,"NUM",RC,DAT)),U,2)
SET NREC(RC)=""
+43 IF RC="HIV"
Begin DoDot:5
+44 NEW HKDATE,HEDATE
+45 SET HKDATE=""
SET HEDATE=DAT
+46 SET HVDFL=$$HIVS^BKMRMDR(AUPNPAT,.HKDATE,.HEDATE)
+47 ; HIV Diagnosis takes precedence over HIV screening
+48 IF +HVDFL=0
SET NREC(RC)=$PIECE($GET(BKARRAY(TYP,"NUM",RC)),U,2)
QUIT
+49 IF +HVDFL=1
SET NREC(RC)=$PIECE(HVDFL,U,2)
End DoDot:5
+50 ;I HVDFL,RC="HIV" S NREC(RC)=$P(BKARRAY(TYP,"NUM",RC),U,2)
+51 IF $GET(NREC(RC))=""
Begin DoDot:5
+52 IF $GET(BKARRAY(RC,"DEN",DAT))'=""
SET NREC(RC)=$$FMTE^XLFDT(DAT,"2Z")_" "_$GET(BKARRAY(RC,"DEN",DAT))
QUIT
+53 NEW BDATE,EDATE,DDT,QFL
+54 SET EDATE=$$FMADD^XLFDT(DAT,60)
SET BDATE=$$FMADD^XLFDT(DAT,-30)
+55 SET DDT=""
SET QFL=0
+56 FOR
SET DDT=$ORDER(BKARRAY(RC,"DEN",DDT))
IF DDT=""
QUIT
Begin DoDot:6
+57 IF DDT'<BDATE
IF DDT'>EDATE
SET NREC(RC)=$$FMTE^XLFDT(DDT,"2Z")_" "_$GET(BKARRAY(RC,"DEN",DDT))
SET QFL=1
End DoDot:6
IF QFL
QUIT
+58 IF $GET(BKMARRAY(RC,"DEN"))=""
Begin DoDot:6
+59 DO EN^BKMSTI(DFN,BDATE,EDATE,RC,.BKDXN,.HVDFL)
+60 IF $PIECE(BKDXN(RC,"DEN"),U,1)'=0
SET NREC(RC)=$PIECE($PIECE(BKDXN(RC,"DEN"),U,2),";",1)
+61 KILL BKDXN
End DoDot:6
End DoDot:5
+62 IF $GET(NREC(RC))=""
IF $GET(BKARRAY(TYP,"REF",RC,DAT))'=""
SET REC(RC)=$PIECE($GET(BKARRAY(TYP,"REF",RC,DAT)),U,1)
End DoDot:4
End DoDot:3
End DoDot:2
+63 WRITE !,?5,"Recommended Screenings: "
+64 SET RC=""
FOR
SET RC=$ORDER(REC(RC))
IF RC=""
QUIT
WRITE !,?10,"1 "_RC
+65 WRITE !,?5,"Needed Screenings: "
+66 SET RC=""
FOR
SET RC=$ORDER(NREC(RC))
IF RC=""
QUIT
Begin DoDot:2
+67 SET NUM=$SELECT(NREC(RC)="":1,1:0)
+68 SET SUMNREC(RC)=$GET(SUMNREC(RC))+NUM
+69 IF NREC(RC)=""
WRITE !,?10,NUM_" "_RC
QUIT
+70 WRITE !,?10,NUM_" "_RC_" "_NREC(RC)
End DoDot:2
+71 WRITE !,?5,"Need-based Screenings Performed: "
+72 SET RC=""
FOR
SET RC=$ORDER(REC(RC))
IF RC=""
QUIT
Begin DoDot:2
+73 IF $GET(NREC(RC))'=""
QUIT
+74 SET NUM=$SELECT($GET(REC(RC))="":0,1:1)
+75 SET SUMNBRC(RC)=$GET(SUMNBRC(RC))+NUM
+76 IF $GET(REC(RC))=""
WRITE !,?10,NUM_" "_RC
QUIT
+77 WRITE !,?10,NUM_" "_RC_" "_REC(RC)
End DoDot:2
End DoDot:1
+78 WRITE !!,?5,"Summary",!
+79 WRITE !,?5,"Needed Screenings: "
+80 SET RC=""
+81 FOR
SET RC=$ORDER(SUMNREC(RC))
IF RC=""
QUIT
WRITE !,?10,SUMNREC(RC)_" "_RC
+82 ;
+83 WRITE !,?5,"Need-Based Screenings Performed: "
+84 SET RC=""
+85 FOR
SET RC=$ORDER(SUMNBRC(RC))
IF RC=""
QUIT
Begin DoDot:1
+86 SET NUM=SUMNBRC(RC)
SET NPR=SUMNREC(RC)
+87 IF NPR'=0
SET PER=$JUSTIFY((NUM/NPR)*100,3,0)
+88 IF NPR=0
SET PER=0
+89 WRITE !,?10,SUMNBRC(RC)_" "_RC_" "_PER_"%"
End DoDot:1
+90 DO ^%ZISC
+91 KILL REC,NREC,NBREC,SUMNBRC,SUMNREC,MBKARAY,BKSTIY,DAT,INC,NPR,NUM,PER,RC,TYP
+92 GOTO PAT
+93 ;
INC ;EP - Determine multiple incidences
+1 NEW TYP,DAT,INC,PDAT,NXDT,NTYP,DTDIF
+2 KILL MBKARAY,BKSTIY
+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 BKSTIY(INC,TYP,"DEN",VDT)=MBKARAY(VDT,TYP)
End DoDot:1
+4 QUIT
