APCHS3B ; IHS/CMI/LAB - PART 3A OF APCHS -- SUMMARY PRODUCTION COMPONENTS ;
;;2.0;IHS PCC SUITE;;MAY 14, 2009
;PATCH 2 commented out writing of date
;
;
;CHANGED TO REVERSE CHRONOLOGICAL ORDER
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,LPRT1
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")
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 D=(9999999-$P(^TMP($J,"APCHS","LAB",X),U,1))
.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",D,%,%1,%2,X)=^TMP($J,"APCHS","LAB",X)
.Q
K ^TMP($J,"APCHS")
Q
;OLD STUFF
;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,1)
;.S ^TMP($J,"APCHS1",9999999-Y,X)=^TMP($J,"APCHS","LAB",X)
;.Q
;K ^TMP($J,"APCHS")
;Q
LDATE S APCHSIVD=0 S APCHSIVD=$O(^AUPNVLAB("AA",APCHSPAT,APCHSLRT,APCHSIVD)) D
.S APCHSDFN=0 F S APCHSDFN=$O(^AUPNVLAB("AA",APCHSPAT,APCHSLRT,APCHSIVD,APCHSDFN)) Q:APCHSDFN="" D:APCHSIVD&(APCHSIVD'>APCHSDLM) LSET
Q
LSET ;
Q:'$D(^AUPNVLAB(APCHSDFN,0))
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
;Q:$D(^TMP($J,"APCHS","LAB",APCHSLRT))
S ^TMP($J,"APCHS","LAB",APCHSLRT)=(-APCHSIVD\1+9999999)_U_APCHSLR_U_APCHSDFN S APCHSLTX=$P(^LAB(60,APCHSLRT,0),U,1)
Q
; <PRINT>
LPRT1 ;ALTERNATE ROUTE IHS/OKCAO/POC 1/20/00
;W ?55,"UNITS",?64,"REF RANGE",!
W ?2,"TEST",?23,"RESULT DT/TIME",?39,"VISIT",?47,"RESULT",?60,"UNITS",?70,"REF RANGE",!
S APCHDATE="" F S APCHDATE=$O(^TMP($J,"APCHS1",APCHDATE)) Q:APCHDATE=""!($D(APCHSQIT)) D LPRT11
Q
;.S APCHSLT="" F S APCHSLT=$O(^TMP($J,"APCHS1",APCHDATE,APCHSLT)) Q:APCHSLT=""!($D(APCHSQIT)) D
;..S APCHNODE=^TMP($J,"APCHS1",APCHDATE,APCHSLT)
;..S APCHSDFN=$P(APCHNODE,U,3)
;..S Y=$P(APCHNODE,U,1)
;..S APCHSLR=$P(APCHNODE,U,2)
;..S APCHCHIL=$S($P($G(^AUPNVLAB(APCHSDFN,12)),U,8)="":0,1:Y)
;..X APCHSCVD S APCHSLTD=Y
;..D LPRT2
;K APCHSLT,APCHNODE,APCHSDFN,APCHSLR,APCHCHIL,APCHDATE
;Q
LPRT11 ;
S APCHSACC="" F S APCHSACC=$O(^TMP($J,"APCHS1",APCHDATE,APCHSACC)) Q:APCHSACC=""!($D(APCHSQIT)) D
.S APCHSPAR=0 F S APCHSPAR=$O(^TMP($J,"APCHS1",APCHDATE,APCHSACC,APCHSPAR)) Q:APCHSPAR'=+APCHSPAR!($D(APCHSQIT)) D
..S APCHCHIL="" F S APCHCHIL=$O(^TMP($J,"APCHS1",APCHDATE,APCHSACC,APCHSPAR,APCHCHIL)) Q:APCHCHIL="" D
...S APCHSLT=$O(^TMP($J,"APCHS1",APCHDATE,APCHSACC,APCHSPAR,APCHCHIL,0))
...S APCHSDFN=$P(^TMP($J,"APCHS1",APCHDATE,APCHSACC,APCHSPAR,APCHCHIL,APCHSLT),U,3)
...S Y=$P(^TMP($J,"APCHS1",APCHDATE,APCHSACC,APCHSPAR,APCHCHIL,APCHSLT),U,1),APCHSLR=$P(^TMP($J,"APCHS1",APCHDATE,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)
S APCHSRDT=$P($G(^AUPNVLAB(APCHSDFN,12)),U,12) I APCHSRDT]"" S APCHSRDT=$$DATE^APCHSMU($P(APCHSRDT,"."))_"@"_$P($P($$FMTE^XLFDT(APCHSRDT),"@",2),":",1,2)
X APCHSCKP Q:$D(APCHSQIT) I APCHSNPG W ?2,"TEST",?23,"RESULT DT/TIME",?39,"VISIT",?47,"RESULT",?60,"UNITS",?70,"REF RANGE",!
W:APCHCHIL " " W $E(APCHSLTX,1,20),?23,APCHSRDT,?38,APCHSLTD,?47,APCHSLR
W ?60,$P($G(^AUPNVLAB(APCHSDFN,11)),U)
I $P($G(^AUPNVLAB(APCHSDFN,11)),U,4)]""!($P($G(^AUPNVLAB(APCHSDFN,11)),U,5)]"") W ?70,$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
;
APCHS3B ; IHS/CMI/LAB - PART 3A OF APCHS -- SUMMARY PRODUCTION COMPONENTS ;
+1 ;;2.0;IHS PCC SUITE;;MAY 14, 2009
+2 ;PATCH 2 commented out writing of date
+3 ;
+4 ;
+5 ;CHANGED TO REVERSE CHRONOLOGICAL ORDER
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 LPRT1
+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")
+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 D=(9999999-$PIECE(^TMP($JOB,"APCHS","LAB",X),U,1))
+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,"APCHS1",D,%,%1,%2,X)=^TMP($JOB,"APCHS","LAB",X)
+8 QUIT
End DoDot:1
+9 KILL ^TMP($JOB,"APCHS")
+10 QUIT
+11 ;OLD STUFF
+12 ;S X=0 F S X=$O(^TMP($J,"APCHS","LAB",X)) Q:X'=+X D
+13 ;.S Y=$P(^TMP($J,"APCHS","LAB",X),U,1)
+14 ;.S ^TMP($J,"APCHS1",9999999-Y,X)=^TMP($J,"APCHS","LAB",X)
+15 ;.Q
+16 ;K ^TMP($J,"APCHS")
+17 ;Q
LDATE SET APCHSIVD=0
SET APCHSIVD=$ORDER(^AUPNVLAB("AA",APCHSPAT,APCHSLRT,APCHSIVD))
Begin DoDot:1
+1 SET APCHSDFN=0
FOR
SET APCHSDFN=$ORDER(^AUPNVLAB("AA",APCHSPAT,APCHSLRT,APCHSIVD,APCHSDFN))
IF APCHSDFN=""
QUIT
IF APCHSIVD&(APCHSIVD'>APCHSDLM)
DO LSET
End DoDot:1
+2 QUIT
LSET ;
+1 IF '$DATA(^AUPNVLAB(APCHSDFN,0))
QUIT
+2 SET APCHSN=^AUPNVLAB(APCHSDFN,0)
SET APCHSLR=$PIECE(APCHSN,U,4)
+3 ;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
+4 IF APCHSLR]""
IF APCHSLR'=" "
IF $PIECE(APCHSN,U,5)]""
SET APCHSLR=APCHSLR_" ("_$PIECE(APCHSN,U,5)_")"
+5 IF APCHSLR=""
IF $PIECE($GET(^TMP($JOB,"APCHS","LAB",APCHSLRT)),U,2)]""
QUIT
+6 ;Q:$D(^TMP($J,"APCHS","LAB",APCHSLRT))
+7 SET ^TMP($JOB,"APCHS","LAB",APCHSLRT)=(-APCHSIVD\1+9999999)_U_APCHSLR_U_APCHSDFN
SET APCHSLTX=$PIECE(^LAB(60,APCHSLRT,0),U,1)
+8 QUIT
+9 ; <PRINT>
LPRT1 ;ALTERNATE ROUTE IHS/OKCAO/POC 1/20/00
+1 ;W ?55,"UNITS",?64,"REF RANGE",!
+2 WRITE ?2,"TEST",?23,"RESULT DT/TIME",?39,"VISIT",?47,"RESULT",?60,"UNITS",?70,"REF RANGE",!
+3 SET APCHDATE=""
FOR
SET APCHDATE=$ORDER(^TMP($JOB,"APCHS1",APCHDATE))
IF APCHDATE=""!($DATA(APCHSQIT))
QUIT
DO LPRT11
+4 QUIT
+5 ;.S APCHSLT="" F S APCHSLT=$O(^TMP($J,"APCHS1",APCHDATE,APCHSLT)) Q:APCHSLT=""!($D(APCHSQIT)) D
+6 ;..S APCHNODE=^TMP($J,"APCHS1",APCHDATE,APCHSLT)
+7 ;..S APCHSDFN=$P(APCHNODE,U,3)
+8 ;..S Y=$P(APCHNODE,U,1)
+9 ;..S APCHSLR=$P(APCHNODE,U,2)
+10 ;..S APCHCHIL=$S($P($G(^AUPNVLAB(APCHSDFN,12)),U,8)="":0,1:Y)
+11 ;..X APCHSCVD S APCHSLTD=Y
+12 ;..D LPRT2
+13 ;K APCHSLT,APCHNODE,APCHSDFN,APCHSLR,APCHCHIL,APCHDATE
+14 ;Q
LPRT11 ;
+1 SET APCHSACC=""
FOR
SET APCHSACC=$ORDER(^TMP($JOB,"APCHS1",APCHDATE,APCHSACC))
IF APCHSACC=""!($DATA(APCHSQIT))
QUIT
Begin DoDot:1
+2 SET APCHSPAR=0
FOR
SET APCHSPAR=$ORDER(^TMP($JOB,"APCHS1",APCHDATE,APCHSACC,APCHSPAR))
IF APCHSPAR'=+APCHSPAR!($DATA(APCHSQIT))
QUIT
Begin DoDot:2
+3 SET APCHCHIL=""
FOR
SET APCHCHIL=$ORDER(^TMP($JOB,"APCHS1",APCHDATE,APCHSACC,APCHSPAR,APCHCHIL))
IF APCHCHIL=""
QUIT
Begin DoDot:3
+4 SET APCHSLT=$ORDER(^TMP($JOB,"APCHS1",APCHDATE,APCHSACC,APCHSPAR,APCHCHIL,0))
+5 SET APCHSDFN=$PIECE(^TMP($JOB,"APCHS1",APCHDATE,APCHSACC,APCHSPAR,APCHCHIL,APCHSLT),U,3)
+6 SET Y=$PIECE(^TMP($JOB,"APCHS1",APCHDATE,APCHSACC,APCHSPAR,APCHCHIL,APCHSLT),U,1)
SET APCHSLR=$PIECE(^TMP($JOB,"APCHS1",APCHDATE,APCHSACC,APCHSPAR,APCHCHIL,APCHSLT),U,2)
XECUTE APCHSCVD
SET APCHSLTD=Y
+7 DO LPRT2
End DoDot:3
End DoDot:2
End DoDot:1
+8 KILL APCHCHIL,APCHSPAR,APCHSACC,APCHSLT
+9 QUIT
LPRT2 ;
+1 SET APCHSLTX=$PIECE(^LAB(60,APCHSLT,0),U)
+2 SET APCHSRDT=$PIECE($GET(^AUPNVLAB(APCHSDFN,12)),U,12)
IF APCHSRDT]""
SET APCHSRDT=$$DATE^APCHSMU($PIECE(APCHSRDT,"."))_"@"_$PIECE($PIECE($$FMTE^XLFDT(APCHSRDT),"@",2),":",1,2)
+3 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
IF APCHSNPG
WRITE ?2,"TEST",?23,"RESULT DT/TIME",?39,"VISIT",?47,"RESULT",?60,"UNITS",?70,"REF RANGE",!
+4 IF APCHCHIL
WRITE " "
WRITE $EXTRACT(APCHSLTX,1,20),?23,APCHSRDT,?38,APCHSLTD,?47,APCHSLR
+5 WRITE ?60,$PIECE($GET(^AUPNVLAB(APCHSDFN,11)),U)
+6 IF $PIECE($GET(^AUPNVLAB(APCHSDFN,11)),U,4)]""!($PIECE($GET(^AUPNVLAB(APCHSDFN,11)),U,5)]"")
WRITE ?70,$PIECE(^AUPNVLAB(APCHSDFN,11),U,4)_"-"_$PIECE(^AUPNVLAB(APCHSDFN,11),U,5)
+7 IF '$PIECE(^APCHSCTL(APCHSTYP,0),U,7)
WRITE !
QUIT
+8 ;print out comments per Dorothy
+9 SET APCHSX=0
FOR
SET APCHSX=$ORDER(^AUPNVLAB(APCHSDFN,21,APCHSX))
IF APCHSX'=+APCHSX!($DATA(APCHSQIT))
QUIT
Begin DoDot:1
+10 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+11 WRITE !,?1,^AUPNVLAB(APCHSDFN,21,APCHSX,0)
End DoDot:1
+12 FOR APCHSX=1:1:3
IF $DATA(APCHSQIT)
QUIT
IF $PIECE($GET(^AUPNVLAB(APCHSDFN,13)),U,APCHSX)]""
Begin DoDot:1
+13 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+14 WRITE !,$PIECE(^AUPNVLAB(APCHSDFN,13),U,APCHSX)
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",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
+7 ;
