BHSLABA ;IHS/CIA/MGH - Health Summary for V lab file ;04-Aug-2009 15:43;MGH
;;1.0;HEALTH SUMMARY COMPONENTS;**1,2,3**;March 17, 2006
;===================================================================
;Taken from APCHS3A
; IHS/TUCSON/LAB - PART 3A OF APCHS -- SUMMARY PRODUCTION COMPONENTS ; [ 07/08/02 3:25 PM ]
;;2.0;IHS RPMS/PCC Health Summary;**3,9**;JUN 24, 1997
;Patch 1 includes changes for patch 13
;Patch 2 for changes in patch 16
;Patch 3 for addition of date/time of result
MRL ; ******************** MOST RECENT LAB * 9000010.09 *******
N BHSPAT,BHSQ
S BHSPAT=DFN
I '$D(^AUPNVLAB("AA",BHSPAT)) D EKGLAB S BHST="LAB",BHSFN=60 D DISPREF^BHSRAD G MRLX
D CKP^GMTSUP Q:$D(GMTSQIT)
; <SETUP>
; <PROCESS>
D LBLD,LPRT
D EKGLAB
;Patch 2, lab refusals
S BHST="LAB",BHSFN=60 D DISPREF^BHSRAD
K BHST,BHSFN
; <CLEANUP>
MRLX K BHSLT,BHSX,BHSLR,BHSLTX,BHSLRT,BHSLL,BHSLW,BHSNMX,BHSDFN,BHSIVD,BHSLTD,BHSN,Y,BHSRDT,BHSLTX
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: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
I 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 ?2,"TEST",?23,"RESULT DT/TIME",?39,"VISIT",?50,"RESULT",?60,"UNITS",?70,"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)
S BHSRDT=$P($G(^AUPNVLAB(BHSDFN,12)),U,12) I BHSRDT]"" S BHSRDT=$$DATE^APCHSMU($P(BHSRDT,"."))_"@"_$P($P($$FMTE^XLFDT(BHSRDT),"@",2),":",1,2)
D CKP^GMTSUP Q:$D(GMTSQIT) I GMTSNPG W ?2,"TEST",?23,"RESULT DT/TIME",?39,"VISIT",?47,"RESULT",?60,"UNITS",?70,"REF RANGE",!
W:APCHCHIL " " W $E(BHSLTX,1,20),?23,BHSRDT,?38,BHSLTD,?50,BHSLR
W ?60,$P($G(^AUPNVLAB(BHSDFN,11)),U)
I $P($G(^AUPNVLAB(BHSDFN,11)),U,4)]""!($P($G(^AUPNVLAB(BHSDFN,11)),U,5)]"") W ?70,$P(^AUPNVLAB(BHSDFN,11),U,4)_"-"_$P(^AUPNVLAB(BHSDFN,11),U,5)
;I '$P(^APCHSCTL(APCHSTYP,0),U,7) W ! Q
;print out comments per Dorothy
S BHSX=0 F S BHSX=$O(^AUPNVLAB(BHSDFN,21,BHSX)) Q:BHSX'=+BHSX!($D(GMTSQIT)) D
.D CKP^GMTSUP Q:$D(GMTSQIT)
.W !,?1,^AUPNVLAB(BHSDFN,21,BHSX,0)
F BHSX=1:1:3 Q:$D(GMTSQIT) I $P($G(^AUPNVLAB(BHSDFN,13)),U,BHSX)]"" D
.D CKP^GMTSUP Q:$D(GMTSQIT)
.W !,$P(^AUPNVLAB(BHSDFN,13),U,BHSX)
;W ?78," ",$P($G(^AUPNVLAB(APCHSDFN,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)
W !,BHSLTX,?BHSLW,BHSLTD," ",BHSLR,!
Q
;
BHSLABA ;IHS/CIA/MGH - Health Summary for V lab file ;04-Aug-2009 15:43;MGH
+1 ;;1.0;HEALTH SUMMARY COMPONENTS;**1,2,3**;March 17, 2006
+2 ;===================================================================
+3 ;Taken from APCHS3A
+4 ; IHS/TUCSON/LAB - PART 3A OF APCHS -- SUMMARY PRODUCTION COMPONENTS ; [ 07/08/02 3:25 PM ]
+5 ;;2.0;IHS RPMS/PCC Health Summary;**3,9**;JUN 24, 1997
+6 ;Patch 1 includes changes for patch 13
+7 ;Patch 2 for changes in patch 16
+8 ;Patch 3 for addition of date/time of result
MRL ; ******************** MOST RECENT LAB * 9000010.09 *******
+1 NEW BHSPAT,BHSQ
+2 SET BHSPAT=DFN
+3 IF '$DATA(^AUPNVLAB("AA",BHSPAT))
DO EKGLAB
SET BHST="LAB"
SET BHSFN=60
DO DISPREF^BHSRAD
GOTO MRLX
+4 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+5 ; <SETUP>
+6 ; <PROCESS>
+7 DO LBLD
DO LPRT
+8 DO EKGLAB
+9 ;Patch 2, lab refusals
+10 SET BHST="LAB"
SET BHSFN=60
DO DISPREF^BHSRAD
+11 KILL BHST,BHSFN
+12 ; <CLEANUP>
MRLX KILL BHSLT,BHSX,BHSLR,BHSLTX,BHSLRT,BHSLL,BHSLW,BHSNMX,BHSDFN,BHSIVD,BHSLTD,BHSN,Y,BHSRDT,BHSLTX
+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
IF BHSIVD&(BHSIVD'>GMTSDLM)
DO LSET
+2 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 IF BHSLR]""
IF $PIECE(BHSN,U,5)]""
SET BHSLR=BHSLR_" ("_$PIECE(BHSN,U,5)_")"
+4 IF BHSLR=""
IF $PIECE($GET(^TMP($JOB,"BHS","LAB",BHSLRT)),U,2)]""
QUIT
+5 SET ^TMP($JOB,"BHS","LAB",BHSLRT)=(-BHSIVD\1+9999999)_U_BHSLR_U_BHSDFN
SET BHSLTX=$PIECE(^LAB(60,BHSLRT,0),U,1)
+6 QUIT
+7 ; <PRINT>
LPRT ;
+1 WRITE ?2,"TEST",?23,"RESULT DT/TIME",?39,"VISIT",?50,"RESULT",?60,"UNITS",?70,"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 SET BHSRDT=$PIECE($GET(^AUPNVLAB(BHSDFN,12)),U,12)
IF BHSRDT]""
SET BHSRDT=$$DATE^APCHSMU($PIECE(BHSRDT,"."))_"@"_$PIECE($PIECE($$FMTE^XLFDT(BHSRDT),"@",2),":",1,2)
+3 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
IF GMTSNPG
WRITE ?2,"TEST",?23,"RESULT DT/TIME",?39,"VISIT",?47,"RESULT",?60,"UNITS",?70,"REF RANGE",!
+4 IF APCHCHIL
WRITE " "
WRITE $EXTRACT(BHSLTX,1,20),?23,BHSRDT,?38,BHSLTD,?50,BHSLR
+5 WRITE ?60,$PIECE($GET(^AUPNVLAB(BHSDFN,11)),U)
+6 IF $PIECE($GET(^AUPNVLAB(BHSDFN,11)),U,4)]""!($PIECE($GET(^AUPNVLAB(BHSDFN,11)),U,5)]"")
WRITE ?70,$PIECE(^AUPNVLAB(BHSDFN,11),U,4)_"-"_$PIECE(^AUPNVLAB(BHSDFN,11),U,5)
+7 ;I '$P(^APCHSCTL(APCHSTYP,0),U,7) W ! Q
+8 ;print out comments per Dorothy
+9 SET BHSX=0
FOR
SET BHSX=$ORDER(^AUPNVLAB(BHSDFN,21,BHSX))
IF BHSX'=+BHSX!($DATA(GMTSQIT))
QUIT
Begin DoDot:1
+10 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+11 WRITE !,?1,^AUPNVLAB(BHSDFN,21,BHSX,0)
End DoDot:1
+12 FOR BHSX=1:1:3
IF $DATA(GMTSQIT)
QUIT
IF $PIECE($GET(^AUPNVLAB(BHSDFN,13)),U,BHSX)]""
Begin DoDot:1
+13 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+14 WRITE !,$PIECE(^AUPNVLAB(BHSDFN,13),U,BHSX)
End DoDot:1
+15 ;W ?78," ",$P($G(^AUPNVLAB(APCHSDFN,11)),U,9)
+16 WRITE !
+17 QUIT
+18 ;
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 WRITE !,BHSLTX,?BHSLW,BHSLTD," ",BHSLR,!
+6 QUIT
+7 ;
