BIELIG3 ;IHS/CMI/MWR - SCAN TO REMOVE VFC FOR IMMS WITH PATS>19YRS; APR 15, 2012
;;8.5;IMMUNIZATION;**3**;SEP 10,2012
;;* MICHAEL REMILLARD, DDS * CIMARRON MEDICAL INFORMATICS, FOR IHS *
;; SCAN PATIENT DATABASE FOR PATIENTS <36 MTHS NOT IN IMM DB.
; PATCH 2: This is a completely new routine to scan for and correct any
; immunization visits in which the patient was 19yrs or older
; and erroneously marked as VFC Eligible at the time of the visit.
;
; PATCH 3: Scan for any V Imms with a .14 Eligibility=0, change to 8,
; which is the IEN of "Unknown" in the new BI TABLE ELIG File.
; Null values will be left null. SCAN+43
;
;----------
START ;EP
;---> Scan for patients in ^AUPNPAT <36 mths not in Imm database ^BIP.
;
D SETVARS^BIUTL5
D
.;D PROMPT(.BIPOP)
.;Q:BIPOP
.D SCAN
D EXIT(BIPOP)
Q
;
;
;----------
PROMPT(BIPOP) ;EP
;---> Describe conversion.
; 1 - BIPOP (ret) BIPOP=1 If quit, fail, DTOUT, DUOUT.
;
N Z S Z="",BIPOP=0,Z="YES"
D TITLE,TEXT1
W ! D DIRZ^BIUTL3(.BIPOP) Q:BIPOP
Q
;
;
;----------
SCAN ;EP
;---> Scan V Imm file of VFC Eligibility inappropriate age.
;
N BICOUNT,BIERR,BIFACT,BIX,BIY,N
;
;---> Check for DUZ(2).
I '$G(DUZ(2)) D ERRCD^BIUTL2(105,,1) Q
;
W !!?12,"Please hold..."
;
;---> Get total number of visits to be checked (for progress bar below).
S BIFACT=1
S N=3080901 F S N=$O(^AUPNVIMM("ADT",N)) Q:'N D
.N M S M=0 F S M=$O(^AUPNVIMM("ADT",N,M)) Q:'M D
..N P S P=0 F S P=$O(^AUPNVIMM("ADT",N,M,P)) Q:'P S BIFACT=BIFACT+1
;
S:BIFACT<1 BIFACT=1 S BIFACT=BIFACT\50
S (BIPOP,BIX,BIY)=0
;
D TITLE
W !!?12,"Repointing visits with Eligibility Unknown to new table..."
W !!?12,"0%---10---20---30---40---50---60---70---80---90---100%"
W !?12,"|"
;
;
;---> Loop through the V Imm global, looking for VFC=Am Indian/AK Native
;---> inappropriate for age (19yrs or greater) at time of visit.
;
; date visit vimm ien
;^AUPNVIMM("ADT",3071110,2102,2300)=""
;
; vac dfn visit vfc(pc14)
;^AUPNVIMM(2300,0)="133^6^2102^^^^^^^^^^^"
;
;^AUPNVSIT(2102,0)="3071110.12^3080508^I^^6^1665^E^^8^^^^3080508^
;
S N=3080901,BICOUNT=0
F S N=$O(^AUPNVIMM("ADT",N)) Q:'N D
.N M S M=0 F S M=$O(^AUPNVIMM("ADT",N,M)) Q:'M D
..N P S P=0 F S P=$O(^AUPNVIMM("ADT",N,M,P)) Q:'P D
...S BIX=BIX+1 I BIFACT,'(BIX#BIFACT)&(BIY<51) W "=" S BIY=BIY+1
...N BI0 S BI0=$G(^AUPNVIMM(P,0))
...Q:(BI0="")
...;********** PATCH 3, v8.5, SEP 10,2012, IHS/CMI/MWR
...;---> Repointing visits with Eligibility Unknown to new table.
...I $P(BI0,U,14)=0 S $P(^AUPNVIMM(P,0),U,14)=8
...Q
...;**********
...;
...;
...;---> Quit if Elig Code is not Am In/AK Na.
...;Q:($P(BI0,U,14)'=4)
...;N BIDATE,BIDFN S BIDATE=N,BIDFN=$P(BI0,U,2)
...;---> Quit if age on date of visit was less than 19yrs.
...;Q:($$AGE^BIUTL1(BIDFN,1,BIDATE)<19)
...;---> Okay, patient was 19yrs or greater and had Elig Code=4, so set
...;---> piece 14="" and update BICOUNT.
...;S $P(^AUPNVIMM(P,0),U,14)="",BICOUNT=BICOUNT+1
;
N BII F BII=1:1:50-BIY W "="
W "|",!?33,"Complete"
;W !!?12,"Immunization visits corrected for VFC Eligibility: ",BICOUNT
;W !!!!!! D DIRZ^BIUTL3(.BIPOP) Q:BIPOP
W !!!!!! D DIRZ^BIUTL3()
;
Q
;
;
;----------
CHGPTR(BICHG) ;EP
;---> Change all records with one vaccine pointer to a different one.
;---> Parameters:
; 1 - BICHG (opt) IF BICHG=1 then change entries from 214 to 235.
;
D SETVARS^BIUTL5
D KGBL^BIUTL8("^MIKE") S ^MIKE(0)=^AUPNVIMM(0)
N BICOUNT,BIECOUNT,BIN S BIN=0,BICOUNT=0,BIECOUNT=0
F S BIN=$O(^AUPNVIMM(BIN)) Q:'BIN D
.N BIERR S BIERR=0
.Q:($P(^AUPNVIMM(BIN,0),U)'=214)
.S BICOUNT=BICOUNT+1
.Q:('$G(BICHG))
.S ^MIKE(BIN,0)=^AUPNVIMM(BIN,0)
.;
.;---> Change .01 pointer to VAccine Table.
.N BIFLD S BIFLD(.01)=235
.D FDIE^BIFMAN(9000010.11,BIN,.BIFLD,.BIERR)
.I BIERR=1 S BIECOUNT=BIECOUNT+1,^MIKE("ERR",N)="" Q
;
W !!,"COUNT: ",BICOUNT
W !,"ERRORS: ",BIECOUNT
Q
;
;
;----------
TEXT1 ;EP
;;
;;This program will scan the immunizations recorded in RPMS from
;;September 2008 to the present for any VFC Eligibility Codes that
;;would have been inappropriate for the patient's age on the day of
;;the immunization visit.
;;
;;For any given immunization visit, if the patient was 19 years of age
;;or older and incorrectly recorded as VFC Eligible (American Indian or
;;Alaska Native), the Eligibility code for that visit will be permanently
;;removed. All other data will remain unchanged.
;;
;;This will prevent such visits from causing problems in future reports
;;and exports to state registries.
;;
;;NO other data or immunizations visits are changed by this process.
;;
D PRINTX("TEXT1",5)
Q
;
;
;----------
PRINTX(BILINL,BITAB) ;EP
Q:$G(BILINL)=""
N I,T,X S T="" S:'$D(BITAB) BITAB=5 F I=1:1:BITAB S T=T_" "
F I=1:1 S X=$T(@BILINL+I) Q:X'[";;" W !,T,$P(X,";;",2)
Q
;
;
;----------
EXIT(BIPOP) ;EP
;---> EOJ Cleanup.
;---> Parameters:
; 1 - BIPOP (opt) BIPOP=1 if DTOUT or DUOUT
;
D:$G(BIPOP)
.W !!?5,"* SCAN ABORTED. *" D DIRZ^BIUTL3()
N BIPOP
D KILLALL^BIUTL8(1)
Q
;
;
;----------
TITLE ;EP
D TITLE^BIUTL5("UPDATING VISITS WITH ELIGIBILITY UNKNOWN")
Q
BIELIG3 ;IHS/CMI/MWR - SCAN TO REMOVE VFC FOR IMMS WITH PATS>19YRS; APR 15, 2012
+1 ;;8.5;IMMUNIZATION;**3**;SEP 10,2012
+2 ;;* MICHAEL REMILLARD, DDS * CIMARRON MEDICAL INFORMATICS, FOR IHS *
+3 ;; SCAN PATIENT DATABASE FOR PATIENTS <36 MTHS NOT IN IMM DB.
+4 ; PATCH 2: This is a completely new routine to scan for and correct any
+5 ; immunization visits in which the patient was 19yrs or older
+6 ; and erroneously marked as VFC Eligible at the time of the visit.
+7 ;
+8 ; PATCH 3: Scan for any V Imms with a .14 Eligibility=0, change to 8,
+9 ; which is the IEN of "Unknown" in the new BI TABLE ELIG File.
+10 ; Null values will be left null. SCAN+43
+11 ;
+12 ;----------
START ;EP
+1 ;---> Scan for patients in ^AUPNPAT <36 mths not in Imm database ^BIP.
+2 ;
+3 DO SETVARS^BIUTL5
+4 Begin DoDot:1
+5 ;D PROMPT(.BIPOP)
+6 ;Q:BIPOP
+7 DO SCAN
End DoDot:1
+8 DO EXIT(BIPOP)
+9 QUIT
+10 ;
+11 ;
+12 ;----------
PROMPT(BIPOP) ;EP
+1 ;---> Describe conversion.
+2 ; 1 - BIPOP (ret) BIPOP=1 If quit, fail, DTOUT, DUOUT.
+3 ;
+4 NEW Z
SET Z=""
SET BIPOP=0
SET Z="YES"
+5 DO TITLE
DO TEXT1
+6 WRITE !
DO DIRZ^BIUTL3(.BIPOP)
IF BIPOP
QUIT
+7 QUIT
+8 ;
+9 ;
+10 ;----------
SCAN ;EP
+1 ;---> Scan V Imm file of VFC Eligibility inappropriate age.
+2 ;
+3 NEW BICOUNT,BIERR,BIFACT,BIX,BIY,N
+4 ;
+5 ;---> Check for DUZ(2).
+6 IF '$GET(DUZ(2))
DO ERRCD^BIUTL2(105,,1)
QUIT
+7 ;
+8 WRITE !!?12,"Please hold..."
+9 ;
+10 ;---> Get total number of visits to be checked (for progress bar below).
+11 SET BIFACT=1
+12 SET N=3080901
FOR
SET N=$ORDER(^AUPNVIMM("ADT",N))
IF 'N
QUIT
Begin DoDot:1
+13 NEW M
SET M=0
FOR
SET M=$ORDER(^AUPNVIMM("ADT",N,M))
IF 'M
QUIT
Begin DoDot:2
+14 NEW P
SET P=0
FOR
SET P=$ORDER(^AUPNVIMM("ADT",N,M,P))
IF 'P
QUIT
SET BIFACT=BIFACT+1
End DoDot:2
End DoDot:1
+15 ;
+16 IF BIFACT<1
SET BIFACT=1
SET BIFACT=BIFACT\50
+17 SET (BIPOP,BIX,BIY)=0
+18 ;
+19 DO TITLE
+20 WRITE !!?12,"Repointing visits with Eligibility Unknown to new table..."
+21 WRITE !!?12,"0%---10---20---30---40---50---60---70---80---90---100%"
+22 WRITE !?12,"|"
+23 ;
+24 ;
+25 ;---> Loop through the V Imm global, looking for VFC=Am Indian/AK Native
+26 ;---> inappropriate for age (19yrs or greater) at time of visit.
+27 ;
+28 ; date visit vimm ien
+29 ;^AUPNVIMM("ADT",3071110,2102,2300)=""
+30 ;
+31 ; vac dfn visit vfc(pc14)
+32 ;^AUPNVIMM(2300,0)="133^6^2102^^^^^^^^^^^"
+33 ;
+34 ;^AUPNVSIT(2102,0)="3071110.12^3080508^I^^6^1665^E^^8^^^^3080508^
+35 ;
+36 SET N=3080901
SET BICOUNT=0
+37 FOR
SET N=$ORDER(^AUPNVIMM("ADT",N))
IF 'N
QUIT
Begin DoDot:1
+38 NEW M
SET M=0
FOR
SET M=$ORDER(^AUPNVIMM("ADT",N,M))
IF 'M
QUIT
Begin DoDot:2
+39 NEW P
SET P=0
FOR
SET P=$ORDER(^AUPNVIMM("ADT",N,M,P))
IF 'P
QUIT
Begin DoDot:3
+40 SET BIX=BIX+1
IF BIFACT
IF '(BIX#BIFACT)&(BIY<51)
WRITE "="
SET BIY=BIY+1
+41 NEW BI0
SET BI0=$GET(^AUPNVIMM(P,0))
+42 IF (BI0="")
QUIT
+43 ;********** PATCH 3, v8.5, SEP 10,2012, IHS/CMI/MWR
+44 ;---> Repointing visits with Eligibility Unknown to new table.
+45 IF $PIECE(BI0,U,14)=0
SET $PIECE(^AUPNVIMM(P,0),U,14)=8
+46 QUIT
+47 ;**********
+48 ;
+49 ;
+50 ;---> Quit if Elig Code is not Am In/AK Na.
+51 ;Q:($P(BI0,U,14)'=4)
+52 ;N BIDATE,BIDFN S BIDATE=N,BIDFN=$P(BI0,U,2)
+53 ;---> Quit if age on date of visit was less than 19yrs.
+54 ;Q:($$AGE^BIUTL1(BIDFN,1,BIDATE)<19)
+55 ;---> Okay, patient was 19yrs or greater and had Elig Code=4, so set
+56 ;---> piece 14="" and update BICOUNT.
+57 ;S $P(^AUPNVIMM(P,0),U,14)="",BICOUNT=BICOUNT+1
End DoDot:3
End DoDot:2
End DoDot:1
+58 ;
+59 NEW BII
FOR BII=1:1:50-BIY
WRITE "="
+60 WRITE "|",!?33,"Complete"
+61 ;W !!?12,"Immunization visits corrected for VFC Eligibility: ",BICOUNT
+62 ;W !!!!!! D DIRZ^BIUTL3(.BIPOP) Q:BIPOP
+63 WRITE !!!!!!
DO DIRZ^BIUTL3()
+64 ;
+65 QUIT
+66 ;
+67 ;
+68 ;----------
CHGPTR(BICHG) ;EP
+1 ;---> Change all records with one vaccine pointer to a different one.
+2 ;---> Parameters:
+3 ; 1 - BICHG (opt) IF BICHG=1 then change entries from 214 to 235.
+4 ;
+5 DO SETVARS^BIUTL5
+6 DO KGBL^BIUTL8("^MIKE")
SET ^MIKE(0)=^AUPNVIMM(0)
+7 NEW BICOUNT,BIECOUNT,BIN
SET BIN=0
SET BICOUNT=0
SET BIECOUNT=0
+8 FOR
SET BIN=$ORDER(^AUPNVIMM(BIN))
IF 'BIN
QUIT
Begin DoDot:1
+9 NEW BIERR
SET BIERR=0
+10 IF ($PIECE(^AUPNVIMM(BIN,0),U)'=214)
QUIT
+11 SET BICOUNT=BICOUNT+1
+12 IF ('$GET(BICHG))
QUIT
+13 SET ^MIKE(BIN,0)=^AUPNVIMM(BIN,0)
+14 ;
+15 ;---> Change .01 pointer to VAccine Table.
+16 NEW BIFLD
SET BIFLD(.01)=235
+17 DO FDIE^BIFMAN(9000010.11,BIN,.BIFLD,.BIERR)
+18 IF BIERR=1
SET BIECOUNT=BIECOUNT+1
SET ^MIKE("ERR",N)=""
QUIT
End DoDot:1
+19 ;
+20 WRITE !!,"COUNT: ",BICOUNT
+21 WRITE !,"ERRORS: ",BIECOUNT
+22 QUIT
+23 ;
+24 ;
+25 ;----------
TEXT1 ;EP
+1 ;;
+2 ;;This program will scan the immunizations recorded in RPMS from
+3 ;;September 2008 to the present for any VFC Eligibility Codes that
+4 ;;would have been inappropriate for the patient's age on the day of
+5 ;;the immunization visit.
+6 ;;
+7 ;;For any given immunization visit, if the patient was 19 years of age
+8 ;;or older and incorrectly recorded as VFC Eligible (American Indian or
+9 ;;Alaska Native), the Eligibility code for that visit will be permanently
+10 ;;removed. All other data will remain unchanged.
+11 ;;
+12 ;;This will prevent such visits from causing problems in future reports
+13 ;;and exports to state registries.
+14 ;;
+15 ;;NO other data or immunizations visits are changed by this process.
+16 ;;
+17 DO PRINTX("TEXT1",5)
+18 QUIT
+19 ;
+20 ;
+21 ;----------
PRINTX(BILINL,BITAB) ;EP
+1 IF $GET(BILINL)=""
QUIT
+2 NEW I,T,X
SET T=""
IF '$DATA(BITAB)
SET BITAB=5
FOR I=1:1:BITAB
SET T=T_" "
+3 FOR I=1:1
SET X=$TEXT(@BILINL+I)
IF X'[";;"
QUIT
WRITE !,T,$PIECE(X,";;",2)
+4 QUIT
+5 ;
+6 ;
+7 ;----------
EXIT(BIPOP) ;EP
+1 ;---> EOJ Cleanup.
+2 ;---> Parameters:
+3 ; 1 - BIPOP (opt) BIPOP=1 if DTOUT or DUOUT
+4 ;
+5 IF $GET(BIPOP)
Begin DoDot:1
+6 WRITE !!?5,"* SCAN ABORTED. *"
DO DIRZ^BIUTL3()
End DoDot:1
+7 NEW BIPOP
+8 DO KILLALL^BIUTL8(1)
+9 QUIT
+10 ;
+11 ;
+12 ;----------
TITLE ;EP
+1 DO TITLE^BIUTL5("UPDATING VISITS WITH ELIGIBILITY UNKNOWN")
+2 QUIT
