BIPATE ;IHS/CMI/MWR - PATIENT CASE DATA EDIT; MAY 10, 2010
;;8.5;IMMUNIZATION;;SEP 01,2011
;;* MICHAEL REMILLARD, DDS * CIMARRON MEDICAL INFORMATICS, FOR IHS *
;; EDIT PATIENT CASE DATA.
;
;
;----------
MAIN ;EP
;---> Not called from Menus.
D SETVARS^BIUTL5
F D PATIENT Q:BIPOP
;
EXIT ;EP
D KILLALL^BIUTL8(1)
Q
;
;
;----------
PATIENT ;EP
D TITLE^BIUTL5("EDIT PATIENT CASE DATA")
;
PATIENT1 ;EP
;---> To avoid @IOF and title.
;---> Select Patient.
N Y S Y=""
W !!," Select the patient you wish to add or edit."
D PATLKUP^BIUTL8(.BIDFN,"ADD",DUZ(2),.BIPOP)
Q:BIPOP
I BIDFN<0 S BIPOP=1 Q
S BIDFN=+BIDFN
;---> Quit if this patient is Locked (being edited by another user).
L +^BIP(BIDFN):1 I '$T D ERRCD^BIUTL2(212,.BIERR) Q
;---> If called from here, do not do HDR & INIT in ^BIPATVW.
D SCREEN(BIDFN) S BIPOP=0
L -^BIP($G(BIDFN))
Q
;
;
;----------
SCREEN(BIDFN) ;EP
;---> Edit Patient Case Data with Screenman.
;---> Parameters:
; 1 - BIDFN (req) Patient's IEN in VA PATIENT File #2.
;
;---> If <STKOV> errors appear here, increase STACK in SYSGEN,
;---> System Configuration Parameters.
;
;---> Quit if BIDFN not provided.
I '$G(BIDFN) D ERRCD^BIUTL2(206,,1)
;
;---> Gather Case Data for this Patient to load for Screenman edit.
N Y S Y=""
D CASEDAT^BIRPC5(.Y,BIDFN) ;EP
;
;---> If an error is passed back, display it and quit.
N BI31,BIRETERR S BI31=$C(31)_$C(31)
S BIRETERR=$P(Y,BI31,2)
I BIRETERR]"" D EN^DDIOL("* "_BIRETERR,"","!!?5"),DIRZ^BIUTL3() Q
S Y=$P(Y,BI31)
;
;---> Build BI array for Case Data edit via Screenman.
N BI
S BI("A")=+BIDFN ;Patient DFN.
S BI("B")=$P(Y,U) ;Case Manager's name, text.
S BI("C")=$P(Y,U,2) ;Parent or Guardian, text.
S BI("D")=$P(Y,U,3) ;Mother's HBsAG Status (P,N,A,U).
S BI("E")=$P(Y,U,4) ;Date Patient became Inactive (DD-Mmm-YYYY).
S BI("F")=$P(Y,U,5) ;Reason for Inactive.
S BI("G")=$P(Y,U,6) ;Other Info.
S BI("H")=$P(Y,U,7) ;Forecast Influenza/Pneumococcal.
S BI("I")=$P(Y,U,8) ;Location Moved or Tx Elsewhere.
S BI("K")=$P(Y,U,9) ;State Registry Consent, 1=YES, 0/""=NO.
;
N DR S DR="[BI FORM-CASE DATA EDIT]"
D DDS^BIFMAN(9002084,DR,BIDFN,"","",.BIPOP)
Q
;
;
;----------
AUTOADD(BIDFN,BISITE,BIERR,BINACT) ;PEP - Automatically add a Patient to the Imm DB.
;---> Automatically add a Patient to the Imm Register.
;---> If an Inactive Date is passed, Patient will be added as Inactive today.
;---> If no Inactive Date is passed and the Patient is under 36 months of age
;---> and has a Current Community in the GPRA Set of Communities (defined by
;---> Imm Manager under Edit Site Parameters), or if the Patient has NO Current
;---> Cummunity set yet, then the Patient will be added as Active.
;---> Otherwise the Patient is added as Inactive.
;---> Parameters:
; 1 - BIDFN (req) Patient's IEN in VA PATIENT File #2.
; 2 - BISITE (req) DUZ(2) for default Case Manager.
; 3 - BIERR (ret) Error text, if any.
; 4 - BINACT (opt) Fileman internal date Patient became Inactive.
;
;---> Check for valid Patient.
I '$G(BIDFN) D ERRCD^BIUTL2(201,.BIERR) Q
I '$D(^AUPNPAT(BIDFN,0)) D ERRCD^BIUTL2(203,.BIERR) Q
;---> Check for valid Site.
S:'$G(BISITE) BISITE=$G(DUZ(2))
I '$G(BISITE) D ERRCD^BIUTL2(105,.BIERR) Q
;
N BINACTR S BINACTR=""
D
.;---> Forced Inactive by passing Inactive Date.
.I $G(BINACT) S BINACTR="n" Q
.;---> Under 36 mths and in GPRA, this patient will be Active.
.;I $$AGE^BIUTL1(BIDFN,2)<36,$$ISGPRA^BIUTL11(BIDFN,BISITE) Q
.N BIAGE S BIAGE=$$AGE^BIUTL1(BIDFN,2)
.;---> Request by Amy Groom:
.;---> If under 36 mths and patient has NO Cur Community, add as Active.
.I BIAGE<36,'$$CURCOM^BIUTL11(BIDFN) Q
.I BIAGE<36,$$ISGPRA^BIUTL11(BIDFN,BISITE) Q
.;---> Older than 36 mths or not in GPRA, this patient will be Inactive
.;---> as of today with a Reason of "Never Activated."
.S BINACT=$G(DT),BINACTR="n"
;
D ADDPAT(BIDFN,BISITE,.BIERR,$G(BINACT),BINACTR,1)
Q
;
;
;----------
ADDPAT(BIDFN,BISITE,BIERR,BINACT,BINACTR,BIAUTO) ;PEP Add a Patient to Imm DB
;---> Add new Patient to Immunization Database (BI PATIENT File).
;---> Sets Case Manger to Site Parameter default.
;---> Also records User and date first entered.
;---> Called by AGZIMM at ANMC to add newborns from RPMS Registration.
;---> Parameters:
; 1 - BIDFN (req) Patient's IEN in VA PATIENT File #2.
; 2 - BISITE (req) DUZ(2) for default Case Manager.
; 3 - BIERR (ret) Error text, if any.
; 4 - BINACT (opt) Fileman internal date Patient became Inactive.
; 5 - BINACTR (opt) Internal code for Inactive Reason:
; m:Moved Elsewhere, t:Treatment Elsewhere, d:Deceased
; p:Previously Inactivated, n:Never Activated
; 6 - BIAUTO (opt) If BIAUTO=1, set Field# .22="Automatically" added.
;
; Example: D AUTOADD^BIPATE(BIDFN,1665,.X,DT,"n")
;
;---> If BIDFN not provided, return error and quit.
I '$G(BIDFN) D ERRCD^BIUTL2(201,.BIERR) Q
;
;---> If Patient is already in the Imm Database, return error and quit.
I $D(^BIP(BIDFN,0)) D ERRCD^BIUTL2(218,.BIERR) Q
;
;---> If no Site IEN was passed, try to get it from local symbol table.
S:'$G(BISITE) BISITE=$G(DUZ(2))
;---> If BISITE not provided, return error and quit.
I '$G(BISITE) D ERRCD^BIUTL2(105,.BIERR) Q
;
;---> If Default Case Manager is INACTIVE, return error and quit.
N BICMGR S BICMGR=$$CMGRDEF^BIUTL2(BISITE)
I BICMGR,$$CMGRACT^BIUTL2(BICMGR) D ERRCD^BIUTL2(214,.BIERR) Q
;
;---> Trim time from BINACT (seed if necessary).
S BINACT=$P($G(BINACT),".") S:BINACT<2000000 BINACT=""
;
;---> Check/set Inactive reason.
S:"mtdpn"'[$E($G(BINACTR)) BINACTR=""
S:'BINACT BINACTR=""
;
N BIERR,BIFLD,BIIEN
S BIIEN(1)=BIDFN
S BIFLD(.01)=BIDFN
S BIFLD(.08)=BINACT
S BIFLD(.1)=BICMGR
S BIFLD(.16)=BINACTR
S BIFLD(.2)=$G(DUZ)
S BIFLD(.21)=$G(DT)
S BIFLD(.22)=$S($G(BIAUTO):1,1:"")
D UPDATE^BIFMAN(9002084,.BIIEN,.BIFLD,.BIERR)
I $G(BIERR)]"" W !!?3,BIERR D DIRZ^BIUTL3()
Q
BIPATE ;IHS/CMI/MWR - PATIENT CASE DATA EDIT; MAY 10, 2010
+1 ;;8.5;IMMUNIZATION;;SEP 01,2011
+2 ;;* MICHAEL REMILLARD, DDS * CIMARRON MEDICAL INFORMATICS, FOR IHS *
+3 ;; EDIT PATIENT CASE DATA.
+4 ;
+5 ;
+6 ;----------
MAIN ;EP
+1 ;---> Not called from Menus.
+2 DO SETVARS^BIUTL5
+3 FOR
DO PATIENT
IF BIPOP
QUIT
+4 ;
EXIT ;EP
+1 DO KILLALL^BIUTL8(1)
+2 QUIT
+3 ;
+4 ;
+5 ;----------
PATIENT ;EP
+1 DO TITLE^BIUTL5("EDIT PATIENT CASE DATA")
+2 ;
PATIENT1 ;EP
+1 ;---> To avoid @IOF and title.
+2 ;---> Select Patient.
+3 NEW Y
SET Y=""
+4 WRITE !!," Select the patient you wish to add or edit."
+5 DO PATLKUP^BIUTL8(.BIDFN,"ADD",DUZ(2),.BIPOP)
+6 IF BIPOP
QUIT
+7 IF BIDFN<0
SET BIPOP=1
QUIT
+8 SET BIDFN=+BIDFN
+9 ;---> Quit if this patient is Locked (being edited by another user).
+10 LOCK +^BIP(BIDFN):1
IF '$TEST
DO ERRCD^BIUTL2(212,.BIERR)
QUIT
+11 ;---> If called from here, do not do HDR & INIT in ^BIPATVW.
+12 DO SCREEN(BIDFN)
SET BIPOP=0
+13 LOCK -^BIP($GET(BIDFN))
+14 QUIT
+15 ;
+16 ;
+17 ;----------
SCREEN(BIDFN) ;EP
+1 ;---> Edit Patient Case Data with Screenman.
+2 ;---> Parameters:
+3 ; 1 - BIDFN (req) Patient's IEN in VA PATIENT File #2.
+4 ;
+5 ;---> If <STKOV> errors appear here, increase STACK in SYSGEN,
+6 ;---> System Configuration Parameters.
+7 ;
+8 ;---> Quit if BIDFN not provided.
+9 IF '$GET(BIDFN)
DO ERRCD^BIUTL2(206,,1)
+10 ;
+11 ;---> Gather Case Data for this Patient to load for Screenman edit.
+12 NEW Y
SET Y=""
+13 ;EP
DO CASEDAT^BIRPC5(.Y,BIDFN)
+14 ;
+15 ;---> If an error is passed back, display it and quit.
+16 NEW BI31,BIRETERR
SET BI31=$CHAR(31)_$CHAR(31)
+17 SET BIRETERR=$PIECE(Y,BI31,2)
+18 IF BIRETERR]""
DO EN^DDIOL("* "_BIRETERR,"","!!?5")
DO DIRZ^BIUTL3()
QUIT
+19 SET Y=$PIECE(Y,BI31)
+20 ;
+21 ;---> Build BI array for Case Data edit via Screenman.
+22 NEW BI
+23 ;Patient DFN.
SET BI("A")=+BIDFN
+24 ;Case Manager's name, text.
SET BI("B")=$PIECE(Y,U)
+25 ;Parent or Guardian, text.
SET BI("C")=$PIECE(Y,U,2)
+26 ;Mother's HBsAG Status (P,N,A,U).
SET BI("D")=$PIECE(Y,U,3)
+27 ;Date Patient became Inactive (DD-Mmm-YYYY).
SET BI("E")=$PIECE(Y,U,4)
+28 ;Reason for Inactive.
SET BI("F")=$PIECE(Y,U,5)
+29 ;Other Info.
SET BI("G")=$PIECE(Y,U,6)
+30 ;Forecast Influenza/Pneumococcal.
SET BI("H")=$PIECE(Y,U,7)
+31 ;Location Moved or Tx Elsewhere.
SET BI("I")=$PIECE(Y,U,8)
+32 ;State Registry Consent, 1=YES, 0/""=NO.
SET BI("K")=$PIECE(Y,U,9)
+33 ;
+34 NEW DR
SET DR="[BI FORM-CASE DATA EDIT]"
+35 DO DDS^BIFMAN(9002084,DR,BIDFN,"","",.BIPOP)
+36 QUIT
+37 ;
+38 ;
+39 ;----------
AUTOADD(BIDFN,BISITE,BIERR,BINACT) ;PEP - Automatically add a Patient to the Imm DB.
+1 ;---> Automatically add a Patient to the Imm Register.
+2 ;---> If an Inactive Date is passed, Patient will be added as Inactive today.
+3 ;---> If no Inactive Date is passed and the Patient is under 36 months of age
+4 ;---> and has a Current Community in the GPRA Set of Communities (defined by
+5 ;---> Imm Manager under Edit Site Parameters), or if the Patient has NO Current
+6 ;---> Cummunity set yet, then the Patient will be added as Active.
+7 ;---> Otherwise the Patient is added as Inactive.
+8 ;---> Parameters:
+9 ; 1 - BIDFN (req) Patient's IEN in VA PATIENT File #2.
+10 ; 2 - BISITE (req) DUZ(2) for default Case Manager.
+11 ; 3 - BIERR (ret) Error text, if any.
+12 ; 4 - BINACT (opt) Fileman internal date Patient became Inactive.
+13 ;
+14 ;---> Check for valid Patient.
+15 IF '$GET(BIDFN)
DO ERRCD^BIUTL2(201,.BIERR)
QUIT
+16 IF '$DATA(^AUPNPAT(BIDFN,0))
DO ERRCD^BIUTL2(203,.BIERR)
QUIT
+17 ;---> Check for valid Site.
+18 IF '$GET(BISITE)
SET BISITE=$GET(DUZ(2))
+19 IF '$GET(BISITE)
DO ERRCD^BIUTL2(105,.BIERR)
QUIT
+20 ;
+21 NEW BINACTR
SET BINACTR=""
+22 Begin DoDot:1
+23 ;---> Forced Inactive by passing Inactive Date.
+24 IF $GET(BINACT)
SET BINACTR="n"
QUIT
+25 ;---> Under 36 mths and in GPRA, this patient will be Active.
+26 ;I $$AGE^BIUTL1(BIDFN,2)<36,$$ISGPRA^BIUTL11(BIDFN,BISITE) Q
+27 NEW BIAGE
SET BIAGE=$$AGE^BIUTL1(BIDFN,2)
+28 ;---> Request by Amy Groom:
+29 ;---> If under 36 mths and patient has NO Cur Community, add as Active.
+30 IF BIAGE<36
IF '$$CURCOM^BIUTL11(BIDFN)
QUIT
+31 IF BIAGE<36
IF $$ISGPRA^BIUTL11(BIDFN,BISITE)
QUIT
+32 ;---> Older than 36 mths or not in GPRA, this patient will be Inactive
+33 ;---> as of today with a Reason of "Never Activated."
+34 SET BINACT=$GET(DT)
SET BINACTR="n"
End DoDot:1
+35 ;
+36 DO ADDPAT(BIDFN,BISITE,.BIERR,$GET(BINACT),BINACTR,1)
+37 QUIT
+38 ;
+39 ;
+40 ;----------
ADDPAT(BIDFN,BISITE,BIERR,BINACT,BINACTR,BIAUTO) ;PEP Add a Patient to Imm DB
+1 ;---> Add new Patient to Immunization Database (BI PATIENT File).
+2 ;---> Sets Case Manger to Site Parameter default.
+3 ;---> Also records User and date first entered.
+4 ;---> Called by AGZIMM at ANMC to add newborns from RPMS Registration.
+5 ;---> Parameters:
+6 ; 1 - BIDFN (req) Patient's IEN in VA PATIENT File #2.
+7 ; 2 - BISITE (req) DUZ(2) for default Case Manager.
+8 ; 3 - BIERR (ret) Error text, if any.
+9 ; 4 - BINACT (opt) Fileman internal date Patient became Inactive.
+10 ; 5 - BINACTR (opt) Internal code for Inactive Reason:
+11 ; m:Moved Elsewhere, t:Treatment Elsewhere, d:Deceased
+12 ; p:Previously Inactivated, n:Never Activated
+13 ; 6 - BIAUTO (opt) If BIAUTO=1, set Field# .22="Automatically" added.
+14 ;
+15 ; Example: D AUTOADD^BIPATE(BIDFN,1665,.X,DT,"n")
+16 ;
+17 ;---> If BIDFN not provided, return error and quit.
+18 IF '$GET(BIDFN)
DO ERRCD^BIUTL2(201,.BIERR)
QUIT
+19 ;
+20 ;---> If Patient is already in the Imm Database, return error and quit.
+21 IF $DATA(^BIP(BIDFN,0))
DO ERRCD^BIUTL2(218,.BIERR)
QUIT
+22 ;
+23 ;---> If no Site IEN was passed, try to get it from local symbol table.
+24 IF '$GET(BISITE)
SET BISITE=$GET(DUZ(2))
+25 ;---> If BISITE not provided, return error and quit.
+26 IF '$GET(BISITE)
DO ERRCD^BIUTL2(105,.BIERR)
QUIT
+27 ;
+28 ;---> If Default Case Manager is INACTIVE, return error and quit.
+29 NEW BICMGR
SET BICMGR=$$CMGRDEF^BIUTL2(BISITE)
+30 IF BICMGR
IF $$CMGRACT^BIUTL2(BICMGR)
DO ERRCD^BIUTL2(214,.BIERR)
QUIT
+31 ;
+32 ;---> Trim time from BINACT (seed if necessary).
+33 SET BINACT=$PIECE($GET(BINACT),".")
IF BINACT<2000000
SET BINACT=""
+34 ;
+35 ;---> Check/set Inactive reason.
+36 IF "mtdpn"'[$EXTRACT($GET(BINACTR))
SET BINACTR=""
+37 IF 'BINACT
SET BINACTR=""
+38 ;
+39 NEW BIERR,BIFLD,BIIEN
+40 SET BIIEN(1)=BIDFN
+41 SET BIFLD(.01)=BIDFN
+42 SET BIFLD(.08)=BINACT
+43 SET BIFLD(.1)=BICMGR
+44 SET BIFLD(.16)=BINACTR
+45 SET BIFLD(.2)=$GET(DUZ)
+46 SET BIFLD(.21)=$GET(DT)
+47 SET BIFLD(.22)=$SELECT($GET(BIAUTO):1,1:"")
+48 DO UPDATE^BIFMAN(9002084,.BIIEN,.BIFLD,.BIERR)
+49 IF $GET(BIERR)]""
WRITE !!?3,BIERR
DO DIRZ^BIUTL3()
+50 QUIT
