BHSLAB1.m

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       ;