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
