Routine: APCHS3L

APCHS3L ; IHS/TUCSON/LAB - PART 3A OF APCHS -- SUMMARY PRODUCTION COMPONENTS ;

 ;;2.0;IHS PCC SUITE;**2**;MAY 14, 2009

MRL ; ******************** MOST RECENT LAB * 9000010.09 *******

 I '$D(^AUPNVLAB("AA",APCHSPAT)) D EKGLAB G MRLX

 X APCHSCKP Q:$D(APCHSQIT)

 X:'APCHSNPG APCHSBRK

 ; <SETUP>

 ; <PROCESS>

 D LBLD,LPRT

 D EKGLAB

 ;now display lab refusals

 S APCHST="LAB",APCHSFN=60 D DISPREF^APCHS3C

 K APCHST,APCHSFN

 ; <CLEANUP>

MRLX K APCHSLT,APCHSLR,APCHSLTX,APCHSLRT,APCHSLL,APCHSLW,APCHSNMX,APCHSDFN,APCHSIVD,APCHSLTD,APCHSN,Y

 K ^TMP($J,"APCHS"),^TMP($J,"APCHS1")

 ; <BUILD>

LBLD K ^TMP($J,"APCHS","LAB"),^TMP($J,"APCHS1")

 S APCHSLRT="" F APCHSQ=0:0 S APCHSLRT=$O(^AUPNVLAB("AA",APCHSPAT,APCHSLRT)) Q:APCHSLRT=""  D LDATE

 D REORDER

REORDER ;reorder by accession, parent and child

 S X=0 F  S X=$O(^TMP($J,"APCHS","LAB",X)) Q:X'=+X  D

 .S Y=$P(^TMP($J,"APCHS","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,"APCHS1",%,%1,%2,X)=^TMP($J,"APCHS","LAB",X)

.Q

 K ^TMP($J,"APCHS")

LDATE S APCHSIVD=$O(^AUPNVLAB("AA",APCHSPAT,APCHSLRT,0))

 S APCHSDFN=0 F  S APCHSDFN=$O(^AUPNVLAB("AA",APCHSPAT,APCHSLRT,APCHSIVD,APCHSDFN)) Q:APCHSDFN'=+APCHSDFN   D:APCHSIVD&(APCHSIVD'>APCHSDLM) LSET

LSET ;

 S APCHSN=^AUPNVLAB(APCHSDFN,0),APCHSLR=$P(APCHSN,U,4)

 I $P($G(^AUPNVLAB(APCHSDFN,11)),U,9)="R",APCHSLR="",$$VALI^XBDIQ1(60,$P(APCHSN,U),999999901) Q  ;do not display tests that are resulted, result is null and flag says don't display

 I APCHSLR]"",APCHSLR'=" ",$P(APCHSN,U,5)]"" S APCHSLR=APCHSLR_" ("_$P(APCHSN,U,5)_")"

 I APCHSLR="",$P($G(^TMP($J,"APCHS","LAB",APCHSLRT)),U,2)]"" Q

 S ^TMP($J,"APCHS","LAB",APCHSLRT)=(-APCHSIVD\1+9999999)_U_APCHSLR_U_APCHSDFN S APCHSLTX=$P(^LAB(60,APCHSLRT,0),U,1)

 ; <PRINT>

LPRT ;

 W ?55,"UNITS",?64,"REF RANGE",!

 S APCHSACC="" F  S APCHSACC=$O(^TMP($J,"APCHS1",APCHSACC)) Q:APCHSACC=""!($D(APCHSQIT))  D

 .S APCHSPAR=0 F  S APCHSPAR=$O(^TMP($J,"APCHS1",APCHSACC,APCHSPAR)) Q:APCHSPAR'=+APCHSPAR!($D(APCHSQIT))  D

 ..S APCHCHIL="" F  S APCHCHIL=$O(^TMP($J,"APCHS1",APCHSACC,APCHSPAR,APCHCHIL)) Q:APCHCHIL=""  D

 ...S APCHSLT=$O(^TMP($J,"APCHS1",APCHSACC,APCHSPAR,APCHCHIL,0))

 ...S APCHSDFN=$P(^TMP($J,"APCHS1",APCHSACC,APCHSPAR,APCHCHIL,APCHSLT),U,3)

 ...S Y=$P(^TMP($J,"APCHS1",APCHSACC,APCHSPAR,APCHCHIL,APCHSLT),U,1),APCHSLR=$P(^TMP($J,"APCHS1",APCHSACC,APCHSPAR,APCHCHIL,APCHSLT),U,2) X APCHSCVD S APCHSLTD=Y

 ...D LPRT2

 K APCHCHIL,APCHSPAR,APCHSACC,APCHSLT

