BKMSTIDS ;VNGT/HS/ALA-STI Incidences ; 20 Jun 2011 4:41 PM
;;2.2;HIV MANAGEMENT SYSTEM;**1**;Apr 01, 2015;Build 17
;
EN(BKMDFN,RPSDT,RPEDT,BKTYPE,BKARRAY,BKSTIY,MUL) ; PEP
; 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
; MUL - Multiple HIV events okay if 1 (default is 0 or no)
;
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
NEW TOT,BKIN,BKN,HSCR,POP,INC,SDAT,STYP,BKBDT,BKEDT,CT,BKMARRAY,BSN
NEW TOTIN,INCD,INCS,TOTNS,TOTRF,TOTSD,RC,TVALN,QFL,SSCREEN,BKSTY,BN
NEW ZARRAY,NDEN,NNUM,TOTGD,TOTGN,FLAG,COLDTM,CPT,DAT,PRNM,TXN,TYP,NREF,TOTGR
NEW HNUM,IHVDFL,NKREF,RDT,RF,NKNUM,NKSTY,MTYP
;
S BKTYPE=$G(BKTYPE,"KEY"),HVDFL=0,AUPNPAT=BKMDFN,MUL=$G(MUL,0)
K BKARRAY,BKSTIN,BKSTIY S QFL=0
;S BKBDT=$$FMADD^XLFDT(RPSDT,-60),BKEDT=$$FMADD^XLFDT(RPSDT,300)
S BKBDT=$$FMADD^XLFDT(RPSDT,-(30.4167*2)),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,HNUM=0
F S INC=$O(BKSTIN(INC)) Q:INC="" D
. S STYP="",NDEN(INC)=0,NNUM(INC)=0,QFL=0
. F S STYP=$O(BKSTIN(INC,STYP)) Q:STYP="" D
.. I STYP="HIV" S HNUM=HNUM+1
.. 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)
... I 'MUL,HNUM>1,STYP="HIV" K BKSTIN(INC,STYP,SDAT)
;
CMP ; Compile raw data
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 BKN=$O(^BKM(90454,"D",TYP,""))
... S BKSTIY(INC,TYP,0)=1_"^^^^"_$$FMTE^XLFDT(DAT,"2Z")_" "_BKSTIN(INC,TYP,DAT),TOTIN=TOTIN+1
... S BN=0
... F S BN=$O(^BKM(90454,BKN,10,BN)) Q:'BN D
.... S BSN=$P(^BKM(90454,BKN,10,BN,0),"^",1)
.... S BKSTY=$P(^BKM(90454,BSN,0),"^",3),HVDFL=0
.... I $D(BKSTIY(INC,BKSTY))>0 Q
.... I $D(BKSTIN(INC,BKSTY))>0 Q
.... I BKSTY="HIV" D
..... NEW HKDATE,HEDATE,HSRDT
..... S HKDATE="",HEDATE=DAT
..... S HVDFL=$$HIVS^BKMRMDR(.BKMDFN,.HKDATE,.HEDATE)
..... I +HVDFL=1 D
...... I HVDFL["POV" S BKSTIY(INC,BKSTY)="0^0^^"_$P(HVDFL,U,2),IHVDFL=1 Q
...... S HSRDT=$$FMADD^XLFDT(BKBDT,-(30.4167*1))
...... I $P(HVDFL,U,3)<HSRDT D
....... I $G(BKARRAY(TYP,"NUM",BKSTY,DAT))="" S BKSTIY(INC,BKSTY)="1^0^^" Q
....... S BKSTIY(INC,BKSTY)=$G(BKARRAY(TYP,"NUM",BKSTY,DAT))
...... S BKSTIY(INC,BKSTY)="1^1^^"_$P(HVDFL,U,2)
..... ;I +HVDFL=1 S IHVDFL=1 Q
..... I +HVDFL=0 S BKSTIY(INC,BKSTY)=$G(BKARRAY(TYP,"NUM",BKSTY,DAT))
.... I +HVDFL=1 Q
.... S BKSTIY(INC,BKSTY)=1
.... I $G(BKARRAY(TYP,"NUM",BKSTY,DAT))'="" D
..... S $P(BKSTIY(INC,BKSTY),"^",2)=1
..... S $P(BKSTIY(INC,BKSTY),"^",4)=$P(BKARRAY(TYP,"NUM",BKSTY,DAT),"^",2)
.... I $G(BKARRAY(TYP,"REF",BKSTY,DAT))'="" D
..... ;S $P(BKSTIY(INC,BKSTY),"^",2)=1
..... S $P(BKSTIY(INC,BKSTY),"^",3)=1
..... I $G(BKARRAY(TYP,"NUM",BKSTY,DAT))="" S $P(BKSTIY(INC,BKSTY),"^",4)=$P(BKARRAY(TYP,"REF",BKSTY,DAT),"^",1)
..... I $G(BKARRAY(TYP,"NUM",BKSTY,DAT))'="" S $P(BKSTIY(INC,BKSTY),"^",3)=0
.. D NG(INC,TYP)
. S BKSTIY(INC,0)=TOTIN
;
S TOTIN=0,TOTNS=0,TOTSD=0,TOTRF=0,TOTGD=0,TOTGN=0,TOTGR=0
S INC=0
F S INC=$O(BKSTIY(INC)) Q:INC="" D
. S TOTIN=TOTIN+$P(BKSTIY(INC,0),U,1)
. ;S TOTGD=TOTGD+NDEN(INC),TOTGN=TOTGN+NNUM(INC)
. S TOTGD=TOTGD+1,TOTGN=TOTGN+NNUM(INC),TOTGR=TOTGR+NREF(INC)
. S TYP=0 F S TYP=$O(BKSTIY(INC,TYP)) Q:TYP="" D
.. I $G(BKSTIY(INC,TYP,0))'="" Q
.. 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_U_TOTGD_U_TOTGN_U_TOTGR
K BKSTIN
;TOTIN = Total number of incidences
;TOTNS = Total number of screenings needed
;TOTSD = Total number of screenings done
;TOTRF = Total number of refusals
;TOTGD = Total number of 'grouped' denominators
;TOTGN = Total number of 'grouped' numerators
;TOTGR = Total number of 'grouped' refusals
Q
;
INC ;EP - Determine multiple incidences
NEW TYP,DAT,INC,PDAT,NXDT,NTYP,DTDIF,NM
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 NNUM=0,NM=""
.. F S NM=$O(BKARRAY(TYP,"NUM",NM)) Q:NM="" I $G(BKARRAY(TYP,"NUM",NM))'=0 S NNUM=NNUM+1
.. S ZARRAY("ZN",DAT,TYP)=NNUM
.. S RF=""
.. 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
;
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 DTDIF=$$FMADD^XLFDT(DAT,(30.4167*2))
. S NXDT=DAT F S NXDT=$O(MBKARAY(NXDT)) Q:NXDT="" D
.. I NXDT<DTDIF D
... S MTYP=$O(BKSTIN(INC,""))
... 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
. I $G(MTYP)'="",MTYP=TYP Q
. I $G(MTYP)'="",MTYP'=TYP S INC=INC+1
. S BKSTIN(INC,TYP,VDT)=MBKARAY(VDT,TYP)
Q
;
NG(NIN,NTYP) ;
NEW BKN,BN,BSN,NKSTY,NKNUM,NKREF
S BKN=$O(^BKM(90454,"D",NTYP,""))
S BN=0,NKNUM=0,NKREF=0
I $G(IHVDFL)=1 S NKNUM=1
F S BN=$O(^BKM(90454,BKN,10,BN)) Q:'BN D
. S BSN=$P(^BKM(90454,BKN,10,BN,0),"^",1)
. S NKSTY=$P(^BKM(90454,BSN,0),"^",3)
. S NKNUM=$P($G(BKSTIY(NIN,NKSTY)),"^",2)+NKNUM
. S NKREF=$P($G(BKSTIY(NIN,NKSTY)),"^",3)+NKREF
S NNUM(NIN)=$S(NKNUM=3:1,1:0)
S NREF(NIN)=$S(NKREF>0&((NKREF+NKNUM)=3):1,1:0)
Q
BKMSTIDS ;VNGT/HS/ALA-STI Incidences ; 20 Jun 2011 4:41 PM
+1 ;;2.2;HIV MANAGEMENT SYSTEM;**1**;Apr 01, 2015;Build 17
+2 ;
EN(BKMDFN,RPSDT,RPEDT,BKTYPE,BKARRAY,BKSTIY,MUL) ; PEP
+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 ; MUL - Multiple HIV events okay if 1 (default is 0 or no)
+9 ;
+10 NEW DIR,Y,X,DTOUT,DUOUT,DFN,SEX,SSN,PTNAME,AGE,AUPNDAYS,AUPNDOB
+11 NEW AUPNPAT,AUPNDOD,AUPNSEX,SIEN,STINM,STI,NIN,DDATA,RSTI,NSTI,RSTINM
+12 NEW RSTNM,RSIEN,NSIEN,NRSCR,HVDFL,BKTYPE,NCT,NSCR,RFL,SCREEN,LR,NTSCR
+13 NEW TOT,BKIN,BKN,HSCR,POP,INC,SDAT,STYP,BKBDT,BKEDT,CT,BKMARRAY,BSN
+14 NEW TOTIN,INCD,INCS,TOTNS,TOTRF,TOTSD,RC,TVALN,QFL,SSCREEN,BKSTY,BN
+15 NEW ZARRAY,NDEN,NNUM,TOTGD,TOTGN,FLAG,COLDTM,CPT,DAT,PRNM,TXN,TYP,NREF,TOTGR
+16 NEW HNUM,IHVDFL,NKREF,RDT,RF,NKNUM,NKSTY,MTYP
+17 ;
+18 SET BKTYPE=$GET(BKTYPE,"KEY")
SET HVDFL=0
SET AUPNPAT=BKMDFN
SET MUL=$GET(MUL,0)
+19 KILL BKARRAY,BKSTIN,BKSTIY
SET QFL=0
+20 ;S BKBDT=$$FMADD^XLFDT(RPSDT,-60),BKEDT=$$FMADD^XLFDT(RPSDT,300)
+21 SET BKBDT=$$FMADD^XLFDT(RPSDT,-(30.4167*2))
SET BKEDT=$$FMADD^XLFDT(RPSDT,300)
+22 DO EN^BKMSTI(AUPNPAT,BKBDT,BKEDT,BKTYPE,.BKARRAY,.HVDFL)
+23 IF '$DATA(BKARRAY)
SET BKSTIY(0)=0
QUIT
+24 IF $DATA(BKARRAY)
Begin DoDot:1
+25 NEW STI
+26 SET STI=""
+27 FOR
SET STI=$ORDER(BKARRAY(STI))
IF STI=""
QUIT
Begin DoDot:2
+28 IF $GET(BKARRAY(STI,"DEN"))'=0
SET QFL=1
QUIT
End DoDot:2
IF QFL
QUIT
End DoDot:1
+29 IF 'QFL
KILL BKARRAY
SET BKSTIY(0)=0
QUIT
+30 DO INC
+31 ; clean up extras values not needed
+32 SET INC=0
SET HNUM=0
+33 FOR
SET INC=$ORDER(BKSTIN(INC))
IF INC=""
QUIT
Begin DoDot:1
+34 SET STYP=""
SET NDEN(INC)=0
SET NNUM(INC)=0
SET QFL=0
+35 FOR
SET STYP=$ORDER(BKSTIN(INC,STYP))
IF STYP=""
QUIT
Begin DoDot:2
+36 IF STYP="HIV"
SET HNUM=HNUM+1
+37 SET SDAT=""
SET CT=0
+38 FOR
SET SDAT=$ORDER(BKSTIN(INC,STYP,SDAT))
IF SDAT=""
QUIT
Begin DoDot:3
+39 SET CT=CT+1
+40 IF CT>1
KILL BKSTIN(INC,STYP,SDAT)
+41 IF 'MUL
IF HNUM>1
IF STYP="HIV"
KILL BKSTIN(INC,STYP,SDAT)
End DoDot:3
End DoDot:2
End DoDot:1
+42 ;
CMP ; Compile raw data
+1 SET INC=0
+2 FOR
SET INC=$ORDER(BKSTIN(INC))
IF INC=""
QUIT
Begin DoDot:1
+3 KILL REC,NBREC,NREC
+4 SET TOTIN=0
+5 SET TYP=""
FOR
SET TYP=$ORDER(BKSTIN(INC,TYP))
IF TYP=""
QUIT
Begin DoDot:2
+6 SET DAT=""
+7 FOR
SET DAT=$ORDER(BKSTIN(INC,TYP,DAT))
IF DAT=""
QUIT
Begin DoDot:3
+8 SET BKN=$ORDER(^BKM(90454,"D",TYP,""))
+9 SET BKSTIY(INC,TYP,0)=1_"^^^^"_$$FMTE^XLFDT(DAT,"2Z")_" "_BKSTIN(INC,TYP,DAT)
SET TOTIN=TOTIN+1
+10 SET BN=0
+11 FOR
SET BN=$ORDER(^BKM(90454,BKN,10,BN))
IF 'BN
QUIT
Begin DoDot:4
+12 SET BSN=$PIECE(^BKM(90454,BKN,10,BN,0),"^",1)
+13 SET BKSTY=$PIECE(^BKM(90454,BSN,0),"^",3)
SET HVDFL=0
+14 IF $DATA(BKSTIY(INC,BKSTY))>0
QUIT
+15 IF $DATA(BKSTIN(INC,BKSTY))>0
QUIT
+16 IF BKSTY="HIV"
Begin DoDot:5
+17 NEW HKDATE,HEDATE,HSRDT
+18 SET HKDATE=""
SET HEDATE=DAT
+19 SET HVDFL=$$HIVS^BKMRMDR(.BKMDFN,.HKDATE,.HEDATE)
+20 IF +HVDFL=1
Begin DoDot:6
+21 IF HVDFL["POV"
SET BKSTIY(INC,BKSTY)="0^0^^"_$PIECE(HVDFL,U,2)
SET IHVDFL=1
QUIT
+22 SET HSRDT=$$FMADD^XLFDT(BKBDT,-(30.4167*1))
+23 IF $PIECE(HVDFL,U,3)<HSRDT
Begin DoDot:7
+24 IF $GET(BKARRAY(TYP,"NUM",BKSTY,DAT))=""
SET BKSTIY(INC,BKSTY)="1^0^^"
QUIT
+25 SET BKSTIY(INC,BKSTY)=$GET(BKARRAY(TYP,"NUM",BKSTY,DAT))
End DoDot:7
+26 SET BKSTIY(INC,BKSTY)="1^1^^"_$PIECE(HVDFL,U,2)
End DoDot:6
+27 ;I +HVDFL=1 S IHVDFL=1 Q
+28 IF +HVDFL=0
SET BKSTIY(INC,BKSTY)=$GET(BKARRAY(TYP,"NUM",BKSTY,DAT))
End DoDot:5
+29 IF +HVDFL=1
QUIT
+30 SET BKSTIY(INC,BKSTY)=1
+31 IF $GET(BKARRAY(TYP,"NUM",BKSTY,DAT))'=""
Begin DoDot:5
+32 SET $PIECE(BKSTIY(INC,BKSTY),"^",2)=1
+33 SET $PIECE(BKSTIY(INC,BKSTY),"^",4)=$PIECE(BKARRAY(TYP,"NUM",BKSTY,DAT),"^",2)
End DoDot:5
+34 IF $GET(BKARRAY(TYP,"REF",BKSTY,DAT))'=""
Begin DoDot:5
+35 ;S $P(BKSTIY(INC,BKSTY),"^",2)=1
+36 SET $PIECE(BKSTIY(INC,BKSTY),"^",3)=1
+37 IF $GET(BKARRAY(TYP,"NUM",BKSTY,DAT))=""
SET $PIECE(BKSTIY(INC,BKSTY),"^",4)=$PIECE(BKARRAY(TYP,"REF",BKSTY,DAT),"^",1)
+38 IF $GET(BKARRAY(TYP,"NUM",BKSTY,DAT))'=""
SET $PIECE(BKSTIY(INC,BKSTY),"^",3)=0
End DoDot:5
End DoDot:4
End DoDot:3
+39 DO NG(INC,TYP)
End DoDot:2
+40 SET BKSTIY(INC,0)=TOTIN
End DoDot:1
+41 ;
+42 SET TOTIN=0
SET TOTNS=0
SET TOTSD=0
SET TOTRF=0
SET TOTGD=0
SET TOTGN=0
SET TOTGR=0
+43 SET INC=0
+44 FOR
SET INC=$ORDER(BKSTIY(INC))
IF INC=""
QUIT
Begin DoDot:1
+45 SET TOTIN=TOTIN+$PIECE(BKSTIY(INC,0),U,1)
+46 ;S TOTGD=TOTGD+NDEN(INC),TOTGN=TOTGN+NNUM(INC)
+47 SET TOTGD=TOTGD+1
SET TOTGN=TOTGN+NNUM(INC)
SET TOTGR=TOTGR+NREF(INC)
+48 SET TYP=0
FOR
SET TYP=$ORDER(BKSTIY(INC,TYP))
IF TYP=""
QUIT
Begin DoDot:2
+49 IF $GET(BKSTIY(INC,TYP,0))'=""
QUIT
+50 SET TOTNS=TOTNS+$PIECE(BKSTIY(INC,TYP),U,1)
+51 SET TOTSD=TOTSD+$PIECE(BKSTIY(INC,TYP),U,2)
+52 SET TOTRF=TOTRF+$PIECE(BKSTIY(INC,TYP),U,3)
End DoDot:2
End DoDot:1
+53 ;
+54 SET BKSTIY(0)=TOTIN_U_TOTNS_U_TOTSD_U_TOTRF_U_TOTGD_U_TOTGN_U_TOTGR
+55 KILL BKSTIN
+56 ;TOTIN = Total number of incidences
+57 ;TOTNS = Total number of screenings needed
+58 ;TOTSD = Total number of screenings done
+59 ;TOTRF = Total number of refusals
+60 ;TOTGD = Total number of 'grouped' denominators
+61 ;TOTGN = Total number of 'grouped' numerators
+62 ;TOTGR = Total number of 'grouped' refusals
+63 QUIT
+64 ;
INC ;EP - Determine multiple incidences
+1 NEW TYP,DAT,INC,PDAT,NXDT,NTYP,DTDIF,NM
+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)
+8 SET NNUM=0
SET NM=""
+9 FOR
SET NM=$ORDER(BKARRAY(TYP,"NUM",NM))
IF NM=""
QUIT
IF $GET(BKARRAY(TYP,"NUM",NM))'=0
SET NNUM=NNUM+1
+10 SET ZARRAY("ZN",DAT,TYP)=NNUM
+11 SET RF=""
+12 FOR
SET RF=$ORDER(BKARRAY(TYP,"REF",RF))
IF RF=""
QUIT
SET RDT=""
FOR
SET RDT=$ORDER(BKARRAY(TYP,"REF",RF,RDT))
IF RDT=""
QUIT
SET ZARRAY("ZR",RDT,RF)=0
End DoDot:2
End DoDot:1
+13 ;
+14 SET INC=0
SET DAT=""
SET PDAT=""
+15 FOR
SET DAT=$ORDER(MBKARAY(DAT))
IF DAT=""
QUIT
Begin DoDot:1
+16 SET INC=INC+1
DO SDT(DAT)
KILL MBKARAY(DAT)
+17 ;S DTDIF=$$FMADD^XLFDT(DAT,60)
+18 SET DTDIF=$$FMADD^XLFDT(DAT,(30.4167*2))
+19 SET NXDT=DAT
FOR
SET NXDT=$ORDER(MBKARAY(NXDT))
IF NXDT=""
QUIT
Begin DoDot:2
+20 IF NXDT<DTDIF
Begin DoDot:3
+21 SET MTYP=$ORDER(BKSTIN(INC,""))
+22 DO SDT(NXDT)
+23 KILL MBKARAY(NXDT)
End DoDot:3
End DoDot:2
End DoDot:1
+24 QUIT
+25 ;
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 IF $GET(MTYP)'=""
IF MTYP=TYP
QUIT
+4 IF $GET(MTYP)'=""
IF MTYP'=TYP
SET INC=INC+1
+5 SET BKSTIN(INC,TYP,VDT)=MBKARAY(VDT,TYP)
End DoDot:1
+6 QUIT
+7 ;
NG(NIN,NTYP) ;
+1 NEW BKN,BN,BSN,NKSTY,NKNUM,NKREF
+2 SET BKN=$ORDER(^BKM(90454,"D",NTYP,""))
+3 SET BN=0
SET NKNUM=0
SET NKREF=0
+4 IF $GET(IHVDFL)=1
SET NKNUM=1
+5 FOR
SET BN=$ORDER(^BKM(90454,BKN,10,BN))
IF 'BN
QUIT
Begin DoDot:1
+6 SET BSN=$PIECE(^BKM(90454,BKN,10,BN,0),"^",1)
+7 SET NKSTY=$PIECE(^BKM(90454,BSN,0),"^",3)
+8 SET NKNUM=$PIECE($GET(BKSTIY(NIN,NKSTY)),"^",2)+NKNUM
+9 SET NKREF=$PIECE($GET(BKSTIY(NIN,NKSTY)),"^",3)+NKREF
End DoDot:1
+10 SET NNUM(NIN)=$SELECT(NKNUM=3:1,1:0)
+11 SET NREF(NIN)=$SELECT(NKREF>0&((NKREF+NKNUM)=3):1,1:0)
+12 QUIT
