- 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
