- 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)
