BKMVA41 ;PRXM/HC/JGH - HMS PATIENT REGISTER; [ 1/19/2005 7:16 PM ] ; 13 Apr 2005 5:42 PM
;;2.1;HIV MANAGEMENT SYSTEM;;Feb 07, 2011
;
Q
;
EN ;ENTRY POINT -- ListMan template BKMV PCC LAB REVIEW
; Assumes existence of DFN,DUZ
N HIVIEN
S HIVIEN=$$HIVIEN^BKMIXX3()
I HIVIEN="" W !,"There is no HMS register defined." H 2 Q
I '$$VALID^BKMIXX3(DUZ) Q
K ^TMP("BKMVA41",$J)
D ^XBFMK
D EN^VALM("BKMV PCC LAB REVIEW")
D ^XBFMK
D EXIT
Q
;
HDR ; -- header code
; Assumes existence of DUZ
N DA,IENS,SITE
S DA=$G(DUZ(2)),IENS=$$IENS^DILF(.DA),SITE=$$GET1^DIQ(4,IENS,.01,"E")
S VALMHDR(1)=$$PAD^BKMIXX4("",">"," ",(80-$L(SITE)+2)\2)_"["_$G(SITE)_"]"
S VALMHDR(2)=$G(RCRDHDR)
Q
;
INIT ; -- init variables and list array
; Assumes existence of DFN
D GETALL(DFN)
Q
;
GETALL(DFN) ; Build ListMan display array of patient lab information
; Input variables:
; DFN - IEN for File 2
; Output variables:
; VALMAR - Builds ListMan array
; VALMCNT - List array count
; VALM0
N DA0,TEXT,LABDT,IENS,REFLOW,REFHIGH,BKMRNG,LAB,BKMVDT,VSTIEN,BKMPVDT
N BKMACC,BKMPAR,BKMCHI,BKMRVDT
D ^XBFMK
S VALMCNT=0,VALMAR="^TMP(""BKMVA41"","""_$J_""")",VALM0=""
;
;PRXM/HC/BHS - 06/14/2006 - Resort lab test by reverse date, acc #, parent lab, child lab
; to match PAT/REC/LAB display order per IHS
; Commented out code removed for readability and size constraints
S LAB=0,LABDT=0
F S LAB=$O(^AUPNVLAB("AC",DFN,LAB)) Q:LAB="" D
. S DA=LAB,IENS=$$IENS^DILF(.DA)
. S LABDT=$$GET1^DIQ(9000010.09,IENS,"1201","I")
. ; If event d/t is null, try visit d/t
. I LABDT="" D Q:LABDT=""
. . S VSTIEN=$$GET1^DIQ(9000010.09,IENS,".03","I") Q:VSTIEN=""
. . S LABDT=$$GET1^DIQ(9000010,VSTIEN_",",".01","I")
. S BKMRVDT=9999999-(LABDT\1)
. S BKMACC=$E($$GET1^DIQ(9000010.09,IENS,".06","E"),1,2)
. I BKMACC="" S BKMACC="ZZ"
. S BKMPAR=$S($$GET1^DIQ(9000010.09,IENS,"1208","I")]"":$$GET1^DIQ(9000010.09,IENS,"1208","I"),1:LAB)
. S BKMCHI=$S($$GET1^DIQ(9000010.09,IENS,"1208","I")="":0,1:LAB)
. S ^TMP("BKMVA41",$J,"NEW_SORT",BKMRVDT,BKMACC,BKMPAR,BKMCHI)=""
; Build display records
S (BKMRVDT,BKMPVDT)="" F S BKMRVDT=$O(^TMP("BKMVA41",$J,"NEW_SORT",BKMRVDT)) Q:BKMRVDT="" D
. S BKMACC="" F S BKMACC=$O(^TMP("BKMVA41",$J,"NEW_SORT",BKMRVDT,BKMACC)) Q:BKMACC="" D
. . S BKMPAR="" F S BKMPAR=$O(^TMP("BKMVA41",$J,"NEW_SORT",BKMRVDT,BKMACC,BKMPAR)) Q:BKMPAR="" D
. . . S BKMCHI="" F S BKMCHI=$O(^TMP("BKMVA41",$J,"NEW_SORT",BKMRVDT,BKMACC,BKMPAR,BKMCHI)) Q:BKMCHI="" D
. . . . S DA=$S(BKMCHI>0:BKMCHI,1:BKMPAR)
. . . . S IENS=$$IENS^DILF(.DA)
. . . . S BKMVDT=9999999-BKMRVDT
. . . . S VALMCNT=$G(VALMCNT)+1
. . . . S TEXT=""
. . . . ; Display only date and only when not a duplicate of previous entry
. . . . S TEXT=$$SETFLD^VALM1($S((BKMVDT\1)'=(BKMPVDT\1):$$FMTE^XLFDT(BKMVDT\1,"5Z"),1:""),TEXT,"Visit")
. . . . S TEXT=$$SETFLD^VALM1($S(BKMCHI>0:" ",1:"")_$$GET1^DIQ(9000010.09,IENS,".01","E"),TEXT,"Lab Test")
. . . . S TEXT=$$SETFLD^VALM1($$GET1^DIQ(9000010.09,IENS,".04","E"),TEXT,"Results")
. . . . S TEXT=$$SETFLD^VALM1($$GET1^DIQ(9000010.09,IENS,"1101","E"),TEXT,"Units")
. . . . S REFLOW=$$GET1^DIQ(9000010.09,IENS,"1104","E")
. . . . S REFHIGH=$$GET1^DIQ(9000010.09,IENS,"1105","E")
. . . . S BKMRNG=REFLOW_"-"_REFHIGH
. . . . I BKMRNG="-" S BKMRNG=""
. . . . S TEXT=$$SETFLD^VALM1(BKMRNG,TEXT,"RefRange")
. . . . D SET^VALM10(VALMCNT,TEXT)
. . . . S BKMPVDT=BKMVDT
D ^XBFMK
Q
;
GETDA(DFN,VALUE) ; Return IEN for the Patient DFN with the Register value
; Search for the appropriate register VALUE for the patient DFN and return the
; patient IEN in the variable DA.
; If the variable VALUE contains a 1 then the IEN for the patient in the
; HIV Management System is returned.
N DA
S DA="" F S DA=$O(^AUPNVLAB("AC",DFN,DA)) Q:DA=""
Q DA
;
HELP ; -- help code
S X="?" D DISP^XQORM1 W !
Q
;
EXIT ;clean up used variables
K ^TMP("BKMVA41",$J)
K VALM0,VALMAR,VALMCNT,VALMHDR
Q
;
;
BKMVA41 ;PRXM/HC/JGH - HMS PATIENT REGISTER; [ 1/19/2005 7:16 PM ] ; 13 Apr 2005 5:42 PM
+1 ;;2.1;HIV MANAGEMENT SYSTEM;;Feb 07, 2011
+2 ;
+3 QUIT
+4 ;
EN ;ENTRY POINT -- ListMan template BKMV PCC LAB REVIEW
+1 ; Assumes existence of DFN,DUZ
+2 NEW HIVIEN
+3 SET HIVIEN=$$HIVIEN^BKMIXX3()
+4 IF HIVIEN=""
WRITE !,"There is no HMS register defined."
HANG 2
QUIT
+5 IF '$$VALID^BKMIXX3(DUZ)
QUIT
+6 KILL ^TMP("BKMVA41",$JOB)
+7 DO ^XBFMK
+8 DO EN^VALM("BKMV PCC LAB REVIEW")
+9 DO ^XBFMK
+10 DO EXIT
+11 QUIT
+12 ;
HDR ; -- header code
+1 ; Assumes existence of DUZ
+2 NEW DA,IENS,SITE
+3 SET DA=$GET(DUZ(2))
SET IENS=$$IENS^DILF(.DA)
SET SITE=$$GET1^DIQ(4,IENS,.01,"E")
+4 SET VALMHDR(1)=$$PAD^BKMIXX4("",">"," ",(80-$LENGTH(SITE)+2)\2)_"["_$GET(SITE)_"]"
+5 SET VALMHDR(2)=$GET(RCRDHDR)
+6 QUIT
+7 ;
INIT ; -- init variables and list array
+1 ; Assumes existence of DFN
+2 DO GETALL(DFN)
+3 QUIT
+4 ;
GETALL(DFN) ; Build ListMan display array of patient lab information
+1 ; Input variables:
+2 ; DFN - IEN for File 2
+3 ; Output variables:
+4 ; VALMAR - Builds ListMan array
+5 ; VALMCNT - List array count
+6 ; VALM0
+7 NEW DA0,TEXT,LABDT,IENS,REFLOW,REFHIGH,BKMRNG,LAB,BKMVDT,VSTIEN,BKMPVDT
+8 NEW BKMACC,BKMPAR,BKMCHI,BKMRVDT
+9 DO ^XBFMK
+10 SET VALMCNT=0
SET VALMAR="^TMP(""BKMVA41"","""_$JOB_""")"
SET VALM0=""
+11 ;
+12 ;PRXM/HC/BHS - 06/14/2006 - Resort lab test by reverse date, acc #, parent lab, child lab
+13 ; to match PAT/REC/LAB display order per IHS
+14 ; Commented out code removed for readability and size constraints
+15 SET LAB=0
SET LABDT=0
+16 FOR
SET LAB=$ORDER(^AUPNVLAB("AC",DFN,LAB))
IF LAB=""
QUIT
Begin DoDot:1
+17 SET DA=LAB
SET IENS=$$IENS^DILF(.DA)
+18 SET LABDT=$$GET1^DIQ(9000010.09,IENS,"1201","I")
+19 ; If event d/t is null, try visit d/t
+20 IF LABDT=""
Begin DoDot:2
+21 SET VSTIEN=$$GET1^DIQ(9000010.09,IENS,".03","I")
IF VSTIEN=""
QUIT
+22 SET LABDT=$$GET1^DIQ(9000010,VSTIEN_",",".01","I")
End DoDot:2
IF LABDT=""
QUIT
+23 SET BKMRVDT=9999999-(LABDT\1)
+24 SET BKMACC=$EXTRACT($$GET1^DIQ(9000010.09,IENS,".06","E"),1,2)
+25 IF BKMACC=""
SET BKMACC="ZZ"
+26 SET BKMPAR=$SELECT($$GET1^DIQ(9000010.09,IENS,"1208","I")]"":$$GET1^DIQ(9000010.09,IENS,"1208","I"),1:LAB)
+27 SET BKMCHI=$SELECT($$GET1^DIQ(9000010.09,IENS,"1208","I")="":0,1:LAB)
+28 SET ^TMP("BKMVA41",$JOB,"NEW_SORT",BKMRVDT,BKMACC,BKMPAR,BKMCHI)=""
End DoDot:1
+29 ; Build display records
+30 SET (BKMRVDT,BKMPVDT)=""
FOR
SET BKMRVDT=$ORDER(^TMP("BKMVA41",$JOB,"NEW_SORT",BKMRVDT))
IF BKMRVDT=""
QUIT
Begin DoDot:1
+31 SET BKMACC=""
FOR
SET BKMACC=$ORDER(^TMP("BKMVA41",$JOB,"NEW_SORT",BKMRVDT,BKMACC))
IF BKMACC=""
QUIT
Begin DoDot:2
+32 SET BKMPAR=""
FOR
SET BKMPAR=$ORDER(^TMP("BKMVA41",$JOB,"NEW_SORT",BKMRVDT,BKMACC,BKMPAR))
IF BKMPAR=""
QUIT
Begin DoDot:3
+33 SET BKMCHI=""
FOR
SET BKMCHI=$ORDER(^TMP("BKMVA41",$JOB,"NEW_SORT",BKMRVDT,BKMACC,BKMPAR,BKMCHI))
IF BKMCHI=""
QUIT
Begin DoDot:4
+34 SET DA=$SELECT(BKMCHI>0:BKMCHI,1:BKMPAR)
+35 SET IENS=$$IENS^DILF(.DA)
+36 SET BKMVDT=9999999-BKMRVDT
+37 SET VALMCNT=$GET(VALMCNT)+1
+38 SET TEXT=""
+39 ; Display only date and only when not a duplicate of previous entry
+40 SET TEXT=$$SETFLD^VALM1($SELECT((BKMVDT\1)'=(BKMPVDT\1):$$FMTE^XLFDT(BKMVDT\1,"5Z"),1:""),TEXT,"Visit")
+41 SET TEXT=$$SETFLD^VALM1($SELECT(BKMCHI>0:" ",1:"")_$$GET1^DIQ(9000010.09,IENS,".01","E"),TEXT,"Lab Test")
+42 SET TEXT=$$SETFLD^VALM1($$GET1^DIQ(9000010.09,IENS,".04","E"),TEXT,"Results")
+43 SET TEXT=$$SETFLD^VALM1($$GET1^DIQ(9000010.09,IENS,"1101","E"),TEXT,"Units")
+44 SET REFLOW=$$GET1^DIQ(9000010.09,IENS,"1104","E")
+45 SET REFHIGH=$$GET1^DIQ(9000010.09,IENS,"1105","E")
+46 SET BKMRNG=REFLOW_"-"_REFHIGH
+47 IF BKMRNG="-"
SET BKMRNG=""
+48 SET TEXT=$$SETFLD^VALM1(BKMRNG,TEXT,"RefRange")
+49 DO SET^VALM10(VALMCNT,TEXT)
+50 SET BKMPVDT=BKMVDT
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+51 DO ^XBFMK
+52 QUIT
+53 ;
GETDA(DFN,VALUE) ; Return IEN for the Patient DFN with the Register value
+1 ; Search for the appropriate register VALUE for the patient DFN and return the
+2 ; patient IEN in the variable DA.
+3 ; If the variable VALUE contains a 1 then the IEN for the patient in the
+4 ; HIV Management System is returned.
+5 NEW DA
+6 SET DA=""
FOR
SET DA=$ORDER(^AUPNVLAB("AC",DFN,DA))
IF DA=""
QUIT
+7 QUIT DA
+8 ;
HELP ; -- help code
+1 SET X="?"
DO DISP^XQORM1
WRITE !
+2 QUIT
+3 ;
EXIT ;clean up used variables
+1 KILL ^TMP("BKMVA41",$JOB)
+2 KILL VALM0,VALMAR,VALMCNT,VALMHDR
+3 QUIT
+4 ;
+5 ;