LPRT2 ;

 S APCHSLTX=$P(^LAB(60,APCHSLT,0),U)

 X APCHSCKP Q:$D(APCHSQIT)  I APCHSNPG W ?55,"UNITS",?64,"REF RANGE",!

 W:APCHCHIL "  " W APCHSLTX,?35,APCHSLTD,?45,APCHSLR

 W ?55,$P($G(^AUPNVLAB(APCHSDFN,11)),U)

 I $P($G(^AUPNVLAB(APCHSDFN,11)),U,4)]""!($P($G(^AUPNVLAB(APCHSDFN,11)),U,5)]"") W ?64,$P(^AUPNVLAB(APCHSDFN,11),U,4)_"-"_$P(^AUPNVLAB(APCHSDFN,11),U,5)

 I '$P(^APCHSCTL(APCHSTYP,0),U,7) W ! Q

 ;print out comments per Dorothy

 S APCHSX=0 F  S APCHSX=$O(^AUPNVLAB(APCHSDFN,21,APCHSX)) Q:APCHSX'=+APCHSX!($D(APCHSQIT))  D

 .X APCHSCKP Q:$D(APCHSQIT)

 .W !,?1,^AUPNVLAB(APCHSDFN,21,APCHSX,0)

 F APCHSX=1:1:3 Q:$D(APCHSQIT)  I $P($G(^AUPNVLAB(APCHSDFN,13)),U,APCHSX)]"" D

 .X APCHSCKP Q:$D(APCHSQIT)

 .W !,$P(^AUPNVLAB(APCHSDFN,13),U,APCHSX)

 ;W ?78," ",$P($G(^AUPNVLAB(APCHSDFN,11)),U,9)

W !

EKGLAB ;ENTRY POINT - EKG display in most recent lab panel

 Q:'$D(^AUPNVDXP("AC",APCHSPAT))

 K APCHS

 S APCHSERR=$$START1^APCLDF(APCHSPAT_"^LAST DIAGNOSTIC ECG SUMMARY","APCHS(")

 G:APCHSERR EKGLABX

 ; *array APCHS(1)="DATE^RESULT^DIAG PROC^VDIAG PROCEDURE IEN^AUPNVDXP^VISIT IEN"

 K APCHSERR

 S APCHSIVD=$S($D(APCHS(1)):9999999-$P($P(APCHS(1),U,1),".",1),1:"")

 Q:'APCHSIVD!(APCHSIVD>APCHSDLM)

 S (APCHSLTX,APCHSLT)="EKG"

 S APCHSLRT("EKG")=$P(APCHS(1),U,1)_"^"_$P(APCHS(1),U,2)

 D EKGPRT  ;                           computes/prints ekg info

EKGLABX ;

 K APCHSERR,APCHS(1)

EKGPRT ;computers/prints ekg info

 S Y=$P(APCHSLRT(APCHSLT),U,1) X APCHSCVD S APCHSLTD=Y

 S APCHSLR=$P(APCHSLRT(APCHSLT),U,2)

 S APCHSLR=$S(APCHSLR="N":"NORMAL",APCHSLR="A":"ABNORMAL",APCHSLR="B":"BORDERLINE",1:"<none recorded>") ;IHS/CMI/LAB added borderline

 S APCHSLW=$S($G(APCHSLW):APCHSLW,1:28)

 W !,APCHSLTX,?APCHSLW,APCHSLTD,"  ",APCHSLR,!

APCHS3L   ; IHS/TUCSON/LAB - PART 3A OF APCHS -- SUMMARY PRODUCTION COMPONENTS ;

 +1       ;;2.0;IHS PCC SUITE;**2**;MAY 14, 2009

 +2       ;

MRL       ; ******************** MOST RECENT LAB * 9000010.09 *******

 +1        IF '$DATA(^AUPNVLAB("AA",APCHSPAT))

               DO EKGLAB

               GOTO MRLX

 +2        XECUTE APCHSCKP

           IF $DATA(APCHSQIT)

               QUIT

 +3        IF 'APCHSNPG

               XECUTE APCHSBRK

 +4       ; <SETUP>

 +5       ; <PROCESS>

 +6        DO LBLD

           DO LPRT

 +7        DO EKGLAB

 +8       ;now display lab refusals

 +9        SET APCHST="LAB"

           SET APCHSFN=60

           DO DISPREF^APCHS3C

 +10       KILL APCHST,APCHSFN

 +11      ; <CLEANUP>

MRLX       KILL APCHSLT,APCHSLR,APCHSLTX,APCHSLRT,APCHSLL,APCHSLW,APCHSNMX,APCHSDFN,APCHSIVD,APCHSLTD,APCHSN,Y

 +1        KILL ^TMP($JOB,"APCHS"),^TMP($JOB,"APCHS1")

 +2        QUIT

 +3       ; <BUILD>

