BHSLAB1 ;IHS/CIA/MGH - Health Summary for V LAB file ;30-May-2014 15:47;DU
;;1.0;HEALTH SUMMARY COMPONENTS;**1,2,9**;March 17, 2006;Build 16
;===================================================================
;Most recent labs for VA health summary from IHS V LABs
;Taken from APCHS3A
; IHS/TUCSON/LAB - PART 3A OF APCHS -- SUMMARY PRODUCTION COMPONENTS ;
;;2.0;IHS RPMS/PCC Health Summary;**3,9**;JUN 24, 1997
;IHS/MSC/MGH Patch 13 changes included
;Patch 6 includes patch 16 changes
MRL ; ******************** MOST RECENT LAB * 9000010.09 *******
N BHSPAT,BHSQ
S BHSPAT=DFN
I '$D(^AUPNVLAB("AA",BHSPAT)) D EKGLAB G MRLX
D CKP^GMTSUP Q:$D(GMTSQIT)
; <SETUP>
; <PROCESS>
D LBLD,LPRT
D EKGLAB
;now display lab refusals
S BHST="LAB",BHSFN=60 D DISPREF^BHSRAD
K BHST,BHSFN
; <CLEANUP>
MRLX K BHSLT,BHSLR,BHSLTX,BHSLRT,BHSLL,BHSLW,BHSNMX,BHSDFN,BHSIVD,BHSLTD,BHSN,Y
K ^TMP($J,"BHS"),^TMP($J,"BHS1")
Q
; <BUILD>
LBLD K ^TMP($J,"BHS","LAB"),^TMP($J,"BHS1")
S BHSLRT="" F BHSQ=0:0 S BHSLRT=$O(^AUPNVLAB("AA",BHSPAT,BHSLRT)) Q:BHSLRT="" D LDATE
D REORDER
Q
REORDER ;reorder by accession, parent and child
N %,%1,%2,X
S X=0 F S X=$O(^TMP($J,"BHS","LAB",X)) Q:X'=+X D
.S Y=$P(^TMP($J,"BHS","LAB",X),U,3)
.S %=$E($P(^AUPNVLAB(Y,0),U,6),1,2) S:%="" %="ZZ"
.S %1=$S($P($G(^AUPNVLAB(Y,12)),U,8)]"":$P(^AUPNVLAB(Y,12),U,8),1:Y)
.S %2=$S($P($G(^AUPNVLAB(Y,12)),U,8)="":0,1:Y)
.S ^TMP($J,"BHS1",%,%1,%2,X)=^TMP($J,"BHS","LAB",X)
.Q
K ^TMP($J,"BHS")
Q
LDATE S BHSIVD=$O(^AUPNVLAB("AA",BHSPAT,BHSLRT,0))
S BHSDFN=0 F S BHSDFN=$O(^AUPNVLAB("AA",BHSPAT,BHSLRT,BHSIVD,BHSDFN)) Q:BHSDFN'=+BHSDFN D
.D:BHSIVD&(BHSIVD'>GMTSDLM) LSET
Q
LSET ;
S BHSN=^AUPNVLAB(BHSDFN,0),BHSLR=$P(BHSN,U,4)
I $P($G(^AUPNVLAB(BHSDFN,11)),U,9)="R",BHSLR="",$$VALI^XBDIQ1(60,$P(BHSN,U),999999901) Q ;do not display tests that are resulted, result is null and flag says don't display
;IHS/MSC/MGH Patch 13 mod
I BHSLR]"",BHSLR'=" ",$P(BHSN,U,5)]"" S BHSLR=BHSLR_" ("_$P(BHSN,U,5)_")"
I BHSLR="",$P($G(^TMP($J,"BHS","LAB",BHSLRT)),U,2)]"" Q
S ^TMP($J,"BHS","LAB",BHSLRT)=(-BHSIVD\1+9999999)_U_BHSLR_U_BHSDFN S BHSLTX=$P(^LAB(60,BHSLRT,0),U,1)
Q
; <PRINT>
LPRT ;
W ?55,"UNITS",?64,"REF RANGE",!
S BHSACC="" F S BHSACC=$O(^TMP($J,"BHS1",BHSACC)) Q:BHSACC=""!($D(GMTSQIT)) D
.S BHSPAR=0 F S BHSPAR=$O(^TMP($J,"BHS1",BHSACC,BHSPAR)) Q:BHSPAR'=+BHSPAR!($D(GMTSQIT)) D
..S APCHCHIL="" F S APCHCHIL=$O(^TMP($J,"BHS1",BHSACC,BHSPAR,APCHCHIL)) Q:APCHCHIL="" D
...S BHSLT=$O(^TMP($J,"BHS1",BHSACC,BHSPAR,APCHCHIL,0))
...S BHSDFN=$P(^TMP($J,"BHS1",BHSACC,BHSPAR,APCHCHIL,BHSLT),U,3)
...S X=$P(^TMP($J,"BHS1",BHSACC,BHSPAR,APCHCHIL,BHSLT),U,1),BHSLR=$P(^TMP($J,"BHS1",BHSACC,BHSPAR,APCHCHIL,BHSLT),U,2) D REGDT4^GMTSU S BHSLTD=X
...D LPRT2
K APCHCHIL,BHSPAR,BHSACC,BHSLT
Q
LPRT2 ;
S BHSLTX=$P(^LAB(60,BHSLT,0),U)
D CKP^GMTSUP Q:$D(GMSQIT) I GMTSNPG W ?55,"UNITS",?64,"REF RANGE",!
W:APCHCHIL " " W BHSLTX,?35,BHSLTD,?45,BHSLR
W ?55,$P($G(^AUPNVLAB(BHSDFN,11)),U)
I $P($G(^AUPNVLAB(BHSDFN,11)),U)]"" W ?64,$P(^AUPNVLAB(BHSDFN,11),U,4)_"-"_$P(^AUPNVLAB(BHSDFN,11),U,5)
W ?78," ",$P($G(^AUPNVLAB(BHSDFN,11)),U,9)
W !
Q
;
EKGLAB ;ENTRY POINT - EKG display in most recent lab panel
Q:'$D(^AUPNVDXP("AC",BHSPAT))
K BHS
S BHSERR=$$START1^APCLDF(BHSPAT_"^LAST DIAGNOSTIC ECG SUMMARY","BHS(")
G:BHSERR EKGLABX
; *array BHS(1)="DATE^RESULT^DIAG PROC^VDIAG PROCEDURE IEN^AUPNVDXP^VISIT IEN"
K BHSERR
S BHSIVD=$S($D(BHS(1)):9999999-$P($P(BHS(1),U,1),".",1),1:"")
Q:'BHSIVD!(BHSIVD>GMTSDLM)
S (BHSLTX,BHSLT)="EKG"
S BHSLRT("EKG")=$P(BHS(1),U,1)_"^"_$P(BHS(1),U,2)
D EKGPRT ; computes/prints ekg info
EKGLABX ;
K BHSERR,BHS(1)
Q
;
EKGPRT ;computers/prints ekg info
S X=$P(BHSLRT(BHSLT),U,1) D REGDT4^GMTSU S BHSLTD=X
S BHSLR=$P(BHSLRT(BHSLT),U,2)
S BHSLR=$S(BHSLR="N":"NORMAL",BHSLR="A":"ABNORMAL",BHSLR="B":"BORDERLINE",1:"<none recorded>") ;IHS/CMI/LAB added borderline
S BHSLW=$S($G(BHSLW):BHSLW,1:28)
D CKP^GMTSUP Q:$D(GMTSQIT)
W !,BHSLTX,?BHSLW,BHSLTD," ",BHSLR,!
Q
;
BHSLAB1 ;IHS/CIA/MGH - Health Summary for V LAB file ;30-May-2014 15:47;DU
+1 ;;1.0;HEALTH SUMMARY COMPONENTS;**1,2,9**;March 17, 2006;Build 16
+2 ;===================================================================
+3 ;Most recent labs for VA health summary from IHS V LABs
+4 ;Taken from APCHS3A
+5 ; IHS/TUCSON/LAB - PART 3A OF APCHS -- SUMMARY PRODUCTION COMPONENTS ;
+6 ;;2.0;IHS RPMS/PCC Health Summary;**3,9**;JUN 24, 1997
+7 ;IHS/MSC/MGH Patch 13 changes included
+8 ;Patch 6 includes patch 16 changes
MRL ; ******************** MOST RECENT LAB * 9000010.09 *******
+1 NEW BHSPAT,BHSQ
+2 SET BHSPAT=DFN
+3 IF '$DATA(^AUPNVLAB("AA",BHSPAT))
DO EKGLAB
GOTO MRLX
+4 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+5 ; <SETUP>
+6 ; <PROCESS>
+7 DO LBLD
DO LPRT
+8 DO EKGLAB
+9 ;now display lab refusals
+10 SET BHST="LAB"
SET BHSFN=60
DO DISPREF^BHSRAD
+11 KILL BHST,BHSFN
+12 ; <CLEANUP>
MRLX KILL BHSLT,BHSLR,BHSLTX,BHSLRT,BHSLL,BHSLW,BHSNMX,BHSDFN,BHSIVD,BHSLTD,BHSN,Y
+1 KILL ^TMP($JOB,"BHS"),^TMP($JOB,"BHS1")
+2 QUIT
+3 ; <BUILD>
LBLD KILL ^TMP($JOB,"BHS","LAB"),^TMP($JOB,"BHS1")
+1 SET BHSLRT=""
FOR BHSQ=0:0
SET BHSLRT=$ORDER(^AUPNVLAB("AA",BHSPAT,BHSLRT))
IF BHSLRT=""
QUIT
DO LDATE
+2 DO REORDER
+3 QUIT
REORDER ;reorder by accession, parent and child
+1 NEW %,%1,%2,X
+2 SET X=0
FOR
SET X=$ORDER(^TMP($JOB,"BHS","LAB",X))
IF X'=+X
QUIT
Begin DoDot:1
+3 SET Y=$PIECE(^TMP($JOB,"BHS","LAB",X),U,3)
+4 SET %=$EXTRACT($PIECE(^AUPNVLAB(Y,0),U,6),1,2)
IF %=""
SET %="ZZ"
+5 SET %1=$SELECT($PIECE($GET(^AUPNVLAB(Y,12)),U,8)]"":$PIECE(^AUPNVLAB(Y,12),U,8),1:Y)
+6 SET %2=$SELECT($PIECE($GET(^AUPNVLAB(Y,12)),U,8)="":0,1:Y)
+7 SET ^TMP($JOB,"BHS1",%,%1,%2,X)=^TMP($JOB,"BHS","LAB",X)
+8 QUIT
End DoDot:1
+9 KILL ^TMP($JOB,"BHS")
+10 QUIT
LDATE SET BHSIVD=$ORDER(^AUPNVLAB("AA",BHSPAT,BHSLRT,0))
+1 SET BHSDFN=0
FOR
SET BHSDFN=$ORDER(^AUPNVLAB("AA",BHSPAT,BHSLRT,BHSIVD,BHSDFN))
IF BHSDFN'=+BHSDFN
QUIT
Begin DoDot:1
+2 IF BHSIVD&(BHSIVD'>GMTSDLM)
DO LSET
End DoDot:1
+3 QUIT
LSET ;
+1 SET BHSN=^AUPNVLAB(BHSDFN,0)
SET BHSLR=$PIECE(BHSN,U,4)
+2 ;do not display tests that are resulted, result is null and flag says don't display
IF $PIECE($GET(^AUPNVLAB(BHSDFN,11)),U,9)="R"
IF BHSLR=""
IF $$VALI^XBDIQ1(60,$PIECE(BHSN,U),999999901)
QUIT
+3 ;IHS/MSC/MGH Patch 13 mod
+4 IF BHSLR]""
IF BHSLR'=" "
IF $PIECE(BHSN,U,5)]""
SET BHSLR=BHSLR_" ("_$PIECE(BHSN,U,5)_")"
+5 IF BHSLR=""
IF $PIECE($GET(^TMP($JOB,"BHS","LAB",BHSLRT)),U,2)]""
QUIT
+6 SET ^TMP($JOB,"BHS","LAB",BHSLRT)=(-BHSIVD\1+9999999)_U_BHSLR_U_BHSDFN
SET BHSLTX=$PIECE(^LAB(60,BHSLRT,0),U,1)
+7 QUIT
+8 ; <PRINT>
LPRT ;
+1 WRITE ?55,"UNITS",?64,"REF RANGE",!
+2 SET BHSACC=""
FOR
SET BHSACC=$ORDER(^TMP($JOB,"BHS1",BHSACC))
IF BHSACC=""!($DATA(GMTSQIT))
QUIT
Begin DoDot:1
+3 SET BHSPAR=0
FOR
SET BHSPAR=$ORDER(^TMP($JOB,"BHS1",BHSACC,BHSPAR))
IF BHSPAR'=+BHSPAR!($DATA(GMTSQIT))
QUIT
Begin DoDot:2
+4 SET APCHCHIL=""
FOR
SET APCHCHIL=$ORDER(^TMP($JOB,"BHS1",BHSACC,BHSPAR,APCHCHIL))
IF APCHCHIL=""
QUIT
Begin DoDot:3
+5 SET BHSLT=$ORDER(^TMP($JOB,"BHS1",BHSACC,BHSPAR,APCHCHIL,0))
+6 SET BHSDFN=$PIECE(^TMP($JOB,"BHS1",BHSACC,BHSPAR,APCHCHIL,BHSLT),U,3)
+7 SET X=$PIECE(^TMP($JOB,"BHS1",BHSACC,BHSPAR,APCHCHIL,BHSLT),U,1)
SET BHSLR=$PIECE(^TMP($JOB,"BHS1",BHSACC,BHSPAR,APCHCHIL,BHSLT),U,2)
DO REGDT4^GMTSU
SET BHSLTD=X
+8 DO LPRT2
End DoDot:3
End DoDot:2
End DoDot:1
+9 KILL APCHCHIL,BHSPAR,BHSACC,BHSLT
+10 QUIT
LPRT2 ;
+1 SET BHSLTX=$PIECE(^LAB(60,BHSLT,0),U)
+2 DO CKP^GMTSUP
IF $DATA(GMSQIT)
QUIT
IF GMTSNPG
WRITE ?55,"UNITS",?64,"REF RANGE",!
+3 IF APCHCHIL
WRITE " "
WRITE BHSLTX,?35,BHSLTD,?45,BHSLR
+4 WRITE ?55,$PIECE($GET(^AUPNVLAB(BHSDFN,11)),U)
+5 IF $PIECE($GET(^AUPNVLAB(BHSDFN,11)),U)]""
WRITE ?64,$PIECE(^AUPNVLAB(BHSDFN,11),U,4)_"-"_$PIECE(^AUPNVLAB(BHSDFN,11),U,5)
+6 WRITE ?78," ",$PIECE($GET(^AUPNVLAB(BHSDFN,11)),U,9)
+7 WRITE !
+8 QUIT
+9 ;
EKGLAB ;ENTRY POINT - EKG display in most recent lab panel
+1 IF '$DATA(^AUPNVDXP("AC",BHSPAT))
QUIT
+2 KILL BHS
+3 SET BHSERR=$$START1^APCLDF(BHSPAT_"^LAST DIAGNOSTIC ECG SUMMARY","BHS(")
+4 IF BHSERR
GOTO EKGLABX
+5 ; *array BHS(1)="DATE^RESULT^DIAG PROC^VDIAG PROCEDURE IEN^AUPNVDXP^VISIT IEN"
+6 KILL BHSERR
+7 SET BHSIVD=$SELECT($DATA(BHS(1)):9999999-$PIECE($PIECE(BHS(1),U,1),".",1),1:"")
+8 IF 'BHSIVD!(BHSIVD>GMTSDLM)
QUIT
+9 SET (BHSLTX,BHSLT)="EKG"
+10 SET BHSLRT("EKG")=$PIECE(BHS(1),U,1)_"^"_$PIECE(BHS(1),U,2)
+11 ; computes/prints ekg info
DO EKGPRT
EKGLABX ;
+1 KILL BHSERR,BHS(1)
+2 QUIT
+3 ;
EKGPRT ;computers/prints ekg info
+1 SET X=$PIECE(BHSLRT(BHSLT),U,1)
DO REGDT4^GMTSU
SET BHSLTD=X
+2 SET BHSLR=$PIECE(BHSLRT(BHSLT),U,2)
+3 ;IHS/CMI/LAB added borderline
SET BHSLR=$SELECT(BHSLR="N":"NORMAL",BHSLR="A":"ABNORMAL",BHSLR="B":"BORDERLINE",1:"<none recorded>")
+4 SET BHSLW=$SELECT($GET(BHSLW):BHSLW,1:28)
+5 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+6 WRITE !,BHSLTX,?BHSLW,BHSLTD," ",BHSLR,!
+7 QUIT
+8 ;
