BHSLAB ;IHS/CIA/MGH - Health Summary for V lab file ;14-Aug-2009 12:55;MGH
;;1.0;HEALTH SUMMARY COMPONENTS;**2,3**;March 17, 2006
;===================================================================
;VA Health Summary for IHS V lab file
;Take from APCHS3
; IHS/TUCSON/LAB - PART 3 OF APCHS -- SUMMARY PRODUCTION COMPONENTS
;;2.0;IHS RPMS/PCC Health Summary;;JUN 24, 1997
;Patch 3 added result date
LAB ; ******************** LAB DATA * 9000010.09 *******
N BHSPAT,BHSQ,X
S BHSPAT=DFN,BHSELX=""
I '$D(^AUPNVLAB("AE",BHSPAT)) D EKGLAB^BHSLAB1 S BHST="LAB",BHSFN=60 D DISPREF^BHSRAD G LABX
D CKP^GMTSUP Q:$D(GMTSQIT)
; <SETUP>
K ^TMP($J,"BHSLRT"),^("BHSLDT"),^("BHSLD2")
; <PROCESS>
D LBLD,LPRT
W ! D EKGLAB^BHSLAB1
; <CLEANUP>
;Patch 2, lab refusals
S BHST="LAB",BHSFN=60 D DISPREF^BHSRAD
LABX K BHSLT,BHSLR,BHSLTX,BHSDFN,BHSNDT,BHSLRT,BHSLDT,BHST,BHSFN,BHSLD2,BHSNA,BHSIVD,BHSDTL,BHSI,BHSJ,BHSL,BHSLL,BHSDSN,BHSIDN,BHSNMX,BHSLW,BHSMXL,BHSLTO,BHSLTN,BHSELX,Y
K ^TMP($J,"BHSLRT"),^("BHSLDT"),^("BHSLD2")
Q
; <BUILD>
LBLD K BHSLRT,BHSLDT,BHSLD2
S (BHSNDT,BHSMXL,BHSLTN)=0
S BHSIVD="" F BHSQ=0:0 S BHSIVD=$O(^AUPNVLAB("AE",BHSPAT,BHSIVD)) Q:'BHSIVD!(BHSIVD>GMTSDLM) D
.D LDATE S:$D(^TMP($J,"BHSLDT",BHSIVD)) GMTSSNDM=GMTSNDM-1 Q:'GMTSNDM
S BHSIVD="" F BHSI=1:1 S BHSIVD=$O(^TMP($J,"BHSLDT",BHSIVD)) Q:BHSIVD="" D
.S ^TMP($J,"BHSLD2",BHSI)=BHSIVD
Q
LDATE S BHSLT="" F BHSQ=0:0 S BHSLT=$O(^AUPNVLAB("AE",BHSPAT,BHSIVD,BHSLT)) Q:'BHSLT D
.S BHSDFN=$O(^AUPNVLAB("AE",BHSPAT,BHSIVD,BHSLT,""))
.D LSET
Q
LSET ;
S BHSLR=$P(^AUPNVLAB(BHSDFN,0),U,4) Q:BHSLR=""
S (BHSLTO,BHSLTN)=BHSLT
S BHSLTO=10000+BHSLTO_"-"_BHSLT
S Y=$$RDT(BHSDFN)
S ^TMP($J,"BHSLRT",BHSLTO,BHSIVD)=BHSLR_$S(Y]"":" (",1:"")_$$RDT(BHSDFN)_$S(Y]"":")",1:"") S BHSLTX=$P(^LAB(60,BHSLT,0),U,1) S:$L(BHSLTX)>BHSMXL BHSMXL=$L(BHSLTX)
S:'$D(^TMP($J,"BHSLDT",BHSIVD)) BHSNDT=BHSNDT+1
S ^TMP($J,"BHSLDT",BHSIVD)=""
Q
; <PRINT>
LPRT S BHSLW=BHSMXL+1,BHSLL=25,BHSNMX=(80-1-BHSLW)\BHSLL
F BHSDSN=1:BHSNMX:BHSNDT D LPRT2
Q
LPRT2 ;
S BHSDTL="" F BHSI=1:1:BHSNMX S BHSJ=BHSDSN+BHSI-1 Q:BHSJ>BHSNDT D
.S X=-^TMP($J,"BHSLD2",BHSJ)\1+9999999 D REGDT4^GMTSU S BHSDTL=BHSDTL_$J(X,BHSLL)
D CKP^GMTSUP Q:$D(GMTSQIT) W ! D CKP^GMTSUP Q:$D(GMTSQIT) W ?BHSLW,BHSDTL
D CKP^GMTSUP Q:$D(GMTSQIT) W !
S BHSLT="" F BHSQ=0:0 S BHSLT=$O(^TMP($J,"BHSLRT",BHSLT)) Q:BHSLT="" D
.S BHSLTX=$P(^LAB(60,$P(BHSLT,"-",2),0),U,1) D LPRT3 I BHSNA D CKP^GMTSUP Q:$D(GMTSQIT) W:GMTSNPG ?BHSLW,BHSDTL,! W BHSLTX,?BHSLW,BHSL,!
Q
LPRT3 S BHSNA=0 S BHSL="" F BHSIDN=1:1:BHSNMX S BHSJ=BHSDSN+BHSIDN-1 Q:BHSJ>BHSNDT D
.S BHSIVD=^TMP($J,"BHSLD2",BHSJ) D LADD
Q
LADD I $D(^TMP($J,"BHSLRT",BHSLT,BHSIVD)) S BHSNA=BHSNA+1 S BHSL=BHSL_$J(^TMP($J,"BHSLRT",BHSLT,BHSIVD),BHSLL)
E S BHSL=BHSL_$J(" ",BHSLL)
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)
BHSLAB ;IHS/CIA/MGH - Health Summary for V lab file ;14-Aug-2009 12:55;MGH
+1 ;;1.0;HEALTH SUMMARY COMPONENTS;**2,3**;March 17, 2006
+2 ;===================================================================
+3 ;VA Health Summary for IHS V lab file
+4 ;Take from APCHS3
+5 ; IHS/TUCSON/LAB - PART 3 OF APCHS -- SUMMARY PRODUCTION COMPONENTS
+6 ;;2.0;IHS RPMS/PCC Health Summary;;JUN 24, 1997
+7 ;Patch 3 added result date
LAB ; ******************** LAB DATA * 9000010.09 *******
+1 NEW BHSPAT,BHSQ,X
+2 SET BHSPAT=DFN
SET BHSELX=""
+3 IF '$DATA(^AUPNVLAB("AE",BHSPAT))
DO EKGLAB^BHSLAB1
SET BHST="LAB"
SET BHSFN=60
DO DISPREF^BHSRAD
GOTO LABX
+4 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+5 ; <SETUP>
+6 KILL ^TMP($JOB,"BHSLRT"),^("BHSLDT"),^("BHSLD2")
+7 ; <PROCESS>
+8 DO LBLD
DO LPRT
+9 WRITE !
DO EKGLAB^BHSLAB1
+10 ; <CLEANUP>
+11 ;Patch 2, lab refusals
+12 SET BHST="LAB"
SET BHSFN=60
DO DISPREF^BHSRAD
LABX KILL BHSLT,BHSLR,BHSLTX,BHSDFN,BHSNDT,BHSLRT,BHSLDT,BHST,BHSFN,BHSLD2,BHSNA,BHSIVD,BHSDTL,BHSI,BHSJ,BHSL,BHSLL,BHSDSN,BHSIDN,BHSNMX,BHSLW,BHSMXL,BHSLTO,BHSLTN,BHSELX,Y
+1 KILL ^TMP($JOB,"BHSLRT"),^("BHSLDT"),^("BHSLD2")
+2 QUIT
+3 ; <BUILD>
LBLD KILL BHSLRT,BHSLDT,BHSLD2
+1 SET (BHSNDT,BHSMXL,BHSLTN)=0
+2 SET BHSIVD=""
FOR BHSQ=0:0
SET BHSIVD=$ORDER(^AUPNVLAB("AE",BHSPAT,BHSIVD))
IF 'BHSIVD!(BHSIVD>GMTSDLM)
QUIT
Begin DoDot:1
+3 DO LDATE
IF $DATA(^TMP($JOB,"BHSLDT",BHSIVD))
SET GMTSSNDM=GMTSNDM-1
IF 'GMTSNDM
QUIT
End DoDot:1
+4 SET BHSIVD=""
FOR BHSI=1:1
SET BHSIVD=$ORDER(^TMP($JOB,"BHSLDT",BHSIVD))
IF BHSIVD=""
QUIT
Begin DoDot:1
+5 SET ^TMP($JOB,"BHSLD2",BHSI)=BHSIVD
End DoDot:1
+6 QUIT
LDATE SET BHSLT=""
FOR BHSQ=0:0
SET BHSLT=$ORDER(^AUPNVLAB("AE",BHSPAT,BHSIVD,BHSLT))
IF 'BHSLT
QUIT
Begin DoDot:1
+1 SET BHSDFN=$ORDER(^AUPNVLAB("AE",BHSPAT,BHSIVD,BHSLT,""))
+2 DO LSET
End DoDot:1
+3 QUIT
LSET ;
+1 SET BHSLR=$PIECE(^AUPNVLAB(BHSDFN,0),U,4)
IF BHSLR=""
QUIT
+2 SET (BHSLTO,BHSLTN)=BHSLT
+3 SET BHSLTO=10000+BHSLTO_"-"_BHSLT
+4 SET Y=$$RDT(BHSDFN)
+5 SET ^TMP($JOB,"BHSLRT",BHSLTO,BHSIVD)=BHSLR_$SELECT(Y]"":" (",1:"")_$$RDT(BHSDFN)_$SELECT(Y]"":")",1:"")
SET BHSLTX=$PIECE(^LAB(60,BHSLT,0),U,1)
IF $LENGTH(BHSLTX)>BHSMXL
SET BHSMXL=$LENGTH(BHSLTX)
+6 IF '$DATA(^TMP($JOB,"BHSLDT",BHSIVD))
SET BHSNDT=BHSNDT+1
+7 SET ^TMP($JOB,"BHSLDT",BHSIVD)=""
+8 QUIT
+9 ; <PRINT>
LPRT SET BHSLW=BHSMXL+1
SET BHSLL=25
SET BHSNMX=(80-1-BHSLW)\BHSLL
+1 FOR BHSDSN=1:BHSNMX:BHSNDT
DO LPRT2
+2 QUIT
LPRT2 ;
+1 SET BHSDTL=""
FOR BHSI=1:1:BHSNMX
SET BHSJ=BHSDSN+BHSI-1
IF BHSJ>BHSNDT
QUIT
Begin DoDot:1
+2 SET X=-^TMP($JOB,"BHSLD2",BHSJ)\1+9999999
DO REGDT4^GMTSU
SET BHSDTL=BHSDTL_$JUSTIFY(X,BHSLL)
End DoDot:1
+3 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
WRITE !
DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
WRITE ?BHSLW,BHSDTL
+4 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
WRITE !
+5 SET BHSLT=""
FOR BHSQ=0:0
SET BHSLT=$ORDER(^TMP($JOB,"BHSLRT",BHSLT))
IF BHSLT=""
QUIT
Begin DoDot:1
+6 SET BHSLTX=$PIECE(^LAB(60,$PIECE(BHSLT,"-",2),0),U,1)
DO LPRT3
IF BHSNA
DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
IF GMTSNPG
WRITE ?BHSLW,BHSDTL,!
WRITE BHSLTX,?BHSLW,BHSL,!
End DoDot:1
+7 QUIT
LPRT3 SET BHSNA=0
SET BHSL=""
FOR BHSIDN=1:1:BHSNMX
SET BHSJ=BHSDSN+BHSIDN-1
IF BHSJ>BHSNDT
QUIT
Begin DoDot:1
+1 SET BHSIVD=^TMP($JOB,"BHSLD2",BHSJ)
DO LADD
End DoDot:1
+2 QUIT
LADD IF $DATA(^TMP($JOB,"BHSLRT",BHSLT,BHSIVD))
SET BHSNA=BHSNA+1
SET BHSL=BHSL_$JUSTIFY(^TMP($JOB,"BHSLRT",BHSLT,BHSIVD),BHSLL)
+1 IF '$TEST
SET BHSL=BHSL_$JUSTIFY(" ",BHSLL)
+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)
