- BHSRAD ;IHS/CIA/MGH - Health Summary for V RAD file ;02-Aug-2013 16:17;DU
- ;;1.0;HEALTH SUMMARY COMPONENTS;**1,2,4,8**;March 17, 2006;Build 22
- ;===================================================================
- ;Taken from BHS3C
- ; IHS/TUCSON/LAB - PART 3C OF APCHS -- SUMMARY PRODUCTION COMPONENTS ; [ 01/20/04 8:04 PM ]
- ;;2.0;IHS RPMS/PCC Health Summary;**11,12**;JUN 24, 1997
- ;IHS/CMI/LAB - patch 12 added new rad component
- ;IHS/MSC/MGH Updated to IHS patch 15
- ;IHS/MSC/MGH Patch 2 update to patch 16
- ;IHS/MSC/MGH Patch 4 moved exams to its own routine
- ;IHS/MSC/MGH patch 8 Updated refusals for SNOMED
- MRR ; ******************** MOST RECENT RADIOLOGY * 9000010.22 *******
- N BHSPAT,BHSICD,BHSICL,BHSQ,X
- S BHSPAT=DFN
- I '$D(^AUPNVRAD("AA",BHSPAT)) S BHST="RADIOLOGY EXAM",BHSFN=71 D DISPREF^BHSRAD Q
- D CKP^GMTSUP Q:$D(GMTSQIT)
- ; <SETUP>
- ; <PROCESS>
- D RBLD,RPRT
- ; <CLEANUP>
- ;now display RAD refusals (patch 2)
- S BHST="RADIOLOGY EXAM",BHSFN=71 D DISPREF^BHSRAD
- K BHST,BHSFN
- MRRX K BHSRT,BHSRR,BHSRTX,BHSRRT,BHSMXL,BHSRL,BHSRW,BHSNMX,BHSDFN,BHSIVD,BHSRTD,BHSN,BHSDCD,BHSEDT,Y
- Q
- ; <BUILD>
- RBLD K BHSRRT S BHSMXL=0
- S BHSRRT="" F BHSQ=0:0 S BHSRRT=$O(^AUPNVRAD("AA",BHSPAT,BHSRRT)) Q:BHSRRT="" D RDATE
- Q
- RDATE S BHSIVD=$O(^AUPNVRAD("AA",BHSPAT,BHSRRT,0)) S BHSDFN=$O(^(BHSIVD,0)) D:BHSIVD&(BHSIVD'>GMTSDLM) RSET
- Q
- RSET S BHSN=^AUPNVRAD(BHSDFN,0),BHSRR=$G(^AUPNVRAD(BHSDFN,11))
- S BHSEDT=$P($G(^AUPNVRAD(BHSDFN,12)),U) ;NEW LINE!
- S X=$P(BHSN,U,5),X=$$EXTSET^XBFUNC(9000010.22,.05,X) S BHSDCD=X
- ;S BHSRRT(BHSRRT)=(-BHSIVD\1+9999999)_U_BHSRR S BHSRTX=$P(^RAMIS(71,BHSRRT,0),U,1) S:$L(BHSRTX)>BHSMXL BHSMXL=$L(BHSRTX) ;ORIG LINE
- S BHSRRT(BHSRRT)=(-BHSIVD\1+9999999)_U_BHSRR_U_BHSEDT_U_BHSDCD_U_$$VAL^XBDIQ1(9000010.22,BHSDFN,.06)
- S BHSRTX=$P(^RAMIS(71,BHSRRT,0),U,1) S:$L(BHSRTX)>BHSMXL BHSMXL=$L(BHSRTX)
- Q
- ; <PRINT>
- RPRT S BHSRW=BHSMXL+1,BHSRL=10,BHSNMX=(IOM-1-BHSRW)\BHSRL
- S BHSRT="" F BHSQ=0:0 S BHSRT=$O(BHSRRT(BHSRT)) Q:BHSRT="" D RPRT2
- Q
- RPRT2 ;
- S X=$P(BHSRRT(BHSRT),U,1),BHSRR=$P(BHSRRT(BHSRT),U,2) D REGDT4^GMTSU S BHSRTD=X
- S BHSEDT=$P($G(BHSRRT(BHSRT)),U,3) I BHSEDT]"" S X=$P(BHSEDT,".") D REGDT4^GMTSU S BHSEDT=X
- ;S BHSRTX=$P(^RAMIS(71,BHSRT,0),U,1) D CKP^GMTSUP Q:$D(GMTSQIT) W BHSRTX,?BHSRW,"(",BHSRTD,") ",BHSRR,!
- S BHSRTX=$P(^RAMIS(71,BHSRT,0),U,1) D CKP^GMTSUP Q:$D(GMTSQIT) W !,BHSRTX,?BHSRW,"(",$S(BHSEDT]"":BHSEDT,1:BHSRTD),") "
- ;IHS/MSC/MGH Patch change
- I $P(BHSRRT(BHSRT),U,4)]"" W "RESULT: " S BHSDCD=$P(BHSRRT(BHSRT),U,4) W $S(BHSDCD]"":BHSDCD,1:"<none recorded>"),!
- I $P(BHSRRT(BHSRT),U,5)]"" W ?3,"Diagnostic Code: ",$P(BHSRRT(BHSRT),U,5),!
- W ?3,"IMPRESSION: " S BHSICL=16,BHSNRQ=BHSRR,BHSTXT="",BHSICD="" D PRTTXT^BHSUTL
- K BHSTXT,BHSNRQ
- Q
- DISPREF ;EP added in patch 2
- D CKP^GMTSUP Q:$D(GMTSQIT)
- N %,SNO
- S BHSRC=0
- S BHSX="" F S BHSX=$O(^AUPNPREF("AA",BHSPAT,BHSFN,BHSX)) Q:BHSX=""!($D(GMTSQIT)) D
- .S BHSD=0 F S BHSD=$O(^AUPNPREF("AA",BHSPAT,BHSFN,BHSX,BHSD)) Q:BHSD=""!(BHSD>GMTSDLM)!($D(GMTSQIT)) D
- ..S BHSI=0 F S BHSI=$O(^AUPNPREF("AA",BHSPAT,BHSFN,BHSX,BHSD,BHSI)) Q:BHSI=""!($D(GMTSQIT)) D
- ...I $D(BHSS) X BHSS Q:'%
- ...S BHSRC=BHSRC+1
- ...I BHSRC=1 I BHST]"" W !,BHST," Refusals "
- ...D CKP^GMTSUP Q:$D(GMTSQIT)
- ...S SNO=$$GET1^DIQ(9000022,BHSI,1.02)
- ...S SNO=$P($$DESC^BSTSAPI(SNO_"^^1"),U,2)
- ...I SNO="" S SNO=$$VAL^XBDIQ1(9000022,BHSI,.07)
- ...W !,$$VAL^XBDIQ1(9000022,BHSI,.04)," -- ",SNO,?60,"(",$$DATE^APCHSMU(9999999-BHSD),")"
- ...;W !,$$VAL^XBDIQ1(9000022,BHSI,.04)," -- ",$$VAL^XBDIQ1(9000022,BHSI,.07),?60,"(",$$DATE^APCHSMU(9999999-BHSD),")"
- ..Q
- .Q
- W !
- K BHST,BHSX,BHSD,BHSS,BHSFN,BHSI,BHSRC
- Q
- RAD ; ******************* RAD TESTS - ALL * 9000010.12 *******
- ; <SETUP>
- S BHSPAT=DFN
- I '$D(^AUPNVRAD("AA",BHSPAT)) S BHST="RADIOLOGY EXAM",BHSFN=71 D DISPREF^BHSRAD Q
- K BHSRRT
- ; <DISPLAY>
- S BHST="" F BHSQ=0:0 S BHST=$O(^AUPNVRAD("AA",BHSPAT,BHST)) Q:BHST="" S BHSTX=$P(^RAMIS(71,BHST,0),U,1),BHSTL=$L(BHSTX) D CKP^GMTSUP Q:$D(GMTSQIT) D RADBLD
- ; <CLEANUP>
- S BHST="RADIOLOGY EXAM",BHSFN=71 D DISPREF^BHSRAD
- K BHST,BHSFN
- RADX K BHST,BHSTX,BHSTL,BHSIVD,BHSDFN,BHSRDG,BHSVDF,BHSDAT,X,Y
- K BHSNFL,BHSNSH,BHSNAB,BHSVSC,BHSITE,BHS0
- Q
- RADBLD S BHSIVD="" F BHSQ=0:0 S BHSIVD=$O(^AUPNVRAD("AA",BHSPAT,BHST,BHSIVD)) Q:BHSIVD=""!(BHSIVD>GMTSDLM) D RADBLD1
- Q
- RADBLD1 ;
- D CKP^GMTSUP Q:$D(GMTSQIT) S X=-BHSIVD\1+9999999 D REGDT4^GMTSU S BHSDAT=X W !,BHSDAT
- S BHSDFN=0 F BHSQ=0:0 S BHSDFN=$O(^AUPNVRAD("AA",BHSPAT,BHST,BHSIVD,BHSDFN)) Q:'BHSDFN D
- .Q:'$D(^AUPNVRAD(BHSDFN,0))
- .S BHSEDT=$P($G(^AUPNVRAD(BHSDFN,12)),U,1)
- .D RADDSP
- Q
- RADDSP ;
- S BHS0=$P(^AUPNVRAD(BHSDFN,0),U,1)
- S BHSRTX=$P(^RAMIS(71,$P(BHS0,U),0),U,1) W ?11,BHSRTX I BHSEDT'=9999999-BHSIVD W " ("_$$FMTE^XLFDT(BHSEDT,5)_")"
- ;IHS/MSC/MGH IHS patch changes
- I $P(BHS0,U,5)]"" W !?11,"RESULT: " S BHSDCD=$P(BHS0,U,4) W $S(BHSDCD]"":BHSDCD,1:"<none recorded>"),!
- I $P(BHS0,U,6)]"" W ?3,"Diagnostic Code: ",$$VAL^XBDIQ1(9000010.22,BHSDFN,.05),!
- I $G(^AUPNVRAD(BHSDFN,11))]"" W ?11,"IMPRESSION: " S BHSICL=12,BHSNRQ=$G(^AUPNVRAD(BHSDFN,11)),BHSTXT="",BHSICD="" D PRTTXT^BHSUTL
- I $G(^AUPNVRAD(BHSDFN,11))="" W !
- K BHSTXT,BHSNRQ
- Q
- BHSRAD ;IHS/CIA/MGH - Health Summary for V RAD file ;02-Aug-2013 16:17;DU
- +1 ;;1.0;HEALTH SUMMARY COMPONENTS;**1,2,4,8**;March 17, 2006;Build 22
- +2 ;===================================================================
- +3 ;Taken from BHS3C
- +4 ; IHS/TUCSON/LAB - PART 3C OF APCHS -- SUMMARY PRODUCTION COMPONENTS ; [ 01/20/04 8:04 PM ]
- +5 ;;2.0;IHS RPMS/PCC Health Summary;**11,12**;JUN 24, 1997
- +6 ;IHS/CMI/LAB - patch 12 added new rad component
- +7 ;IHS/MSC/MGH Updated to IHS patch 15
- +8 ;IHS/MSC/MGH Patch 2 update to patch 16
- +9 ;IHS/MSC/MGH Patch 4 moved exams to its own routine
- +10 ;IHS/MSC/MGH patch 8 Updated refusals for SNOMED
- MRR ; ******************** MOST RECENT RADIOLOGY * 9000010.22 *******
- +1 NEW BHSPAT,BHSICD,BHSICL,BHSQ,X
- +2 SET BHSPAT=DFN
- +3 IF '$DATA(^AUPNVRAD("AA",BHSPAT))
- SET BHST="RADIOLOGY EXAM"
- SET BHSFN=71
- DO DISPREF^BHSRAD
- QUIT
- +4 DO CKP^GMTSUP
- IF $DATA(GMTSQIT)
- QUIT
- +5 ; <SETUP>
- +6 ; <PROCESS>
- +7 DO RBLD
- DO RPRT
- +8 ; <CLEANUP>
- +9 ;now display RAD refusals (patch 2)
- +10 SET BHST="RADIOLOGY EXAM"
- SET BHSFN=71
- DO DISPREF^BHSRAD
- +11 KILL BHST,BHSFN
- MRRX KILL BHSRT,BHSRR,BHSRTX,BHSRRT,BHSMXL,BHSRL,BHSRW,BHSNMX,BHSDFN,BHSIVD,BHSRTD,BHSN,BHSDCD,BHSEDT,Y
- +1 QUIT
- +2 ; <BUILD>
- RBLD KILL BHSRRT
- SET BHSMXL=0
- +1 SET BHSRRT=""
- FOR BHSQ=0:0
- SET BHSRRT=$ORDER(^AUPNVRAD("AA",BHSPAT,BHSRRT))
- IF BHSRRT=""
- QUIT
- DO RDATE
- +2 QUIT
- RDATE SET BHSIVD=$ORDER(^AUPNVRAD("AA",BHSPAT,BHSRRT,0))
- SET BHSDFN=$ORDER(^(BHSIVD,0))
- IF BHSIVD&(BHSIVD'>GMTSDLM)
- DO RSET
- +1 QUIT
- RSET SET BHSN=^AUPNVRAD(BHSDFN,0)
- SET BHSRR=$GET(^AUPNVRAD(BHSDFN,11))
- +1 ;NEW LINE!
- SET BHSEDT=$PIECE($GET(^AUPNVRAD(BHSDFN,12)),U)
- +2 SET X=$PIECE(BHSN,U,5)
- SET X=$$EXTSET^XBFUNC(9000010.22,.05,X)
- SET BHSDCD=X
- +3 ;S BHSRRT(BHSRRT)=(-BHSIVD\1+9999999)_U_BHSRR S BHSRTX=$P(^RAMIS(71,BHSRRT,0),U,1) S:$L(BHSRTX)>BHSMXL BHSMXL=$L(BHSRTX) ;ORIG LINE
- +4 SET BHSRRT(BHSRRT)=(-BHSIVD\1+9999999)_U_BHSRR_U_BHSEDT_U_BHSDCD_U_$$VAL^XBDIQ1(9000010.22,BHSDFN,.06)
- +5 SET BHSRTX=$PIECE(^RAMIS(71,BHSRRT,0),U,1)
- IF $LENGTH(BHSRTX)>BHSMXL
- SET BHSMXL=$LENGTH(BHSRTX)
- +6 QUIT
- +7 ; <PRINT>
- RPRT SET BHSRW=BHSMXL+1
- SET BHSRL=10
- SET BHSNMX=(IOM-1-BHSRW)\BHSRL
- +1 SET BHSRT=""
- FOR BHSQ=0:0
- SET BHSRT=$ORDER(BHSRRT(BHSRT))
- IF BHSRT=""
- QUIT
- DO RPRT2
- +2 QUIT
- RPRT2 ;
- +1 SET X=$PIECE(BHSRRT(BHSRT),U,1)
- SET BHSRR=$PIECE(BHSRRT(BHSRT),U,2)
- DO REGDT4^GMTSU
- SET BHSRTD=X
- +2 SET BHSEDT=$PIECE($GET(BHSRRT(BHSRT)),U,3)
- IF BHSEDT]""
- SET X=$PIECE(BHSEDT,".")
- DO REGDT4^GMTSU
- SET BHSEDT=X
- +3 ;S BHSRTX=$P(^RAMIS(71,BHSRT,0),U,1) D CKP^GMTSUP Q:$D(GMTSQIT) W BHSRTX,?BHSRW,"(",BHSRTD,") ",BHSRR,!
- +4 SET BHSRTX=$PIECE(^RAMIS(71,BHSRT,0),U,1)
- DO CKP^GMTSUP
- IF $DATA(GMTSQIT)
- QUIT
- WRITE !,BHSRTX,?BHSRW,"(",$SELECT(BHSEDT]"":BHSEDT,1:BHSRTD),") "
- +5 ;IHS/MSC/MGH Patch change
- +6 IF $PIECE(BHSRRT(BHSRT),U,4)]""
- WRITE "RESULT: "
- SET BHSDCD=$PIECE(BHSRRT(BHSRT),U,4)
- WRITE $SELECT(BHSDCD]"":BHSDCD,1:"<none recorded>"),!
- +7 IF $PIECE(BHSRRT(BHSRT),U,5)]""
- WRITE ?3,"Diagnostic Code: ",$PIECE(BHSRRT(BHSRT),U,5),!
- +8 WRITE ?3,"IMPRESSION: "
- SET BHSICL=16
- SET BHSNRQ=BHSRR
- SET BHSTXT=""
- SET BHSICD=""
- DO PRTTXT^BHSUTL
- +9 KILL BHSTXT,BHSNRQ
- +10 QUIT
- DISPREF ;EP added in patch 2
- +1 DO CKP^GMTSUP
- IF $DATA(GMTSQIT)
- QUIT
- +2 NEW %,SNO
- +3 SET BHSRC=0
- +4 SET BHSX=""
- FOR
- SET BHSX=$ORDER(^AUPNPREF("AA",BHSPAT,BHSFN,BHSX))
- IF BHSX=""!($DATA(GMTSQIT))
- QUIT
- Begin DoDot:1
- +5 SET BHSD=0
- FOR
- SET BHSD=$ORDER(^AUPNPREF("AA",BHSPAT,BHSFN,BHSX,BHSD))
- IF BHSD=""!(BHSD>GMTSDLM)!($DATA(GMTSQIT))
- QUIT
- Begin DoDot:2
- +6 SET BHSI=0
- FOR
- SET BHSI=$ORDER(^AUPNPREF("AA",BHSPAT,BHSFN,BHSX,BHSD,BHSI))
- IF BHSI=""!($DATA(GMTSQIT))
- QUIT
- Begin DoDot:3
- +7 IF $DATA(BHSS)
- XECUTE BHSS
- IF '%
- QUIT
- +8 SET BHSRC=BHSRC+1
- +9 IF BHSRC=1
- IF BHST]""
- WRITE !,BHST," Refusals "
- +10 DO CKP^GMTSUP
- IF $DATA(GMTSQIT)
- QUIT
- +11 SET SNO=$$GET1^DIQ(9000022,BHSI,1.02)
- +12 SET SNO=$PIECE($$DESC^BSTSAPI(SNO_"^^1"),U,2)
- +13 IF SNO=""
- SET SNO=$$VAL^XBDIQ1(9000022,BHSI,.07)
- +14 WRITE !,$$VAL^XBDIQ1(9000022,BHSI,.04)," -- ",SNO,?60,"(",$$DATE^APCHSMU(9999999-BHSD),")"
- +15 ;W !,$$VAL^XBDIQ1(9000022,BHSI,.04)," -- ",$$VAL^XBDIQ1(9000022,BHSI,.07),?60,"(",$$DATE^APCHSMU(9999999-BHSD),")"
- End DoDot:3
- +16 QUIT
- End DoDot:2
- +17 QUIT
- End DoDot:1
- +18 WRITE !
- +19 KILL BHST,BHSX,BHSD,BHSS,BHSFN,BHSI,BHSRC
- +20 QUIT
- RAD ; ******************* RAD TESTS - ALL * 9000010.12 *******
- +1 ; <SETUP>
- +2 SET BHSPAT=DFN
- +3 IF '$DATA(^AUPNVRAD("AA",BHSPAT))
- SET BHST="RADIOLOGY EXAM"
- SET BHSFN=71
- DO DISPREF^BHSRAD
- QUIT
- +4 KILL BHSRRT
- +5 ; <DISPLAY>
- +6 SET BHST=""
- FOR BHSQ=0:0
- SET BHST=$ORDER(^AUPNVRAD("AA",BHSPAT,BHST))
- IF BHST=""
- QUIT
- SET BHSTX=$PIECE(^RAMIS(71,BHST,0),U,1)
- SET BHSTL=$LENGTH(BHSTX)
- DO CKP^GMTSUP
- IF $DATA(GMTSQIT)
- QUIT
- DO RADBLD
- +7 ; <CLEANUP>
- +8 SET BHST="RADIOLOGY EXAM"
- SET BHSFN=71
- DO DISPREF^BHSRAD
- +9 KILL BHST,BHSFN
- RADX KILL BHST,BHSTX,BHSTL,BHSIVD,BHSDFN,BHSRDG,BHSVDF,BHSDAT,X,Y
- +1 KILL BHSNFL,BHSNSH,BHSNAB,BHSVSC,BHSITE,BHS0
- +2 QUIT
- RADBLD SET BHSIVD=""
- FOR BHSQ=0:0
- SET BHSIVD=$ORDER(^AUPNVRAD("AA",BHSPAT,BHST,BHSIVD))
- IF BHSIVD=""!(BHSIVD>GMTSDLM)
- QUIT
- DO RADBLD1
- +1 QUIT
- RADBLD1 ;
- +1 DO CKP^GMTSUP
- IF $DATA(GMTSQIT)
- QUIT
- SET X=-BHSIVD\1+9999999
- DO REGDT4^GMTSU
- SET BHSDAT=X
- WRITE !,BHSDAT
- +2 SET BHSDFN=0
- FOR BHSQ=0:0
- SET BHSDFN=$ORDER(^AUPNVRAD("AA",BHSPAT,BHST,BHSIVD,BHSDFN))
- IF 'BHSDFN
- QUIT
- Begin DoDot:1
- +3 IF '$DATA(^AUPNVRAD(BHSDFN,0))
- QUIT
- +4 SET BHSEDT=$PIECE($GET(^AUPNVRAD(BHSDFN,12)),U,1)
- +5 DO RADDSP
- End DoDot:1
- +6 QUIT
- RADDSP ;
- +1 SET BHS0=$PIECE(^AUPNVRAD(BHSDFN,0),U,1)
- +2 SET BHSRTX=$PIECE(^RAMIS(71,$PIECE(BHS0,U),0),U,1)
- WRITE ?11,BHSRTX
- IF BHSEDT'=9999999-BHSIVD
- WRITE " ("_$$FMTE^XLFDT(BHSEDT,5)_")"
- +3 ;IHS/MSC/MGH IHS patch changes
- +4 IF $PIECE(BHS0,U,5)]""
- WRITE !?11,"RESULT: "
- SET BHSDCD=$PIECE(BHS0,U,4)
- WRITE $SELECT(BHSDCD]"":BHSDCD,1:"<none recorded>"),!
- +5 IF $PIECE(BHS0,U,6)]""
- WRITE ?3,"Diagnostic Code: ",$$VAL^XBDIQ1(9000010.22,BHSDFN,.05),!
- +6 IF $GET(^AUPNVRAD(BHSDFN,11))]""
- WRITE ?11,"IMPRESSION: "
- SET BHSICL=12
- SET BHSNRQ=$GET(^AUPNVRAD(BHSDFN,11))
- SET BHSTXT=""
- SET BHSICD=""
- DO PRTTXT^BHSUTL
- +7 IF $GET(^AUPNVRAD(BHSDFN,11))=""
- WRITE !
- +8 KILL BHSTXT,BHSNRQ
- +9 QUIT
