- BIPATPF ;IHS/CMI/MWR - VIEW PATIENT PROFILE; MAY 10, 2010
- ;;8.5;IMMUNIZATION;;SEP 01,2011
- ;;* MICHAEL REMILLARD, DDS * CIMARRON MEDICAL INFORMATICS, FOR IHS *
- ;; DISPLAY PATIENT'S IMMUNIZATION IMM/SERVE PROFILE.
- ;
- ;
- ;----------
- START ;EP
- ;---> Lookup patients and display their Immunization Profiles.
- ;---> NOT CALLED BY ANY MENU OPTION AT THIS TIME.
- D SETVARS^BIUTL5 N BIDFN
- F D Q:$G(BIDFN)<1
- .D TITLE^BIUTL5("PATIENT IMMUNIZATION PROFILE")
- .D PATLKUP^BIUTL8(.BIDFN)
- .Q:$G(BIDFN)<1
- .D EN(BIDFN)
- D EXIT
- Q
- ;
- ;
- ;----------
- HAVEPAT(BIDFN,BIFDT,BIDUZ2) ;EP
- ;---> Entry point when patient already known.
- ;---> Parameters:
- ; 1 - BIDFN (req) Patient's IEN in VA PATIENT File #2.
- ; 2 - BIFDT (opt) Forecast Date (date used for forecast).
- ; 3 - BIDUZ2 (opt) User's DUZ(2) to indicate Immserve Forecasting
- ; Rules in Patient History data string.
- ;
- ;---> Check for BIDFN.
- Q:$$DFNCHECK^BIUTL2()
- ;---> If no Forecast Date passed, set it equal to today.
- S:'$G(BIFDT) BIFDT=DT
- ;---> If no Site passed, set equal to user's site.
- S:'$G(BIDUZ2) BIDUZ2=$G(DUZ(2))
- I '$G(BIDUZ2) D ERRCD^BIUTL2(105,,1) Q
- ;
- D SETVARS^BIUTL5
- K ^BITMP($J),^TMP("BILMPF",$J)
- S ^BITMP($J,1,BIDFN)=""
- D EN(BIDFN,BIFDT,BIDUZ2)
- D EXIT
- Q
- ;
- ;
- ;----------
- EN(BIDFN,BIFDT,BIDUZ2) ;EP
- ;---> Main entry point for BI PATIENT PROFILE VIEW.
- I '$G(BIDFN) D EN^DDIOL("No Patient selected.") Q
- S:'$G(BIFDT) BIFDT=DT
- S:'$G(BIDUZ2) BIDUZ2=$G(DUZ(2))
- I '$G(BIDUZ2) D ERRCD^BIUTL2(105,,1) Q
- N DFN S DFN=BIDFN ;For now with Linda's view reg templates.
- D EN^VALM("BI PATIENT PROFILE VIEW")
- Q
- ;
- ;
- ;----------
- HDR ;EP
- ;---> Header code.
- Q:'$D(BIDFN)
- N BICRT,X,Y
- S BICRT=$S(($E($G(IOST))="C")!(IOST["BROWSER"):1,1:0)
- S VALMHDR(1)=""
- S Y=$E($$NAME^BIUTL1(BIDFN),1,25)
- S X=" Patient: "
- S:BICRT X=X_IORVON
- S X=X_Y
- S:BICRT X=X_IOINORM
- S X=X_$$SP^BIUTL5(27-$L(Y))_"DOB: "
- S:BICRT X=X_IORVON
- S X=X_$$DOBF^BIUTL1(BIDFN)
- S:BICRT X=X_IOINORM
- S VALMHDR(2)=X
- S X=" Chart#: "
- S:BICRT X=X_IORVON
- S X=X_$$HRCN^BIUTL1(BIDFN)
- S Y=$E($$INSTTX^BIUTL6($G(DUZ(2))),1,17)
- S X=X_" at "_Y
- S:BICRT X=X_IOINORM
- S X=X_$$SP^BIUTL5(20-$L(Y))_$$ACTIVE^BIUTL1(BIDFN)
- S X=X_" "_$$SEXW^BIUTL1(BIDFN)
- S VALMHDR(3)=X
- ;
- Q
- ;
- ;
- ;----------
- INIT ;EP
- ;---> Initialize variables and list array.
- ;
- ;---> If BIDFN not supplied, set Error Code and quit.
- I '$G(BIDFN) D ERRCD^BIUTL2(201,,1) Q
- ;
- ;---> Initialize RPC variables.
- ; BI31 - Delimiter between return value and return error.
- ; BIRETVAL - Return value of valid data from RPC.
- ; BIRETERR - Return value (text string) of error from RPC.
- N BI30,BI31,BIRETVAL,BIRETERR
- S BI30=$C(30),BI31=$C(31)_$C(31),BIRETVAL=""
- ;
- ;---> RPC to gather Immunization History.
- D IMMPROF^BIRPC(.BIRETVAL,BIDFN,$G(BIFDT),$G(BIDUZ2))
- ;
- ;---> Set BIGBL=to global where Immserve Profile is stored
- ;---> (returned from RPC).
- N BIGBL S BIGBL=$P($P(BIRETVAL,BI31,1),")")_","
- ;---> BIGBL is ^BITEMP($J,"PROF",
- ;
- ;---> If error was returned in ^BITEMP($J,"PROF",1),
- ;---> set BIRETERR=error text, display it and quit.
- S BIRETERR=$P(@(BIGBL_1_")"),BI31,2)
- I BIRETERR]"" D Q
- .D EN^DDIOL("* "_BIRETERR,"","!!?5"),DIRZ^BIUTL3()
- .S VALMQUIT=""
- ;
- ;---> Build Listmanager array from BIGBL global array.
- K ^TMP("BILMPF",$J)
- N BILINE,N S N=0
- F S N=$O(@(BIGBL_N_")")) Q:'N D
- .S ^TMP("BILMPF",$J,N,0)=" "_$P(@(BIGBL_N_")"),BI30)
- .S BILINE=N
- ;
- ;---> Overwrite BI31 node and set final VALM line count.
- S ^TMP("BILMPF",$J,BILINE,0)=" "
- S VALMCNT=BILINE
- Q
- ;
- ;
- ;----------
- RESET ;EP
- ;---> Update partition for return to Listmanager.
- I $D(VALMQUIT) S VALMBCK="Q" Q
- D TERM^VALM0 S VALMBCK="R"
- D INIT,HDR Q
- ;
- ;
- ;----------
- HELP ;EP
- ;---> Help code.
- N BIX S BIX=X
- D FULL^VALM1
- W !!?5,"Use arrow keys to scroll up and down through the report, or"
- W !?5,"type ""??"" for more actions, such as Search and Print List."
- D DIRZ^BIUTL3(""," Press ENTER/RETURN to continue")
- D:BIX'="??" RE^VALM4
- Q
- ;
- ;
- ;----------
- EXIT ;EP
- ;---> EOJ Cleanup.
- K ^TMP("BILMPF",$J)
- D CLEAR^VALM1
- D FULL^VALM1
- Q
- BIPATPF ;IHS/CMI/MWR - VIEW PATIENT PROFILE; MAY 10, 2010
- +1 ;;8.5;IMMUNIZATION;;SEP 01,2011
- +2 ;;* MICHAEL REMILLARD, DDS * CIMARRON MEDICAL INFORMATICS, FOR IHS *
- +3 ;; DISPLAY PATIENT'S IMMUNIZATION IMM/SERVE PROFILE.
- +4 ;
- +5 ;
- +6 ;----------
- START ;EP
- +1 ;---> Lookup patients and display their Immunization Profiles.
- +2 ;---> NOT CALLED BY ANY MENU OPTION AT THIS TIME.
- +3 DO SETVARS^BIUTL5
- NEW BIDFN
- +4 FOR
- Begin DoDot:1
- +5 DO TITLE^BIUTL5("PATIENT IMMUNIZATION PROFILE")
- +6 DO PATLKUP^BIUTL8(.BIDFN)
- +7 IF $GET(BIDFN)<1
- QUIT
- +8 DO EN(BIDFN)
- End DoDot:1
- IF $GET(BIDFN)<1
- QUIT
- +9 DO EXIT
- +10 QUIT
- +11 ;
- +12 ;
- +13 ;----------
- HAVEPAT(BIDFN,BIFDT,BIDUZ2) ;EP
- +1 ;---> Entry point when patient already known.
- +2 ;---> Parameters:
- +3 ; 1 - BIDFN (req) Patient's IEN in VA PATIENT File #2.
- +4 ; 2 - BIFDT (opt) Forecast Date (date used for forecast).
- +5 ; 3 - BIDUZ2 (opt) User's DUZ(2) to indicate Immserve Forecasting
- +6 ; Rules in Patient History data string.
- +7 ;
- +8 ;---> Check for BIDFN.
- +9 IF $$DFNCHECK^BIUTL2()
- QUIT
- +10 ;---> If no Forecast Date passed, set it equal to today.
- +11 IF '$GET(BIFDT)
- SET BIFDT=DT
- +12 ;---> If no Site passed, set equal to user's site.
- +13 IF '$GET(BIDUZ2)
- SET BIDUZ2=$GET(DUZ(2))
- +14 IF '$GET(BIDUZ2)
- DO ERRCD^BIUTL2(105,,1)
- QUIT
- +15 ;
- +16 DO SETVARS^BIUTL5
- +17 KILL ^BITMP($JOB),^TMP("BILMPF",$JOB)
- +18 SET ^BITMP($JOB,1,BIDFN)=""
- +19 DO EN(BIDFN,BIFDT,BIDUZ2)
- +20 DO EXIT
- +21 QUIT
- +22 ;
- +23 ;
- +24 ;----------
- EN(BIDFN,BIFDT,BIDUZ2) ;EP
- +1 ;---> Main entry point for BI PATIENT PROFILE VIEW.
- +2 IF '$GET(BIDFN)
- DO EN^DDIOL("No Patient selected.")
- QUIT
- +3 IF '$GET(BIFDT)
- SET BIFDT=DT
- +4 IF '$GET(BIDUZ2)
- SET BIDUZ2=$GET(DUZ(2))
- +5 IF '$GET(BIDUZ2)
- DO ERRCD^BIUTL2(105,,1)
- QUIT
- +6 ;For now with Linda's view reg templates.
- NEW DFN
- SET DFN=BIDFN
- +7 DO EN^VALM("BI PATIENT PROFILE VIEW")
- +8 QUIT
- +9 ;
- +10 ;
- +11 ;----------
- HDR ;EP
- +1 ;---> Header code.
- +2 IF '$DATA(BIDFN)
- QUIT
- +3 NEW BICRT,X,Y
- +4 SET BICRT=$SELECT(($EXTRACT($GET(IOST))="C")!(IOST["BROWSER"):1,1:0)
- +5 SET VALMHDR(1)=""
- +6 SET Y=$EXTRACT($$NAME^BIUTL1(BIDFN),1,25)
- +7 SET X=" Patient: "
- +8 IF BICRT
- SET X=X_IORVON
- +9 SET X=X_Y
- +10 IF BICRT
- SET X=X_IOINORM
- +11 SET X=X_$$SP^BIUTL5(27-$LENGTH(Y))_"DOB: "
- +12 IF BICRT
- SET X=X_IORVON
- +13 SET X=X_$$DOBF^BIUTL1(BIDFN)
- +14 IF BICRT
- SET X=X_IOINORM
- +15 SET VALMHDR(2)=X
- +16 SET X=" Chart#: "
- +17 IF BICRT
- SET X=X_IORVON
- +18 SET X=X_$$HRCN^BIUTL1(BIDFN)
- +19 SET Y=$EXTRACT($$INSTTX^BIUTL6($GET(DUZ(2))),1,17)
- +20 SET X=X_" at "_Y
- +21 IF BICRT
- SET X=X_IOINORM
- +22 SET X=X_$$SP^BIUTL5(20-$LENGTH(Y))_$$ACTIVE^BIUTL1(BIDFN)
- +23 SET X=X_" "_$$SEXW^BIUTL1(BIDFN)
- +24 SET VALMHDR(3)=X
- +25 ;
- +26 QUIT
- +27 ;
- +28 ;
- +29 ;----------
- INIT ;EP
- +1 ;---> Initialize variables and list array.
- +2 ;
- +3 ;---> If BIDFN not supplied, set Error Code and quit.
- +4 IF '$GET(BIDFN)
- DO ERRCD^BIUTL2(201,,1)
- QUIT
- +5 ;
- +6 ;---> Initialize RPC variables.
- +7 ; BI31 - Delimiter between return value and return error.
- +8 ; BIRETVAL - Return value of valid data from RPC.
- +9 ; BIRETERR - Return value (text string) of error from RPC.
- +10 NEW BI30,BI31,BIRETVAL,BIRETERR
- +11 SET BI30=$CHAR(30)
- SET BI31=$CHAR(31)_$CHAR(31)
- SET BIRETVAL=""
- +12 ;
- +13 ;---> RPC to gather Immunization History.
- +14 DO IMMPROF^BIRPC(.BIRETVAL,BIDFN,$GET(BIFDT),$GET(BIDUZ2))
- +15 ;
- +16 ;---> Set BIGBL=to global where Immserve Profile is stored
- +17 ;---> (returned from RPC).
- +18 NEW BIGBL
- SET BIGBL=$PIECE($PIECE(BIRETVAL,BI31,1),")")_","
- +19 ;---> BIGBL is ^BITEMP($J,"PROF",
- +20 ;
- +21 ;---> If error was returned in ^BITEMP($J,"PROF",1),
- +22 ;---> set BIRETERR=error text, display it and quit.
- +23 SET BIRETERR=$PIECE(@(BIGBL_1_")"),BI31,2)
- +24 IF BIRETERR]""
- Begin DoDot:1
- +25 DO EN^DDIOL("* "_BIRETERR,"","!!?5")
- DO DIRZ^BIUTL3()
- +26 SET VALMQUIT=""
- End DoDot:1
- QUIT
- +27 ;
- +28 ;---> Build Listmanager array from BIGBL global array.
- +29 KILL ^TMP("BILMPF",$JOB)
- +30 NEW BILINE,N
- SET N=0
- +31 FOR
- SET N=$ORDER(@(BIGBL_N_")"))
- IF 'N
- QUIT
- Begin DoDot:1
- +32 SET ^TMP("BILMPF",$JOB,N,0)=" "_$PIECE(@(BIGBL_N_")"),BI30)
- +33 SET BILINE=N
- End DoDot:1
- +34 ;
- +35 ;---> Overwrite BI31 node and set final VALM line count.
- +36 SET ^TMP("BILMPF",$JOB,BILINE,0)=" "
- +37 SET VALMCNT=BILINE
- +38 QUIT
- +39 ;
- +40 ;
- +41 ;----------
- RESET ;EP
- +1 ;---> Update partition for return to Listmanager.
- +2 IF $DATA(VALMQUIT)
- SET VALMBCK="Q"
- QUIT
- +3 DO TERM^VALM0
- SET VALMBCK="R"
- +4 DO INIT
- DO HDR
- QUIT
- +5 ;
- +6 ;
- +7 ;----------
- HELP ;EP
- +1 ;---> Help code.
- +2 NEW BIX
- SET BIX=X
- +3 DO FULL^VALM1
- +4 WRITE !!?5,"Use arrow keys to scroll up and down through the report, or"
- +5 WRITE !?5,"type ""??"" for more actions, such as Search and Print List."
- +6 DO DIRZ^BIUTL3(""," Press ENTER/RETURN to continue")
- +7 IF BIX'="??"
- DO RE^VALM4
- +8 QUIT
- +9 ;
- +10 ;
- +11 ;----------
- EXIT ;EP
- +1 ;---> EOJ Cleanup.
- +2 KILL ^TMP("BILMPF",$JOB)
- +3 DO CLEAR^VALM1
- +4 DO FULL^VALM1
- +5 QUIT