LBLD       KILL ^TMP($JOB,"APCHS","LAB"),^TMP($JOB,"APCHS1")

 +1        SET APCHSLRT=""

           FOR APCHSQ=0:0

               SET APCHSLRT=$ORDER(^AUPNVLAB("AA",APCHSPAT,APCHSLRT))

               IF APCHSLRT=""

                   QUIT

               DO LDATE

 +2        DO REORDER

 +3        QUIT

REORDER   ;reorder by accession, parent and child

 +1        SET X=0

FOR

               SET X=$ORDER(^TMP($JOB,"APCHS","LAB",X))

               IF X'=+X

                   QUIT

               Begin DoDot:1

 +2                SET Y=$PIECE(^TMP($JOB,"APCHS","LAB",X),U,3)

 +3                SET %=$EXTRACT($PIECE(^AUPNVLAB(Y,0),U,6),1,2)

                   IF %=""

                       SET %="ZZ"

 +4                SET %1=$SELECT($PIECE($GET(^AUPNVLAB(Y,12)),U,8)]"":$PIECE(^AUPNVLAB(Y,12),U,8),1:Y)

 +5                SET %2=$SELECT($PIECE($GET(^AUPNVLAB(Y,12)),U,8)="":0,1:Y)

 +6                SET ^TMP($JOB,"APCHS1",%,%1,%2,X)=^TMP($JOB,"APCHS","LAB",X)

 +7                QUIT

               End DoDot:1

 +8        KILL ^TMP($JOB,"APCHS")

 +9        QUIT

LDATE      SET APCHSIVD=$ORDER(^AUPNVLAB("AA",APCHSPAT,APCHSLRT,0))

 +1        SET APCHSDFN=0

FOR

               SET APCHSDFN=$ORDER(^AUPNVLAB("AA",APCHSPAT,APCHSLRT,APCHSIVD,APCHSDFN))

               IF APCHSDFN'=+APCHSDFN

                   QUIT

               IF APCHSIVD&(APCHSIVD'>APCHSDLM)

                   DO LSET

 +2        QUIT

LSET      ;

 +1        SET APCHSN=^AUPNVLAB(APCHSDFN,0)

           SET APCHSLR=$PIECE(APCHSN,U,4)

 +2       ;do not display tests that are resulted, result is null and flag says don't display

           IF $PIECE($GET(^AUPNVLAB(APCHSDFN,11)),U,9)="R"

               IF APCHSLR=""

                   IF $$VALI^XBDIQ1(60,$PIECE(APCHSN,U),999999901)

                       QUIT

 +3        IF APCHSLR]""

               IF APCHSLR'=" "

                   IF $PIECE(APCHSN,U,5)]""

                       SET APCHSLR=APCHSLR_" ("_$PIECE(APCHSN,U,5)_")"

 +4        IF APCHSLR=""

               IF $PIECE($GET(^TMP($JOB,"APCHS","LAB",APCHSLRT)),U,2)]""

                   QUIT

 +5        SET ^TMP($JOB,"APCHS","LAB",APCHSLRT)=(-APCHSIVD\1+9999999)_U_APCHSLR_U_APCHSDFN

           SET APCHSLTX=$PIECE(^LAB(60,APCHSLRT,0),U,1)

 +6        QUIT

 +7       ; <PRINT>

LPRT      ;

 +1        WRITE ?55,"UNITS",?64,"REF RANGE",!

 +2        SET APCHSACC=""

FOR

               SET APCHSACC=$ORDER(^TMP($JOB,"APCHS1",APCHSACC))

               IF APCHSACC=""!($DATA(APCHSQIT))

                   QUIT

               Begin DoDot:1

 +3                SET APCHSPAR=0

FOR

                       SET APCHSPAR=$ORDER(^TMP($JOB,"APCHS1",APCHSACC,APCHSPAR))

                       IF APCHSPAR'=+APCHSPAR!($DATA(APCHSQIT))

                           QUIT

                       Begin DoDot:2

 +4                        SET APCHCHIL=""

FOR

                               SET APCHCHIL=$ORDER(^TMP($JOB,"APCHS1",APCHSACC,APCHSPAR,APCHCHIL))

                               IF APCHCHIL=""

                                   QUIT

                               Begin DoDot:3

 +5                                SET APCHSLT=$ORDER(^TMP($JOB,"APCHS1",APCHSACC,APCHSPAR,APCHCHIL,0))

 +6                                SET APCHSDFN=$PIECE(^TMP($JOB,"APCHS1",APCHSACC,APCHSPAR,APCHCHIL,APCHSLT),U,3)

 +7                                SET Y=$PIECE(^TMP($JOB,"APCHS1",APCHSACC,APCHSPAR,APCHCHIL,APCHSLT),U,1)

                                   SET APCHSLR=$PIECE(^TMP($JOB,"APCHS1",APCHSACC,APCHSPAR,APCHCHIL,APCHSLT),U,2)

                                   XECUTE APCHSCVD

                                   SET APCHSLTD=Y

 +8                                DO LPRT2

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

 +9        KILL APCHCHIL,APCHSPAR,APCHSACC,APCHSLT

 +10       QUIT

