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