APCHS3 ; IHS/CMI/LAB - PART 3 OF APCHS -- SUMMARY PRODUCTION COMPONENTS ;
;;2.0;IHS PCC SUITE;;MAY 14, 2009
;
LAB ; ******************** LAB DATA * 9000010.09 *******
I '$D(^AUPNVLAB("AE",APCHSPAT)) D EKGLAB^APCHS3A G LABX
X APCHSCKP Q:$D(APCHSQIT)
X:'APCHSNPG APCHSBRK
; <SETUP>
K ^TMP($J,"APCHSLRT"),^("APCHSLDT"),^("APCHSLD2")
; <PROCESS>
D LBLD,LPRT
W ! D EKGLAB^APCHS3A
; <CLEANUP>
LABX K APCHSLT,APCHSLR,APCHSLTX,APCHSDFN,APCHSNDT,APCHSLRT,APCHSLDT,APCHSLD2,APCHSNA,APCHSIVD,APCHSDTL,APCHSI,APCHSJ,APCHSL,APCHSLL,APCHSDSN,APCHSIDN,APCHSNMX,APCHSLW,APCHSMXL,APCHSLTO,APCHSLTN,APCHSELX,Y
K ^TMP($J,"APCHSLRT"),^("APCHSLDT"),^("APCHSLD2")
Q
; <BUILD>
LBLD K APCHSLRT,APCHSLDT,APCHSLD2
S (APCHSNDT,APCHSMXL,APCHSLTN)=0,APCHSELX=$D(^APCHSCTL(APCHSTYP,4,"C"))
S APCHSIVD="" F APCHSQ=0:0 S APCHSIVD=$O(^AUPNVLAB("AE",APCHSPAT,APCHSIVD)) Q:'APCHSIVD!(APCHSIVD>APCHSDLM) D LDATE S:$D(^TMP($J,"APCHSLDT",APCHSIVD)) APCHSNDM=APCHSNDM-1 Q:'APCHSNDM
S APCHSIVD="" F APCHSI=1:1 S APCHSIVD=$O(^TMP($J,"APCHSLDT",APCHSIVD)) Q:APCHSIVD="" S ^TMP($J,"APCHSLD2",APCHSI)=APCHSIVD
Q
LDATE S APCHSLT="" F APCHSQ=0:0 S APCHSLT=$O(^AUPNVLAB("AE",APCHSPAT,APCHSIVD,APCHSLT)) Q:'APCHSLT D
.S APCHSDFN=0 F S APCHSDFN=$O(^AUPNVLAB("AE",APCHSPAT,APCHSIVD,APCHSLT,APCHSDFN)) Q:'APCHSDFN D LSET
Q
LSET ;
I APCHSELX Q:'$D(^APCHSCTL(APCHSTYP,4,"C",APCHSLT))
S APCHSLR=$P(^AUPNVLAB(APCHSDFN,0),U,4) Q:APCHSLR="" Q:APCHSLR=" "
I APCHSELX S APCHSLTO=$O(^APCHSCTL(APCHSTYP,4,"C",APCHSLT,"")),APCHSLTO=+^APCHSCTL(APCHSTYP,4,APCHSLTO,0)
E S (APCHSLTO,APCHSLTN)=APCHSLT
S APCHSLTO=10000+APCHSLTO_"-"_APCHSLT
S Y=$$RDT(APCHSDFN)
S ^TMP($J,"APCHSLRT",APCHSLTO,APCHSIVD)=APCHSLR_$S(Y]"":" (",1:"")_$$RDT(APCHSDFN)_$S(Y]"":")",1:"") S APCHSLTX=$P(^LAB(60,APCHSLT,0),U,1) S:$L(APCHSLTX)>APCHSMXL APCHSMXL=$L(APCHSLTX)
S:'$D(^TMP($J,"APCHSLDT",APCHSIVD)) APCHSNDT=APCHSNDT+1 S ^TMP($J,"APCHSLDT",APCHSIVD)=""
Q
; <PRINT>
LPRT S APCHSLW=APCHSMXL+1,APCHSLL=25,APCHSNMX=(80-1-APCHSLW)\APCHSLL
F APCHSDSN=1:APCHSNMX:APCHSNDT D LPRT2
Q
LPRT2 ;
S APCHSDTL="" F APCHSI=1:1:APCHSNMX S APCHSJ=APCHSDSN+APCHSI-1 Q:APCHSJ>APCHSNDT S Y=-^TMP($J,"APCHSLD2",APCHSJ)\1+9999999 X APCHSCVD S APCHSDTL=APCHSDTL_$J(Y,APCHSLL)
X APCHSCKP Q:$D(APCHSQIT) W ! X APCHSCKP Q:$D(APCHSQIT) W ?APCHSLW,APCHSDTL
X APCHSCKP Q:$D(APCHSQIT) W !
S APCHSLT="" F APCHSQ=0:0 S APCHSLT=$O(^TMP($J,"APCHSLRT",APCHSLT)) Q:APCHSLT="" S APCHSLTX=$P(^LAB(60,$P(APCHSLT,"-",2),0),U,1) D LPRT3 I APCHSNA X APCHSCKP Q:$D(APCHSQIT) W:APCHSNPG ?APCHSLW,APCHSDTL,! W APCHSLTX,?APCHSLW,APCHSL,!
Q
LPRT3 S APCHSNA=0 S APCHSL="" F APCHSIDN=1:1:APCHSNMX S APCHSJ=APCHSDSN+APCHSIDN-1 Q:APCHSJ>APCHSNDT S APCHSIVD=^TMP($J,"APCHSLD2",APCHSJ) D LADD
Q
LADD I $D(^TMP($J,"APCHSLRT",APCHSLT,APCHSIVD)) S APCHSNA=APCHSNA+1 S APCHSL=APCHSL_$J(^TMP($J,"APCHSLRT",APCHSLT,APCHSIVD),APCHSLL)
E S APCHSL=APCHSL_$J(" ",APCHSLL)
Q
RDT(R) ;
I $G(R)="" Q ""
NEW X
S X=$P($G(^AUPNVLAB(R,12)),U,12)
I X="" Q ""
Q $$DATE^APCHSMU($P(X,"."))_"@"_$P($P($$FMTE^XLFDT(X),"@",2),":",1,2)
APCHS3 ; IHS/CMI/LAB - PART 3 OF APCHS -- SUMMARY PRODUCTION COMPONENTS ;
+1 ;;2.0;IHS PCC SUITE;;MAY 14, 2009
+2 ;
LAB ; ******************** LAB DATA * 9000010.09 *******
+1 IF '$DATA(^AUPNVLAB("AE",APCHSPAT))
DO EKGLAB^APCHS3A
GOTO LABX
+2 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+3 IF 'APCHSNPG
XECUTE APCHSBRK
+4 ; <SETUP>
+5 KILL ^TMP($JOB,"APCHSLRT"),^("APCHSLDT"),^("APCHSLD2")
+6 ; <PROCESS>
+7 DO LBLD
DO LPRT
+8 WRITE !
DO EKGLAB^APCHS3A
+9 ; <CLEANUP>
LABX KILL APCHSLT,APCHSLR,APCHSLTX,APCHSDFN,APCHSNDT,APCHSLRT,APCHSLDT,APCHSLD2,APCHSNA,APCHSIVD,APCHSDTL,APCHSI,APCHSJ,APCHSL,APCHSLL,APCHSDSN,APCHSIDN,APCHSNMX,APCHSLW,APCHSMXL,APCHSLTO,APCHSLTN,APCHSELX,Y
+1 KILL ^TMP($JOB,"APCHSLRT"),^("APCHSLDT"),^("APCHSLD2")
+2 QUIT
+3 ; <BUILD>
LBLD KILL APCHSLRT,APCHSLDT,APCHSLD2
+1 SET (APCHSNDT,APCHSMXL,APCHSLTN)=0
SET APCHSELX=$DATA(^APCHSCTL(APCHSTYP,4,"C"))
+2 SET APCHSIVD=""
FOR APCHSQ=0:0
SET APCHSIVD=$ORDER(^AUPNVLAB("AE",APCHSPAT,APCHSIVD))
IF 'APCHSIVD!(APCHSIVD>APCHSDLM)
QUIT
DO LDATE
IF $DATA(^TMP($JOB,"APCHSLDT",APCHSIVD))
SET APCHSNDM=APCHSNDM-1
IF 'APCHSNDM
QUIT
+3 SET APCHSIVD=""
FOR APCHSI=1:1
SET APCHSIVD=$ORDER(^TMP($JOB,"APCHSLDT",APCHSIVD))
IF APCHSIVD=""
QUIT
SET ^TMP($JOB,"APCHSLD2",APCHSI)=APCHSIVD
+4 QUIT
LDATE SET APCHSLT=""
FOR APCHSQ=0:0
SET APCHSLT=$ORDER(^AUPNVLAB("AE",APCHSPAT,APCHSIVD,APCHSLT))
IF 'APCHSLT
QUIT
Begin DoDot:1
+1 SET APCHSDFN=0
FOR
SET APCHSDFN=$ORDER(^AUPNVLAB("AE",APCHSPAT,APCHSIVD,APCHSLT,APCHSDFN))
IF 'APCHSDFN
QUIT
DO LSET
End DoDot:1
+2 QUIT
LSET ;
+1 IF APCHSELX
IF '$DATA(^APCHSCTL(APCHSTYP,4,"C",APCHSLT))
QUIT
+2 SET APCHSLR=$PIECE(^AUPNVLAB(APCHSDFN,0),U,4)
IF APCHSLR=""
QUIT
IF APCHSLR=" "
QUIT
+3 IF APCHSELX
SET APCHSLTO=$ORDER(^APCHSCTL(APCHSTYP,4,"C",APCHSLT,""))
SET APCHSLTO=+^APCHSCTL(APCHSTYP,4,APCHSLTO,0)
+4 IF '$TEST
SET (APCHSLTO,APCHSLTN)=APCHSLT
+5 SET APCHSLTO=10000+APCHSLTO_"-"_APCHSLT
+6 SET Y=$$RDT(APCHSDFN)
+7 SET ^TMP($JOB,"APCHSLRT",APCHSLTO,APCHSIVD)=APCHSLR_$SELECT(Y]"":" (",1:"")_$$RDT(APCHSDFN)_$SELECT(Y]"":")",1:"")
SET APCHSLTX=$PIECE(^LAB(60,APCHSLT,0),U,1)
IF $LENGTH(APCHSLTX)>APCHSMXL
SET APCHSMXL=$LENGTH(APCHSLTX)
+8 IF '$DATA(^TMP($JOB,"APCHSLDT",APCHSIVD))
SET APCHSNDT=APCHSNDT+1
SET ^TMP($JOB,"APCHSLDT",APCHSIVD)=""
+9 QUIT
+10 ; <PRINT>
LPRT SET APCHSLW=APCHSMXL+1
SET APCHSLL=25
SET APCHSNMX=(80-1-APCHSLW)\APCHSLL
+1 FOR APCHSDSN=1:APCHSNMX:APCHSNDT
DO LPRT2
+2 QUIT
LPRT2 ;
+1 SET APCHSDTL=""
FOR APCHSI=1:1:APCHSNMX
SET APCHSJ=APCHSDSN+APCHSI-1
IF APCHSJ>APCHSNDT
QUIT
SET Y=-^TMP($JOB,"APCHSLD2",APCHSJ)\1+9999999
XECUTE APCHSCVD
SET APCHSDTL=APCHSDTL_$JUSTIFY(Y,APCHSLL)
+2 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
WRITE !
XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
WRITE ?APCHSLW,APCHSDTL
+3 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
WRITE !
+4 SET APCHSLT=""
FOR APCHSQ=0:0
SET APCHSLT=$ORDER(^TMP($JOB,"APCHSLRT",APCHSLT))
IF APCHSLT=""
QUIT
SET APCHSLTX=$PIECE(^LAB(60,$PIECE(APCHSLT,"-",2),0),U,1)
DO LPRT3
IF APCHSNA
XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
IF APCHSNPG
WRITE ?APCHSLW,APCHSDTL,!
WRITE APCHSLTX,?APCHSLW,APCHSL,!
+5 QUIT
LPRT3 SET APCHSNA=0
SET APCHSL=""
FOR APCHSIDN=1:1:APCHSNMX
SET APCHSJ=APCHSDSN+APCHSIDN-1
IF APCHSJ>APCHSNDT
QUIT
SET APCHSIVD=^TMP($JOB,"APCHSLD2",APCHSJ)
DO LADD
+1 QUIT
LADD IF $DATA(^TMP($JOB,"APCHSLRT",APCHSLT,APCHSIVD))
SET APCHSNA=APCHSNA+1
SET APCHSL=APCHSL_$JUSTIFY(^TMP($JOB,"APCHSLRT",APCHSLT,APCHSIVD),APCHSLL)
+1 IF '$TEST
SET APCHSL=APCHSL_$JUSTIFY(" ",APCHSLL)
+2 QUIT
RDT(R) ;
+1 IF $GET(R)=""
QUIT ""
+2 NEW X
+3 SET X=$PIECE($GET(^AUPNVLAB(R,12)),U,12)
+4 IF X=""
QUIT ""
+5 QUIT $$DATE^APCHSMU($PIECE(X,"."))_"@"_$PIECE($PIECE($$FMTE^XLFDT(X),"@",2),":",1,2)
