BISCAN ;IHS/CMI/MWR - SCAN PATIENT DB FOR <36 MTHS, ADD TO IMM DB; MAY 10, 2010
;;8.5;IMMUNIZATION;;SEP 01,2011
;;* MICHAEL REMILLARD, DDS * CIMARRON MEDICAL INFORMATICS, FOR IHS *
;; SCAN PATIENT DATABASE FOR PATIENTS <36 MTHS NOT IN IMM DB.
;; PATCH 1: Correct Age Range in report from 1-36 to 0-35. REVIEW+9
;; Also disabled PREVINA (no longer stuffing previously inactive).
;; Also "please hold..." prompt while getting patient total. SCAN+11
;; Also do not add patient if Ineligible in Registration. SCAN+40
;
;----------
START ;EP
;---> Scan for patients in ^AUPNPAT <36 mths not in Imm database ^BIP.
;
D SETVARS^BIUTL5 S BIPOP=0 N BICC
D
.D PROMPT(.BICC,.BIPOP) Q:BIPOP
.Q:BIPOP
.D SCAN(.BICC,.BIPOP) Q:BIPOP
.D REVIEW
D EXIT(BIPOP)
Q
;
;
;----------
PROMPT(BICC,BIPOP) ;EP
;---> Describe conversion.
; 1 - BICC (ret) Current Community array.
; 2 - 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
;
;---> Current Community.
D CC^BIOUTPT(.BICC,"BISCAN",.BIPOP)
Q:BIPOP
;
D TITLE W !!
D DIR^BIFMAN("Y",.Y,.BIPOP," Do you wish to continue with the Scan",Z)
Q:BIPOP
S:Y<1 BIPOP=1
Q
;
;
;----------
RESET ;EP
;---> To satisfy return from call to BIOUTPT.
Q
;
;
;----------
SCAN(BICC,BIPOP) ;EP
;---> Convert patients to new file/register.
; 1 - BICC (ret) Current Community array.
; 2 - BIPOP (ret) BIPOP=1 If quit, fail, DTOUT, DUOUT.
;
K ^BITMP($J)
N BIERR,BIFACT,BIX,BIY,N
;
;---> Check for DUZ(2).
I '$G(DUZ(2)) D ERRCD^BIUTL2(105,,1) Q
;
;********** PATCH 1, SEP 21,2006, IHS/CMI/MWR
;---> Hold prompt while getting total patient count.
W !!?12,"Please hold..."
;**********
;
;
S N=0 F S N=$O(^AUPNPAT(N)) Q:'N S BIFACT=N
S:BIFACT<1 BIFACT=1 S BIFACT=BIFACT\50
S (BIPOP,BIX,BIY)=0
;
D TITLE
W !!?12,"Converting Patients to the new Register..."
W !!?12,"0%---10---20---30---40---50---60---70---80---90---100%"
W !?12,"|"
;
;---> Loop through the RPMS Patient global, adding to
;---> new BI Patient global.
;---> * Consider using DOB xref (time versus reliability?).
S BIDFN=0,BIPATS=0
F S BIDFN=$O(^AUPNPAT(BIDFN)) Q:'BIDFN Q:$G(BIERR)]"" D
.;
.;---> Display bar graph of progress.
.S BIX=BIX+1 I BIFACT,'(BIX#BIFACT)&(BIY<51) W "=" S BIY=BIY+1
.;
.;---> Quit if this patient already exists in the Imm Patient File.
.Q:$D(^BIP(BIDFN,0))
.;---> Quit if patient does not have an Active Chart at this site.
.Q:$$INACTREG^BIUTL1(BIDFN,DUZ(2))
.;
.;********** PATCH 1, SEP 21,2006, IHS/CMI/MWR
.;---> Quit if patient is Ineligible in RPMS Registration.
.Q:$$INELIG^BIUTL1(BIDFN)
.;**********
.;
.;---> Quit if patient is not less than 36 months.
.Q:($$AGE^BIUTL1(BIDFN,2,$G(DT))>35)
.;---> Quit if patient is deceased.
.Q:$$DECEASED^BIUTL1(BIDFN)
.;---> Quit If patient does not have one of the selected Current Communities.
.Q:$$CURCOM^BIEXPRT2(BIDFN,.BICC)
.;
.;---> Add patient to ^BIP Imm Database.
.D ADD(BIDFN,.BIPATS,.BIERR)
;
I $G(BIERR)]"" W !!?3,BIERR D DIRZ^BIUTL3() Q
;
;---> Update Zero Node of BI PATIENT File #9002084.
N M,N S (L,N,T)=0 F S N=$O(^BIP(N)) Q:'N S L=N,T=T+1
S $P(^BIP(0),U,3,4)=L_U_T
;
N BII F BII=1:1:50-BIY W "="
W "|",!?33,"Complete"
W !!?12,"Patients added to the new Immunization Register: ",BIPATS
W !!?12,"Total Patients in the new Immunization Register....: ",T
W !!!!!! D DIRZ^BIUTL3(.BIPOP) Q:BIPOP
;
Q
;
;
;----------
ADD(BIDFN,BIPATS,BIERR) ;EP
;---> Add patient to new Immunization database.
;---> Parameters:
; 1 - BIDFN (req) Patient's IEN in VA PATIENT File #2.
; 2 - BIPATS (opt) Bookeeper node, total patients in ^BIP(0)
; 3 - BIERR (ret) Error text, if any.
;
Q:'$D(^AUPNPAT(BIDFN,0))
S:'$D(BIPATS) BIPATS=0
;
D ADDPAT^BIPATE(BIDFN,1665,.BIERR,,,1)
Q:($G(BIERR)]"")
S ^BITMP($J,BIDFN)="",BIPATS=BIPATS+1
Q
;
;
;----------
REVIEW ;EP
;---> Review/Print List of Patients automatically activated.
;
D TITLE,TEXT2 W !
N BIPOP S BIPOP=0
D DIR^BIFMAN("Y",.Y,.BIPOP," Review List of Auto Activated now")
Q:BIPOP
Q:Y<1
;
;********** PATCH 1, SEP 21,2006, IHS/CMI/MWR
;---> Correct Age Range in report from 1-36 to 0-35.
;K BICC S BIPG="5^^^^"_DT_":"_DT,BIAG="1-36"
K BICC S BIPG="5^^^^"_DT_":"_DT,BIAG="0-35"
;**********
;
D ^BIDU
Q
;
;
;----------
PREVINA ;EP
;---> Stuff "Previously Inactivated" in the .16 Field of the BI PATIENT
;---> File for any patients who were Inactive prior to v8.1.
;
;********** PATCH 1, SEP 21,2006, IHS/CMI/MWR
;---> No longer stuffing "Previously Inactivated".
Q
;**********
;
N N S N=0
F S N=$O(^BIP(N)) Q:'N D
.Q:'$P($G(^BIP(N,0)),"^",8)
.S $P(^BIP(N,0),"^",16)="p"
Q
;
;
;----------
TEXT1 ;EP
;;
;;This program will scan the RPMS Patient Database for children who
;;are less than 36 months old. Of those children, any who are not in
;;the Immunization Database and who live in one of the Communities
;;you select will be added to the Immunization Register.
;;
;;NOTE: This scan program, if interrupted, may be restarted at any time.
;; It may also be rerun at any time. It will not create duplicates.
;;
;;The next screen will provide an opportunity to select specific
;;communities from which patients will be scanned. (This is the
;;"Current Community" field in RPMS Patient Registration.) You will have
;;the opportunity to automatically use the GPRA set of communities.
;;
;;
;;
D PRINTX("TEXT1",5)
Q
;
;
;----------
TEXT2 ;EP
;;
;;You may review the list of Patients who have been Automatically
;;Activated today. Would you like to view that list now?
;;
;;
D PRINTX("TEXT2",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("SCAN FOR PATIENTS <36 MONTHS")
Q
BISCAN ;IHS/CMI/MWR - SCAN PATIENT DB FOR <36 MTHS, ADD TO IMM DB; MAY 10, 2010
+1 ;;8.5;IMMUNIZATION;;SEP 01,2011
+2 ;;* MICHAEL REMILLARD, DDS * CIMARRON MEDICAL INFORMATICS, FOR IHS *
+3 ;; SCAN PATIENT DATABASE FOR PATIENTS <36 MTHS NOT IN IMM DB.
+4 ;; PATCH 1: Correct Age Range in report from 1-36 to 0-35. REVIEW+9
+5 ;; Also disabled PREVINA (no longer stuffing previously inactive).
+6 ;; Also "please hold..." prompt while getting patient total. SCAN+11
+7 ;; Also do not add patient if Ineligible in Registration. SCAN+40
+8 ;
+9 ;----------
START ;EP
+1 ;---> Scan for patients in ^AUPNPAT <36 mths not in Imm database ^BIP.
+2 ;
+3 DO SETVARS^BIUTL5
SET BIPOP=0
NEW BICC
+4 Begin DoDot:1
+5 DO PROMPT(.BICC,.BIPOP)
IF BIPOP
QUIT
+6 IF BIPOP
QUIT
+7 DO SCAN(.BICC,.BIPOP)
IF BIPOP
QUIT
+8 DO REVIEW
End DoDot:1
+9 DO EXIT(BIPOP)
+10 QUIT
+11 ;
+12 ;
+13 ;----------
PROMPT(BICC,BIPOP) ;EP
+1 ;---> Describe conversion.
+2 ; 1 - BICC (ret) Current Community array.
+3 ; 2 - BIPOP (ret) BIPOP=1 If quit, fail, DTOUT, DUOUT.
+4 ;
+5 NEW Z
SET Z=""
SET BIPOP=0
SET Z="YES"
+6 DO TITLE
DO TEXT1
WRITE !
+7 DO DIRZ^BIUTL3(.BIPOP)
+8 IF BIPOP
QUIT
+9 ;
+10 ;---> Current Community.
+11 DO CC^BIOUTPT(.BICC,"BISCAN",.BIPOP)
+12 IF BIPOP
QUIT
+13 ;
+14 DO TITLE
WRITE !!
+15 DO DIR^BIFMAN("Y",.Y,.BIPOP," Do you wish to continue with the Scan",Z)
+16 IF BIPOP
QUIT
+17 IF Y<1
SET BIPOP=1
+18 QUIT
+19 ;
+20 ;
+21 ;----------
RESET ;EP
+1 ;---> To satisfy return from call to BIOUTPT.
+2 QUIT
+3 ;
+4 ;
+5 ;----------
SCAN(BICC,BIPOP) ;EP
+1 ;---> Convert patients to new file/register.
+2 ; 1 - BICC (ret) Current Community array.
+3 ; 2 - BIPOP (ret) BIPOP=1 If quit, fail, DTOUT, DUOUT.
+4 ;
+5 KILL ^BITMP($JOB)
+6 NEW BIERR,BIFACT,BIX,BIY,N
+7 ;
+8 ;---> Check for DUZ(2).
+9 IF '$GET(DUZ(2))
DO ERRCD^BIUTL2(105,,1)
QUIT
+10 ;
+11 ;********** PATCH 1, SEP 21,2006, IHS/CMI/MWR
+12 ;---> Hold prompt while getting total patient count.
+13 WRITE !!?12,"Please hold..."
+14 ;**********
+15 ;
+16 ;
+17 SET N=0
FOR
SET N=$ORDER(^AUPNPAT(N))
IF 'N
QUIT
SET BIFACT=N
+18 IF BIFACT<1
SET BIFACT=1
SET BIFACT=BIFACT\50
+19 SET (BIPOP,BIX,BIY)=0
+20 ;
+21 DO TITLE
+22 WRITE !!?12,"Converting Patients to the new Register..."
+23 WRITE !!?12,"0%---10---20---30---40---50---60---70---80---90---100%"
+24 WRITE !?12,"|"
+25 ;
+26 ;---> Loop through the RPMS Patient global, adding to
+27 ;---> new BI Patient global.
+28 ;---> * Consider using DOB xref (time versus reliability?).
+29 SET BIDFN=0
SET BIPATS=0
+30 FOR
SET BIDFN=$ORDER(^AUPNPAT(BIDFN))
IF 'BIDFN
QUIT
IF $GET(BIERR)]""
QUIT
Begin DoDot:1
+31 ;
+32 ;---> Display bar graph of progress.
+33 SET BIX=BIX+1
IF BIFACT
IF '(BIX#BIFACT)&(BIY<51)
WRITE "="
SET BIY=BIY+1
+34 ;
+35 ;---> Quit if this patient already exists in the Imm Patient File.
+36 IF $DATA(^BIP(BIDFN,0))
QUIT
+37 ;---> Quit if patient does not have an Active Chart at this site.
+38 IF $$INACTREG^BIUTL1(BIDFN,DUZ(2))
QUIT
+39 ;
+40 ;********** PATCH 1, SEP 21,2006, IHS/CMI/MWR
+41 ;---> Quit if patient is Ineligible in RPMS Registration.
+42 IF $$INELIG^BIUTL1(BIDFN)
QUIT
+43 ;**********
+44 ;
+45 ;---> Quit if patient is not less than 36 months.
+46 IF ($$AGE^BIUTL1(BIDFN,2,$GET(DT))>35)
QUIT
+47 ;---> Quit if patient is deceased.
+48 IF $$DECEASED^BIUTL1(BIDFN)
QUIT
+49 ;---> Quit If patient does not have one of the selected Current Communities.
+50 IF $$CURCOM^BIEXPRT2(BIDFN,.BICC)
QUIT
+51 ;
+52 ;---> Add patient to ^BIP Imm Database.
+53 DO ADD(BIDFN,.BIPATS,.BIERR)
End DoDot:1
+54 ;
+55 IF $GET(BIERR)]""
WRITE !!?3,BIERR
DO DIRZ^BIUTL3()
QUIT
+56 ;
+57 ;---> Update Zero Node of BI PATIENT File #9002084.
+58 NEW M,N
SET (L,N,T)=0
FOR
SET N=$ORDER(^BIP(N))
IF 'N
QUIT
SET L=N
SET T=T+1
+59 SET $PIECE(^BIP(0),U,3,4)=L_U_T
+60 ;
+61 NEW BII
FOR BII=1:1:50-BIY
WRITE "="
+62 WRITE "|",!?33,"Complete"
+63 WRITE !!?12,"Patients added to the new Immunization Register: ",BIPATS
+64 WRITE !!?12,"Total Patients in the new Immunization Register....: ",T
+65 WRITE !!!!!!
DO DIRZ^BIUTL3(.BIPOP)
IF BIPOP
QUIT
+66 ;
+67 QUIT
+68 ;
+69 ;
+70 ;----------
ADD(BIDFN,BIPATS,BIERR) ;EP
+1 ;---> Add patient to new Immunization database.
+2 ;---> Parameters:
+3 ; 1 - BIDFN (req) Patient's IEN in VA PATIENT File #2.
+4 ; 2 - BIPATS (opt) Bookeeper node, total patients in ^BIP(0)
+5 ; 3 - BIERR (ret) Error text, if any.
+6 ;
+7 IF '$DATA(^AUPNPAT(BIDFN,0))
QUIT
+8 IF '$DATA(BIPATS)
SET BIPATS=0
+9 ;
+10 DO ADDPAT^BIPATE(BIDFN,1665,.BIERR,,,1)
+11 IF ($GET(BIERR)]"")
QUIT
+12 SET ^BITMP($JOB,BIDFN)=""
SET BIPATS=BIPATS+1
+13 QUIT
+14 ;
+15 ;
+16 ;----------
REVIEW ;EP
+1 ;---> Review/Print List of Patients automatically activated.
+2 ;
+3 DO TITLE
DO TEXT2
WRITE !
+4 NEW BIPOP
SET BIPOP=0
+5 DO DIR^BIFMAN("Y",.Y,.BIPOP," Review List of Auto Activated now")
+6 IF BIPOP
QUIT
+7 IF Y<1
QUIT
+8 ;
+9 ;********** PATCH 1, SEP 21,2006, IHS/CMI/MWR
+10 ;---> Correct Age Range in report from 1-36 to 0-35.
+11 ;K BICC S BIPG="5^^^^"_DT_":"_DT,BIAG="1-36"
+12 KILL BICC
SET BIPG="5^^^^"_DT_":"_DT
SET BIAG="0-35"
+13 ;**********
+14 ;
+15 DO ^BIDU
+16 QUIT
+17 ;
+18 ;
+19 ;----------
PREVINA ;EP
+1 ;---> Stuff "Previously Inactivated" in the .16 Field of the BI PATIENT
+2 ;---> File for any patients who were Inactive prior to v8.1.
+3 ;
+4 ;********** PATCH 1, SEP 21,2006, IHS/CMI/MWR
+5 ;---> No longer stuffing "Previously Inactivated".
+6 QUIT
+7 ;**********
+8 ;
+9 NEW N
SET N=0
+10 FOR
SET N=$ORDER(^BIP(N))
IF 'N
QUIT
Begin DoDot:1
+11 IF '$PIECE($GET(^BIP(N,0)),"^",8)
QUIT
+12 SET $PIECE(^BIP(N,0),"^",16)="p"
End DoDot:1
+13 QUIT
+14 ;
+15 ;
+16 ;----------
TEXT1 ;EP
+1 ;;
+2 ;;This program will scan the RPMS Patient Database for children who
+3 ;;are less than 36 months old. Of those children, any who are not in
+4 ;;the Immunization Database and who live in one of the Communities
+5 ;;you select will be added to the Immunization Register.
+6 ;;
+7 ;;NOTE: This scan program, if interrupted, may be restarted at any time.
+8 ;; It may also be rerun at any time. It will not create duplicates.
+9 ;;
+10 ;;The next screen will provide an opportunity to select specific
+11 ;;communities from which patients will be scanned. (This is the
+12 ;;"Current Community" field in RPMS Patient Registration.) You will have
+13 ;;the opportunity to automatically use the GPRA set of communities.
+14 ;;
+15 ;;
+16 ;;
+17 DO PRINTX("TEXT1",5)
+18 QUIT
+19 ;
+20 ;
+21 ;----------
TEXT2 ;EP
+1 ;;
+2 ;;You may review the list of Patients who have been Automatically
+3 ;;Activated today. Would you like to view that list now?
+4 ;;
+5 ;;
+6 DO PRINTX("TEXT2",5)
+7 QUIT
+8 ;
+9 ;
+10 ;----------
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("SCAN FOR PATIENTS <36 MONTHS")
+2 QUIT