LPRT2     ;

 +1        SET APCHSLTX=$PIECE(^LAB(60,APCHSLT,0),U)

 +2        XECUTE APCHSCKP

           IF $DATA(APCHSQIT)

               QUIT

           IF APCHSNPG

               WRITE ?55,"UNITS",?64,"REF RANGE",!

 +3        IF APCHCHIL

               WRITE "  "

           WRITE APCHSLTX,?35,APCHSLTD,?45,APCHSLR

 +4        WRITE ?55,$PIECE($GET(^AUPNVLAB(APCHSDFN,11)),U)

 +5        IF $PIECE($GET(^AUPNVLAB(APCHSDFN,11)),U,4)]""!($PIECE($GET(^AUPNVLAB(APCHSDFN,11)),U,5)]"")

               WRITE ?64,$PIECE(^AUPNVLAB(APCHSDFN,11),U,4)_"-"_$PIECE(^AUPNVLAB(APCHSDFN,11),U,5)

 +6        IF '$PIECE(^APCHSCTL(APCHSTYP,0),U,7)

               WRITE !

               QUIT

 +7       ;print out comments per Dorothy

 +8        SET APCHSX=0

FOR

               SET APCHSX=$ORDER(^AUPNVLAB(APCHSDFN,21,APCHSX))

               IF APCHSX'=+APCHSX!($DATA(APCHSQIT))

                   QUIT

               Begin DoDot:1

 +9                XECUTE APCHSCKP

                   IF $DATA(APCHSQIT)

                       QUIT

 +10               WRITE !,?1,^AUPNVLAB(APCHSDFN,21,APCHSX,0)

               End DoDot:1

 +11       FOR APCHSX=1:1:3

               IF $DATA(APCHSQIT)

                   QUIT

               IF $PIECE($GET(^AUPNVLAB(APCHSDFN,13)),U,APCHSX)]""

                   Begin DoDot:1

 +12                   XECUTE APCHSCKP

                       IF $DATA(APCHSQIT)

                           QUIT

 +13                   WRITE !,$PIECE(^AUPNVLAB(APCHSDFN,13),U,APCHSX)

                   End DoDot:1

 +14      ;W ?78," ",$P($G(^AUPNVLAB(APCHSDFN,11)),U,9)

 +15       WRITE !

 +16       QUIT

 +17      ;

EKGLAB    ;ENTRY POINT - EKG display in most recent lab panel

 +1        IF '$DATA(^AUPNVDXP("AC",APCHSPAT))

               QUIT

 +2        KILL APCHS

 +3        SET APCHSERR=$$START1^APCLDF(APCHSPAT_"^LAST DIAGNOSTIC ECG SUMMARY","APCHS(")

 +4        IF APCHSERR

               GOTO EKGLABX

 +5       ; *array APCHS(1)="DATE^RESULT^DIAG PROC^VDIAG PROCEDURE IEN^AUPNVDXP^VISIT IEN"

 +6        KILL APCHSERR

 +7        SET APCHSIVD=$SELECT($DATA(APCHS(1)):9999999-$PIECE($PIECE(APCHS(1),U,1),".",1),1:"")

 +8        IF 'APCHSIVD!(APCHSIVD>APCHSDLM)

               QUIT

 +9        SET (APCHSLTX,APCHSLT)="EKG"

 +10       SET APCHSLRT("EKG")=$PIECE(APCHS(1),U,1)_"^"_$PIECE(APCHS(1),U,2)

 +11      ;                           computes/prints ekg info

           DO EKGPRT

EKGLABX   ;

 +1        KILL APCHSERR,APCHS(1)

 +2        QUIT

 +3       ;

EKGPRT    ;computers/prints ekg info

 +1        SET Y=$PIECE(APCHSLRT(APCHSLT),U,1)

           XECUTE APCHSCVD

           SET APCHSLTD=Y

 +2        SET APCHSLR=$PIECE(APCHSLRT(APCHSLT),U,2)

 +3       ;IHS/CMI/LAB added borderline

           SET APCHSLR=$SELECT(APCHSLR="N":"NORMAL",APCHSLR="A":"ABNORMAL",APCHSLR="B":"BORDERLINE",1:"<none recorded>")

 +4        SET APCHSLW=$SELECT($GET(APCHSLW):APCHSLW,1:28)

 +5        WRITE !,APCHSLTX,?APCHSLW,APCHSLTD,"  ",APCHSLR,!

 +6        QUIT

APCHS3L.m