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")
Q
; <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
Q
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")
Q
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
Q
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)
Q
; <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
Q
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 !
Q
;
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)
Q
;
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,!
Q
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
