BIRPC ;IHS/CMI/MWR - REMOTE PROCEDURE CALLS; MAY 10, 2010
;;8.5;IMMUNIZATION;**9**;OCT 01,2014
;;* MICHAEL REMILLARD, DDS * CIMARRON MEDICAL INFORMATICS, FOR IHS *
;; RETURNS IMMUNIZATION HISTORY, FORECAST, IMM/SERV PROFILE.
;; PATCH 1: Add API: FORCALL, to allow queued update of all BI Patients.
;; PATCH 3: Add NDC and Elig Codes, plus Date of Event to default Hx string. IMMHX+60
;; PATCH 5: Add Admin Note to default Hx string. IMMHX+60
;; PATCH 9: Add Date VIS Presented to Patient as piece 26. IMMHX+65
;
;
;----------
IMMHX(BIHX,BIDFN,BIDE,BISKIN,BIFMT) ;PEP - Return Immunization History.
;---> Return Patient's Immunization History.
;---> Immunizations returned in one string, delimited by "^".
;---> Parameters:
; 1 - BIHX (ret) String of patient's immunizations_||_Error.
; 2 - BIDFN (req) DFN of patient.
; 3 - BIDE (opt) Array of Data Elements to be returned:
; BIDE(IEN of Data Element).
; 4 - BISKIN (opt) =1 if Skin Tests should be included (DEFAULT);
; =0 if Skin Tests should NOT be included.
; 5 - BIFMT (opt) Format: 0=ASCII Split, 1=ASCII, 3=IMM/SERVE
; "Split" means the components of a combination vaccine
; will be split out as if they were given individually.
;
;---> Delimiter to pass error with result to GUI.
N BI31,BIERR S BI31=$C(31)_$C(31)
S BIHX="",BIERR=""
;
;---> If DFN not provided, set Error Code and quit.
;I $G(BIDFN) D Q ;---> Use this line to test error handling.
I '$G(BIDFN) D Q
.D ERRCD^BIUTL2(306,.BIERR) S BIHX=BI31_BIERR
;
;---> Set required variables, kill ^BITMP($J).
D SETVARS^BIUTL5 K ^BITMP($J)
;
;---> Set the Patient TEMP global.
S ^BITMP($J,1,BIDFN)=""
;
;---> If BIDE local array (Data Elements to be returned) is not
;---> passed, then set the following default Data Elements.
;---> The following are IEN's in ^BIEXPDD(.
;---> IEN PC DATA
;---> --- -- ----
;---> 1 = Visit Type: "I"=Immunization, "S"=Skin Test.
;---> 4 2 = Vaccine Name, Short.
;---> 8 3 = Vaccine Component IEN'S. ;v8.0
;---> 24 4 = IEN, V File Visit.
;---> 26 5 = Location (or Outside Location) where Imm was given.
;---> 27 6 = Vaccine Group (Series Type) for grouping of vaccines.
;---> 29 7 = Date of Visit (DD-Mmm-YYYY @HH:MM).
;---> 38 8 = Skin Test Result.
;---> 39 9 = Skin Test Reading.
;---> 40 10 = Skin Test date read.
;---> 41 11 = Skin Test Name.
;---> 42 12 = Skin Test Name IEN.
;---> 44 13 = Reaction to Immunization, text.
;---> 51 14 = Release/Revision Date of VIS (DD-Mmm-YYYY).
;---> 61 15 = Encounter Provider.
;---> 65 16 = Dose Override.
;---> 66 17 = Date of Visit (MM/DD/YY).
;---> 69 18 = Vaccine Component CVX Code.
;---> 74 19 = CPT-Coded Visit.
;---> 78 20 = Imported from Outside Registry (if = 1).
;---> 80 21 = NDC Code pointer IEN.
;********** PATCH 3, v8.5, SEP 10,2012, IHS/CMI/MWR
;---> Add NDC and Eligibility Codes, plus Date of Event to default Hx string.
;---> 82 22 = Elilgibility Code Text.
;---> 84 23 = NDC Code text.
;---> 85 24 = Date of Event/Administer shot (1201 field of V File) in MM/DD/YY
;
;********** PATCH 5, v8.5, JUL 01,2013, IHS/CMI/MWR
;---> Add Admin Note to default Hx string.
;---> 87 25 = Administrative Note.
;
;********** PATCH 9, v8.5, OCT 01,2014, IHS/CMI/MWR
;---> Add Date VIS Presented to Patient (MM/DD/YY).
;---> 90 26 = Date VIS Presented to Patient.
;
D:'$D(BIDE)
.;N I F I=4,8,24,26,27,29,38,39,40,41,42,44,51,61,65,66,69,74,78,80,82,84,85,87 S BIDE(I)=""
.N I F I=4,8,24,26,27,29,38,39,40,41,42,44,51,61,65,66,69,74,78,80,82,84,85,87,90 S BIDE(I)=""
;**********
N BIMM S BIMM("ALL")=""
;
;---> Next, gather Immunization History for this patient.
; 1 - BIFMT (req) Format: 0=ASCII Split, 1=ASCII, 2=HL7, 3=IMM/SERVE
; 2 - BIDE (req) Data Elements array (null if HL7)
; 3 - BIMM (req) Array of Vaccine Types
; 4 - BIFDT (opt) Forecast Date (not needed for history only).
; 5 - BISKIN (opt) =1 if Skin Tests should be included.
;
S:'$D(BISKIN) BISKIN=1
S:'$D(BIFMT) BIFMT=0
D HISTORY^BIEXPRT3(BIFMT,.BIDE,.BIMM,,BISKIN)
;
;
;---> Next, set parameters for writing data as a string in BIHX.
;---> Parameters:
; 1 - BIEXP (req) Export: 0=screen, 1=host file, 2=string
; 2 - BIFMT (req) Format: 1=ASCII, 2=HL7, 3=IMM/SERVE
; 3 - BIFLNM (opt) File name
; 4 - BIPATH (opt) BI Path name for host files
; 5 - BIHX (ret) Immunization History in "^"-delimited string
;
D WRITE^BIEXPRT4(2,1,,,.BIHX)
;
;W !,BIHX,!,"IMMHX^BIRPC" R ZZZ
S BIHX=BIHX_BI31
Q
;
;
;----------
IMMFORC(BIFORC,BIDFN,BIFDT,BIUPD,BIDUZ2,BIPDSS) ;PEP - Return Immunization Forecast.
;---> Return Immserve Patient Forecast in one string.
;---> Lines delimited by "^".
;---> Called by RPC: BI IMMSERVE PT PROFILE
;---> Parameters:
; 1 - BIFORC (ret) String of patient's forecast_||_Error.
; 2 - BIDFN (req) DFN of patient.
; 3 - BIFDT (opt) Forecast Date (date used for forecast).
; 4 - BIUPD (opt) If BIUPD=1, do NOT update Immserve Forecast.
; Default $G(BIUPD)="", forecast gets updated.
; 5 - BIDUZ2 (opt) User's DUZ(2) to indicate Immserve Forecasting
; Rules in Patient History data string.
; 6 - BIPDSS (ret) Returned string of V IMM IEN's that are
; Problem Doses, according to TCH.
;
;---> Define delimiter to pass error and error variable.
N BI31,BIERR S BI31=$C(31)_$C(31),BIERR=""
;
;---> If the Vaccine Table is not standard, set Error Code and quit.
I $D(^BISITE(-1)) D Q
.D ERRCD^BIUTL2(503,.BIERR) S BIFORC=BI31_BIERR
;
I '$G(BIDFN) D ERRCD^BIUTL2(301,.BIERR) S BIFORC=BI31_BIERR Q
;
;---> If patient is deceased, report it as error (in msgbox).
I $$DECEASED^BIUTL1(BIDFN) D Q
.D ERRCD^BIUTL2(205,.BIERR) S BIFORC=BI31_BIERR Q
;
;---> If no Forecast Date passed, set it equal to today.
S:'$G(BIFDT) BIFDT=DT
;
;---> If Forecast Date is before Patient's DOB, set Error Code and quit.
I BIFDT<$$DOB^BIUTL1(BIDFN) D Q
.D ERRCD^BIUTL2(315,.BIERR) S BIFORC=BI31_BIERR
;
;---> Update patient's forecast with Immserve Utility (in ^BIPDUE).
D:'$G(BIUPD) UPDATE^BIPATUP(BIDFN,BIFDT,.BIERR,1,$G(BIDUZ2),.BIPDSS)
I BIERR]"" S BIFORC=BI31_BIERR Q
;
;---> If no Immunizations are due for this patient, return message.
I '$D(^BIPDUE("B",BIDFN))&('$D(^BIPERR("B",BIDFN))) D Q
.S BIFORC="No immunizations due."_BI31
.;---> NOTE! The above text is specifically checked for in ^BIPATVW1.
;
;---> Copy Immserve Patient Forecast (stored in ^BIPDUE) to string.
N A,B,C,N,U,V,X,Z
S:'$D(BIFORC) BIFORC="" S U="^",V="|"
S N=0
F S N=$O(^BIPDUE("B",BIDFN,N)) Q:'N D
.S Z=$G(^BIPDUE(N,0))
.I $P(Z,U)'=BIDFN K ^BIPDUE(N),^BIPDUE("B",BIDFN,N) Q
.;
.;---> A=Date Due, B=Date Past Due.
.S A=$P(Z,U,4),B=$P(Z,U,5)
.S X=" "_$$VNAME^BIUTL2($P(Z,U,2)) ;v8.0
.;
.;---> Concatenate due by/past due appropriate text and date.
.S X=X_V_$S(B:" past due",1:" due")
.S BIFORC=BIFORC_X_U
;
;
;---> Copy any Forecasting Errors (stored in ^BIPERR) to string.
S N=0
F S N=$O(^BIPERR("B",BIDFN,N)) Q:'N D
.S Z=$G(^BIPERR(N,0))
.I $P(Z,U)'=BIDFN K ^BIPERR(N),^BIPERR("B",BIDFN,N) Q
.S X=$P(Z,U,2) S:'X X=999
.;
.S X=$P(Z,U,3)_" ERROR: "_$P((^BIERR(X,0)),"^",2)
.S BIFORC=BIFORC_X_U
;
S BIFORC=BIFORC_BI31
Q
;
;
;
;----------
IMMPROF(BIGBL,BIDFN,BIFDT,BIDUZ2) ;PEP - Return ImmServe Profile in global array.
;---> Return ImmServe Profile in global array, ^BITEMP($J,"PROF".
;---> Lines delimited by "^".
;---> Called by RPC: BI PATIENT PROFILE GET
;---> Parameters:
; 1 - BIGBL (ret) Name of result global containing patient's
; ImmServe Profile, passed to Broker.
; 2 - BIDFN (req) DFN of patient.
; 3 - BIFDT (opt) Forecast Date (date used to calc Imms due).
; 4 - BIDUZ2 (opt) User's DUZ(2) to indicate Immserve Forecasting
; Rules in Patient History data string.
;
;---> Delimiters to pass error with result to GUI.
N BI30,BI31,BIERR,X
S BI30=$C(30),BI31=$C(31)_$C(31)
S BIGBL="^BITEMP("_$J_",""PROF"")",BIERR=""
K ^BITEMP($J,"PROF")
;
I '$G(BIDFN) D Q
.D ERRCD^BIUTL2(305,.BIERR) S ^BITEMP($J,"PROF",1)=BI31_BIERR
;
;---> If patient is deceased, report it as error (in msgbox).
I $$DECEASED^BIUTL1(BIDFN) D Q
.D ERRCD^BIUTL2(205,.BIERR) S ^BITEMP($J,"PROF",1)=BI31_BIERR
;
;---> If the Patient is not in the Immunization Register,
;---> report the fact in the Profile (instead of as an error).
I '$D(^BIP(BIDFN)) D Q
.N X
.S X="This patient is not in the Immunization Register."
.S ^BITEMP($J,"PROF",1)=X_BI30
.S X="The Immserve Profile cannot be stored and displayed"
.S ^BITEMP($J,"PROF",2)=X_BI30
.S X="if the patient is not in the Register."
.S ^BITEMP($J,"PROF",3)=X_BI30
.S ^BITEMP($J,"PROF",4)=BI31
;
;---> If no Forecast Date passed, set it equal to today.
S:'$G(BIFDT) BIFDT=DT
;
;---> Update patient's profile with Immserve Utility.
D UPDATE^BIPATUP(BIDFN,BIFDT,.BIERR,,$G(BIDUZ2))
;
;---> Copy Immserve Patient Profile to string.
N I,N,U,X S U="^"
S N=0
F I=1:1 S N=$O(^BIP(BIDFN,1,N)) Q:'N D
.;---> Set null lines (line breaks) equal to one space, so that
.;---> Windows reader will quit only at the final "null" line.
.S X=^BIP(BIDFN,1,N,0) S:X="" X=" "
.S ^BITEMP($J,"PROF",I)=X_BI30
;
;---> If no ImmServe Profile produced, report it as an error.
I '$O(^BITEMP($J,"PROF",0)) D ERRCD^BIUTL2(307,.BIERR)
;
;---> Tack on Error Delimiter and any error.
S ^BITEMP($J,"PROF",I)=BI31_BIERR
Q
;
;
;----------
FORCALL ;PEP - Update Forecast for all Immunization Patients.
;---> Can be called by RPC: BI FORECAST ALL
;---> Can be called by OPTION: BI FORECAST ALL (may be queued in Taskman)
;---> This subroutine updates the immunization forecast for all patients in
;---> the File BI PATIENT IMMUNIZATIONS DUE File #9002084.1 for today.
D ^XBKVAR
N ZTIO S ZTIO=""
N BIN S BIN=0
F S BIN=$O(^BIP(BIN)) Q:'BIN D IMMFORC^BIRPC(,BIN)
Q
BIRPC ;IHS/CMI/MWR - REMOTE PROCEDURE CALLS; MAY 10, 2010
+1 ;;8.5;IMMUNIZATION;**9**;OCT 01,2014
+2 ;;* MICHAEL REMILLARD, DDS * CIMARRON MEDICAL INFORMATICS, FOR IHS *
+3 ;; RETURNS IMMUNIZATION HISTORY, FORECAST, IMM/SERV PROFILE.
+4 ;; PATCH 1: Add API: FORCALL, to allow queued update of all BI Patients.
+5 ;; PATCH 3: Add NDC and Elig Codes, plus Date of Event to default Hx string. IMMHX+60
+6 ;; PATCH 5: Add Admin Note to default Hx string. IMMHX+60
+7 ;; PATCH 9: Add Date VIS Presented to Patient as piece 26. IMMHX+65
+8 ;
+9 ;
+10 ;----------
IMMHX(BIHX,BIDFN,BIDE,BISKIN,BIFMT) ;PEP - Return Immunization History.
+1 ;---> Return Patient's Immunization History.
+2 ;---> Immunizations returned in one string, delimited by "^".
+3 ;---> Parameters:
+4 ; 1 - BIHX (ret) String of patient's immunizations_||_Error.
+5 ; 2 - BIDFN (req) DFN of patient.
+6 ; 3 - BIDE (opt) Array of Data Elements to be returned:
+7 ; BIDE(IEN of Data Element).
+8 ; 4 - BISKIN (opt) =1 if Skin Tests should be included (DEFAULT);
+9 ; =0 if Skin Tests should NOT be included.
+10 ; 5 - BIFMT (opt) Format: 0=ASCII Split, 1=ASCII, 3=IMM/SERVE
+11 ; "Split" means the components of a combination vaccine
+12 ; will be split out as if they were given individually.
+13 ;
+14 ;---> Delimiter to pass error with result to GUI.
+15 NEW BI31,BIERR
SET BI31=$CHAR(31)_$CHAR(31)
+16 SET BIHX=""
SET BIERR=""
+17 ;
+18 ;---> If DFN not provided, set Error Code and quit.
+19 ;I $G(BIDFN) D Q ;---> Use this line to test error handling.
+20 IF '$GET(BIDFN)
Begin DoDot:1
+21 DO ERRCD^BIUTL2(306,.BIERR)
SET BIHX=BI31_BIERR
End DoDot:1
QUIT
+22 ;
+23 ;---> Set required variables, kill ^BITMP($J).
+24 DO SETVARS^BIUTL5
KILL ^BITMP($JOB)
+25 ;
+26 ;---> Set the Patient TEMP global.
+27 SET ^BITMP($JOB,1,BIDFN)=""
+28 ;
+29 ;---> If BIDE local array (Data Elements to be returned) is not
+30 ;---> passed, then set the following default Data Elements.
+31 ;---> The following are IEN's in ^BIEXPDD(.
+32 ;---> IEN PC DATA
+33 ;---> --- -- ----
+34 ;---> 1 = Visit Type: "I"=Immunization, "S"=Skin Test.
+35 ;---> 4 2 = Vaccine Name, Short.
+36 ;---> 8 3 = Vaccine Component IEN'S. ;v8.0
+37 ;---> 24 4 = IEN, V File Visit.
+38 ;---> 26 5 = Location (or Outside Location) where Imm was given.
+39 ;---> 27 6 = Vaccine Group (Series Type) for grouping of vaccines.
+40 ;---> 29 7 = Date of Visit (DD-Mmm-YYYY @HH:MM).
+41 ;---> 38 8 = Skin Test Result.
+42 ;---> 39 9 = Skin Test Reading.
+43 ;---> 40 10 = Skin Test date read.
+44 ;---> 41 11 = Skin Test Name.
+45 ;---> 42 12 = Skin Test Name IEN.
+46 ;---> 44 13 = Reaction to Immunization, text.
+47 ;---> 51 14 = Release/Revision Date of VIS (DD-Mmm-YYYY).
+48 ;---> 61 15 = Encounter Provider.
+49 ;---> 65 16 = Dose Override.
+50 ;---> 66 17 = Date of Visit (MM/DD/YY).
+51 ;---> 69 18 = Vaccine Component CVX Code.
+52 ;---> 74 19 = CPT-Coded Visit.
+53 ;---> 78 20 = Imported from Outside Registry (if = 1).
+54 ;---> 80 21 = NDC Code pointer IEN.
+55 ;********** PATCH 3, v8.5, SEP 10,2012, IHS/CMI/MWR
+56 ;---> Add NDC and Eligibility Codes, plus Date of Event to default Hx string.
+57 ;---> 82 22 = Elilgibility Code Text.
+58 ;---> 84 23 = NDC Code text.
+59 ;---> 85 24 = Date of Event/Administer shot (1201 field of V File) in MM/DD/YY
+60 ;
+61 ;********** PATCH 5, v8.5, JUL 01,2013, IHS/CMI/MWR
+62 ;---> Add Admin Note to default Hx string.
+63 ;---> 87 25 = Administrative Note.
+64 ;
+65 ;********** PATCH 9, v8.5, OCT 01,2014, IHS/CMI/MWR
+66 ;---> Add Date VIS Presented to Patient (MM/DD/YY).
+67 ;---> 90 26 = Date VIS Presented to Patient.
+68 ;
+69 IF '$DATA(BIDE)
Begin DoDot:1
+70 ;N I F I=4,8,24,26,27,29,38,39,40,41,42,44,51,61,65,66,69,74,78,80,82,84,85,87 S BIDE(I)=""
+71 NEW I
FOR I=4,8,24,26,27,29,38,39,40,41,42,44,51,61,65,66,69,74,78,80,82,84,85,87,90
SET BIDE(I)=""
End DoDot:1
+72 ;**********
+73 NEW BIMM
SET BIMM("ALL")=""
+74 ;
+75 ;---> Next, gather Immunization History for this patient.
+76 ; 1 - BIFMT (req) Format: 0=ASCII Split, 1=ASCII, 2=HL7, 3=IMM/SERVE
+77 ; 2 - BIDE (req) Data Elements array (null if HL7)
+78 ; 3 - BIMM (req) Array of Vaccine Types
+79 ; 4 - BIFDT (opt) Forecast Date (not needed for history only).
+80 ; 5 - BISKIN (opt) =1 if Skin Tests should be included.
+81 ;
+82 IF '$DATA(BISKIN)
SET BISKIN=1
+83 IF '$DATA(BIFMT)
SET BIFMT=0
+84 DO HISTORY^BIEXPRT3(BIFMT,.BIDE,.BIMM,,BISKIN)
+85 ;
+86 ;
+87 ;---> Next, set parameters for writing data as a string in BIHX.
+88 ;---> Parameters:
+89 ; 1 - BIEXP (req) Export: 0=screen, 1=host file, 2=string
+90 ; 2 - BIFMT (req) Format: 1=ASCII, 2=HL7, 3=IMM/SERVE
+91 ; 3 - BIFLNM (opt) File name
+92 ; 4 - BIPATH (opt) BI Path name for host files
+93 ; 5 - BIHX (ret) Immunization History in "^"-delimited string
+94 ;
+95 DO WRITE^BIEXPRT4(2,1,,,.BIHX)
+96 ;
+97 ;W !,BIHX,!,"IMMHX^BIRPC" R ZZZ
+98 SET BIHX=BIHX_BI31
+99 QUIT
+100 ;
+101 ;
+102 ;----------
IMMFORC(BIFORC,BIDFN,BIFDT,BIUPD,BIDUZ2,BIPDSS) ;PEP - Return Immunization Forecast.
+1 ;---> Return Immserve Patient Forecast in one string.
+2 ;---> Lines delimited by "^".
+3 ;---> Called by RPC: BI IMMSERVE PT PROFILE
+4 ;---> Parameters:
+5 ; 1 - BIFORC (ret) String of patient's forecast_||_Error.
+6 ; 2 - BIDFN (req) DFN of patient.
+7 ; 3 - BIFDT (opt) Forecast Date (date used for forecast).
+8 ; 4 - BIUPD (opt) If BIUPD=1, do NOT update Immserve Forecast.
+9 ; Default $G(BIUPD)="", forecast gets updated.
+10 ; 5 - BIDUZ2 (opt) User's DUZ(2) to indicate Immserve Forecasting
+11 ; Rules in Patient History data string.
+12 ; 6 - BIPDSS (ret) Returned string of V IMM IEN's that are
+13 ; Problem Doses, according to TCH.
+14 ;
+15 ;---> Define delimiter to pass error and error variable.
+16 NEW BI31,BIERR
SET BI31=$CHAR(31)_$CHAR(31)
SET BIERR=""
+17 ;
+18 ;---> If the Vaccine Table is not standard, set Error Code and quit.
+19 IF $DATA(^BISITE(-1))
Begin DoDot:1
+20 DO ERRCD^BIUTL2(503,.BIERR)
SET BIFORC=BI31_BIERR
End DoDot:1
QUIT
+21 ;
+22 IF '$GET(BIDFN)
DO ERRCD^BIUTL2(301,.BIERR)
SET BIFORC=BI31_BIERR
QUIT
+23 ;
+24 ;---> If patient is deceased, report it as error (in msgbox).
+25 IF $$DECEASED^BIUTL1(BIDFN)
Begin DoDot:1
+26 DO ERRCD^BIUTL2(205,.BIERR)
SET BIFORC=BI31_BIERR
QUIT
End DoDot:1
QUIT
+27 ;
+28 ;---> If no Forecast Date passed, set it equal to today.
+29 IF '$GET(BIFDT)
SET BIFDT=DT
+30 ;
+31 ;---> If Forecast Date is before Patient's DOB, set Error Code and quit.
+32 IF BIFDT<$$DOB^BIUTL1(BIDFN)
Begin DoDot:1
+33 DO ERRCD^BIUTL2(315,.BIERR)
SET BIFORC=BI31_BIERR
End DoDot:1
QUIT
+34 ;
+35 ;---> Update patient's forecast with Immserve Utility (in ^BIPDUE).
+36 IF '$GET(BIUPD)
DO UPDATE^BIPATUP(BIDFN,BIFDT,.BIERR,1,$GET(BIDUZ2),.BIPDSS)
+37 IF BIERR]""
SET BIFORC=BI31_BIERR
QUIT
+38 ;
+39 ;---> If no Immunizations are due for this patient, return message.
+40 IF '$DATA(^BIPDUE("B",BIDFN))&('$DATA(^BIPERR("B",BIDFN)))
Begin DoDot:1
+41 SET BIFORC="No immunizations due."_BI31
+42 ;---> NOTE! The above text is specifically checked for in ^BIPATVW1.
End DoDot:1
QUIT
+43 ;
+44 ;---> Copy Immserve Patient Forecast (stored in ^BIPDUE) to string.
+45 NEW A,B,C,N,U,V,X,Z
+46 IF '$DATA(BIFORC)
SET BIFORC=""
SET U="^"
SET V="|"
+47 SET N=0
+48 FOR
SET N=$ORDER(^BIPDUE("B",BIDFN,N))
IF 'N
QUIT
Begin DoDot:1
+49 SET Z=$GET(^BIPDUE(N,0))
+50 IF $PIECE(Z,U)'=BIDFN
KILL ^BIPDUE(N),^BIPDUE("B",BIDFN,N)
QUIT
+51 ;
+52 ;---> A=Date Due, B=Date Past Due.
+53 SET A=$PIECE(Z,U,4)
SET B=$PIECE(Z,U,5)
+54 ;v8.0
SET X=" "_$$VNAME^BIUTL2($PIECE(Z,U,2))
+55 ;
+56 ;---> Concatenate due by/past due appropriate text and date.
+57 SET X=X_V_$SELECT(B:" past due",1:" due")
+58 SET BIFORC=BIFORC_X_U
End DoDot:1
+59 ;
+60 ;
+61 ;---> Copy any Forecasting Errors (stored in ^BIPERR) to string.
+62 SET N=0
+63 FOR
SET N=$ORDER(^BIPERR("B",BIDFN,N))
IF 'N
QUIT
Begin DoDot:1
+64 SET Z=$GET(^BIPERR(N,0))
+65 IF $PIECE(Z,U)'=BIDFN
KILL ^BIPERR(N),^BIPERR("B",BIDFN,N)
QUIT
+66 SET X=$PIECE(Z,U,2)
IF 'X
SET X=999
+67 ;
+68 SET X=$PIECE(Z,U,3)_" ERROR: "_$PIECE((^BIERR(X,0)),"^",2)
+69 SET BIFORC=BIFORC_X_U
End DoDot:1
+70 ;
+71 SET BIFORC=BIFORC_BI31
+72 QUIT
+73 ;
+74 ;
+75 ;
+76 ;----------
IMMPROF(BIGBL,BIDFN,BIFDT,BIDUZ2) ;PEP - Return ImmServe Profile in global array.
+1 ;---> Return ImmServe Profile in global array, ^BITEMP($J,"PROF".
+2 ;---> Lines delimited by "^".
+3 ;---> Called by RPC: BI PATIENT PROFILE GET
+4 ;---> Parameters:
+5 ; 1 - BIGBL (ret) Name of result global containing patient's
+6 ; ImmServe Profile, passed to Broker.
+7 ; 2 - BIDFN (req) DFN of patient.
+8 ; 3 - BIFDT (opt) Forecast Date (date used to calc Imms due).
+9 ; 4 - BIDUZ2 (opt) User's DUZ(2) to indicate Immserve Forecasting
+10 ; Rules in Patient History data string.
+11 ;
+12 ;---> Delimiters to pass error with result to GUI.
+13 NEW BI30,BI31,BIERR,X
+14 SET BI30=$CHAR(30)
SET BI31=$CHAR(31)_$CHAR(31)
+15 SET BIGBL="^BITEMP("_$JOB_",""PROF"")"
SET BIERR=""
+16 KILL ^BITEMP($JOB,"PROF")
+17 ;
+18 IF '$GET(BIDFN)
Begin DoDot:1
+19 DO ERRCD^BIUTL2(305,.BIERR)
SET ^BITEMP($JOB,"PROF",1)=BI31_BIERR
End DoDot:1
QUIT
+20 ;
+21 ;---> If patient is deceased, report it as error (in msgbox).
+22 IF $$DECEASED^BIUTL1(BIDFN)
Begin DoDot:1
+23 DO ERRCD^BIUTL2(205,.BIERR)
SET ^BITEMP($JOB,"PROF",1)=BI31_BIERR
End DoDot:1
QUIT
+24 ;
+25 ;---> If the Patient is not in the Immunization Register,
+26 ;---> report the fact in the Profile (instead of as an error).
+27 IF '$DATA(^BIP(BIDFN))
Begin DoDot:1
+28 NEW X
+29 SET X="This patient is not in the Immunization Register."
+30 SET ^BITEMP($JOB,"PROF",1)=X_BI30
+31 SET X="The Immserve Profile cannot be stored and displayed"
+32 SET ^BITEMP($JOB,"PROF",2)=X_BI30
+33 SET X="if the patient is not in the Register."
+34 SET ^BITEMP($JOB,"PROF",3)=X_BI30
+35 SET ^BITEMP($JOB,"PROF",4)=BI31
End DoDot:1
QUIT
+36 ;
+37 ;---> If no Forecast Date passed, set it equal to today.
+38 IF '$GET(BIFDT)
SET BIFDT=DT
+39 ;
+40 ;---> Update patient's profile with Immserve Utility.
+41 DO UPDATE^BIPATUP(BIDFN,BIFDT,.BIERR,,$GET(BIDUZ2))
+42 ;
+43 ;---> Copy Immserve Patient Profile to string.
+44 NEW I,N,U,X
SET U="^"
+45 SET N=0
+46 FOR I=1:1
SET N=$ORDER(^BIP(BIDFN,1,N))
IF 'N
QUIT
Begin DoDot:1
+47 ;---> Set null lines (line breaks) equal to one space, so that
+48 ;---> Windows reader will quit only at the final "null" line.
+49 SET X=^BIP(BIDFN,1,N,0)
IF X=""
SET X=" "
+50 SET ^BITEMP($JOB,"PROF",I)=X_BI30
End DoDot:1
+51 ;
+52 ;---> If no ImmServe Profile produced, report it as an error.
+53 IF '$ORDER(^BITEMP($JOB,"PROF",0))
DO ERRCD^BIUTL2(307,.BIERR)
+54 ;
+55 ;---> Tack on Error Delimiter and any error.
+56 SET ^BITEMP($JOB,"PROF",I)=BI31_BIERR
+57 QUIT
+58 ;
+59 ;
+60 ;----------
FORCALL ;PEP - Update Forecast for all Immunization Patients.
+1 ;---> Can be called by RPC: BI FORECAST ALL
+2 ;---> Can be called by OPTION: BI FORECAST ALL (may be queued in Taskman)
+3 ;---> This subroutine updates the immunization forecast for all patients in
+4 ;---> the File BI PATIENT IMMUNIZATIONS DUE File #9002084.1 for today.
+5 DO ^XBKVAR
+6 NEW ZTIO
SET ZTIO=""
+7 NEW BIN
SET BIN=0
+8 FOR
SET BIN=$ORDER(^BIP(BIN))
IF 'BIN
QUIT
DO IMMFORC^BIRPC(,BIN)
+9 QUIT
