BHSENC ;IHS/CIA/MGH - Encounters from PCC ;09-Mar-2016 09:59;du
;;1.0;HEALTH SUMMARY COMPONENTS;**8,13**;Jan 06, 2006;Build 6
;===================================================================
;Taken from APCHS2B
; IHS/TUCSON/LAB - PART 2B OF BHS -- SUMMARY PRODUCTION COMPONENTS ; [ 06/10/03 11:13 AM ]
;;2.0;IHS RPMS/PCC Health Summary;**3,11,12**;JUN 24, 1997
;
OUTPT ; ********** OUTPATIENT ENCOUNTERS * 9000010/9000010.07 **********
; <SETUP>
N BHSN,BHSNTE,BHSPRV,BHSQ,X
S BHSPAT=DFN
Q:'$D(^AUPNVSIT("AA",BHSPAT))
S BHSOVT="ARSCOTE" ; NOTE: THIS CONTROLS TYPES OF VISITS DISPLAYED
D CKP^GMTSUP Q:$D(GMTSQIT)
; <DISPLAY>
S BHSPVD=0
S BHSPFN="" S BHSDCX="",BHSDPR=""
I GMPXHLOC="Y" S BHSDCX=1
S BHSDPR=1
I 'BHSDPR,'BHSDCX S BHSDCL=23
I BHSDCX,'BHSDPR S BHSDCL=32
I BHSDCX,BHSDPR S BHSDCL=35
I 'BHSDCX,BHSDPR S BHSDCL=28
F BHSIVD=0:0 S BHSIVD=$O(^AUPNVSIT("AA",BHSPAT,BHSIVD)) Q:BHSIVD=""!(BHSIVD>GMTSDLM) D Q:GMTSNDM=0!(BHSQT)
. S BHSQT=1
. D ONEDATE
. Q:$D(GMTSQIT)
. S:(BHSDAT'=BHSPVD)&BHSDTU GMTSNDM=GMTSNDM-BHSDTU,BHSPVD=BHSDAT
. S BHSQT=0
. Q
;
OUTPTX ; <CLEANUP>
K BHSIVD,BHSDTU,BHSDAT,BHSVDF,BHSFAC,BHSPFN,BHSSCL,BHSMTX,BHSMOD,BHSPVD,BHSOVT,GMTSNDT,BHSCLI,BHSPDN,BHSICD,BHSP,BHSICL,BHSNRQ,BHSDPR,BHSDCX
K BHSNFL,BHSNSH,BHSCCL,BHSNAB,BHSVSC,BHSITE,BHSQT,BHSDCL,Y,BHSSNO,BHSNORM
Q
;
ONEDATE ;
S BHSCCL=""
S X=-BHSIVD\1+9999999 D REGDT4^GMTSU S BHSDAT=X
S BHSDTU=0,GMTSNDT=(BHSDAT'=BHSPVD)
S BHSVDF="" F BHSQ=0:0 S BHSVDF=$O(^AUPNVSIT("AA",BHSPAT,BHSIVD,BHSVDF)) Q:BHSVDF="" D Q:BHSQT
. S BHSQT=1
. S BHSSCL=""
. S BHSN=^AUPNVSIT(BHSVDF,0)
. I $P(BHSN,U,7)="E",'$D(^AUPNVPOV("AD",BHSVDF)) Q ;don't display events with no pov
. I $P(BHSN,U,7)="I",'$D(^AUPNVPOV("AD",BHSVDF)) Q ;don't display events with no pov
. I +$P(BHSN,U,9),'$P(BHSN,U,11) D GETCLN,GETPROV,GETSITEV^BHSUTL D
.. I BHSOVT[BHSVSC D DSPVIS
.. Q
. Q:$D(GMTSQIT)
. S BHSQT=0
. Q
Q
;
GETPROV ;
S BHSPRV=$$PRIMPROV^APCLV(BHSVDF,"T")
Q
GETCLN ;
S BHSCLI=$P(BHSN,U,8) I BHSCLI="" S BHSCCL="<none>" Q
S BHSCLI=$P(BHSN,U,8) Q:BHSCLI=""
Q:'$D(^DIC(40.7,BHSCLI))
I $D(^DIC(40.7,BHSCLI,9999999)),$P(^(9999999),U,1)]"" S BHSCLI=$E($P(^DIC(40.7,BHSCLI,9999999),U,1),1,6),BHSCCL=BHSCLI Q
S BHSCLI=$E($P(^DIC(40.7,BHSCLI,0),U,1),1,8)
S BHSCCL=BHSCLI
Q
DSPVIS ;
S BHSDTU=1
I $O(^AUPNVPOV("AD",BHSVDF,""))="" D NOPOV Q
S BHSPDN="" F BHSQ=0:0 S BHSPDN=$O(^AUPNVPOV("AD",BHSVDF,BHSPDN)) Q:'BHSPDN S BHSN=^AUPNVPOV(BHSPDN,0) D HASPOV
Q
;
NOPOV ;
S (BHSICD,BHSNRQ)="<purpose of visit not yet entered>",BHSMOD=""
G COMMON
;
HASPOV ;
;IHS/MSC/MGH added norm/abnormal Patch 13
S BHSICD=$P(BHSN,U,1) D GETICDDX^BHSUTL
S BHSSNO=$$GET1^DIQ(9000010.07,BHSPDN,1101)
S BHSNORM=$$GET1^DIQ(9000010.07,BHSPDN,.29)
S BHSNRQ=$P(BHSN,U,4)
;D GETNARR^BHSUTL I $P(BHSN,U,5)]"" S BHSNRQ=BHSNRQ_" (Stage: "_$P(BHSN,U,5)_")" ;IHS/CMI/LAB - patched to display stage of 0
D GETNARR^BHSUTL I BHSSNO'="" S BHSNRQ=BHSNRQ_";"_BHSNORM_" ("_BHSSNO_")" ;patch 8 add SNOMED
S BHSMOD=$P(BHSN,U,6)
COMMON ;
D CKP^GMTSUP Q:$D(GMTSQIT) S:GMTSNPG GMTSNDT=1
I GMTSNDT W BHSDAT S (BHSPFN,BHSSCL)="",GMTSNDT=0
I BHSNSH=BHSPFN S BHSFAC=""
E S (BHSFAC,BHSPFN)=BHSNSH,BHSSCL=""
I BHSCCL=BHSSCL S BHSCLI=""
E S (BHSCLI,BHSSCL)=BHSCCL
I BHSICD["<purpose of visit not"&(BHSSCL="<none>") S BHSCLI=""
I BHSMOD]"" S BHSMTX=$P(^DD(9000010.07,.06,0),U,3),BHSMTX=$P($P(BHSMTX,BHSMOD_":",2),";",1),BHSMTX=$P(BHSMTX,",",1),BHSICD=BHSMTX_" "_BHSICD
S:$D(^AUPNVCHS("AD",BHSVDF)) BHSNTE="*** CHS ***"
;S BHSICL=$S(BHSCLI'=" ":35,1:23)
W ?10,BHSFAC
I BHSDCX,BHSDPR W ?23,$E(BHSCLI,1,6),?30,BHSPRV
I BHSDCX,'BHSDPR W ?23,BHSCLI
I 'BHSDCX,BHSDPR W ?23,BHSPRV
S BHSICL=BHSDCL
S:0 BHSICD=BHSVSC_":"_BHSICD D PRTICD^BHSUTL
I $D(BHSPDN) D QUAL(BHSPDN) ;Patch 8 add qualifiers
Q
INHOSP ; ********** INHOSPITAL ENCOUNTERS * 9000010/9000010.07 **********
; <SETUP>
N BHSPAT
S BHSPAT=DFN
Q:'$D(^AUPNVSIT("AA",BHSPAT))
S BHSOVT="I" ; NOTE: This controls types of visits displayed
D CKP^GMTSUP Q:$D(GMTSQIT)
; <DISPLAY>
S BHSDCX="",BHSDPR=""
I GMPXHLOC="Y" S BHSDCX=1
S BHSDPR=1
I 'BHSDPR,'BHSDCX S BHSDCL=23
I BHSDCX,'BHSDPR S BHSDCL=32
I BHSDCX,BHSDPR S BHSDCL=35
I 'BHSDCX,BHSDPR S BHSDCL=28
S BHSPVD=0
F BHSIVD=0:0 S BHSIVD=$O(^AUPNVSIT("AA",BHSPAT,BHSIVD)) Q:BHSIVD=""!(BHSIVD>GMTSDLM) D ONEDATE Q:$D(GMTSQIT) S:(BHSDAT'=BHSPVD)&BHSDTU GMTSNDM=GMTSNDM-BHSDTU,BHSPVD=BHSDAT Q:GMTSNDM=0
; <CLEANUP>
INHOSPX K BHSIVD,BHSDTU,BHSDAT,BHSVDF,BHSFAC,BHSPFN,BHSSCL,BHSMTX,BHSMOD,BHSPVD,BHSOVT,GMTSNDT,BHSCLI,BHSPDN,BHSICD,BHSICL,BHSNRQ
K BHSNFL,BHSNSH,BHSNAB,BHSVSC,BHSITE,Y
Q
;
QUAL(IEN) ;Get any qualifiers for this problem
N AIEN,FNUM,Q,STRING,STRING2,STRING3,STRING4,X,IEN2
Q:$G(IEN)=""
S (STRING,STRING2,STRING3,STRING4)=""
;Return qualifiers
F X=13,17,18,14 D
.S STRING=""
.S IEN2=0 F S IEN2=$O(^AUPNVPOV(IEN,X,IEN2)) Q:'+IEN2 D
..S FNUM=$S(X=13:9000010.0713,X=17:9000010.0717,X=18:9000010.0718,X=14:9000010.0714)
..S AIEN=IEN2_","_IEN_","
..S Q=$$GET1^DIQ(FNUM,AIEN,.01)
..S Q=$$CONCEPT^BGOPAUD(Q)
..S STRING=$S(STRING="":Q,1:STRING_" "_Q)
.I STRING'="" D
..W ?30,STRING,!
BHSENC ;IHS/CIA/MGH - Encounters from PCC ;09-Mar-2016 09:59;du
+1 ;;1.0;HEALTH SUMMARY COMPONENTS;**8,13**;Jan 06, 2006;Build 6
+2 ;===================================================================
+3 ;Taken from APCHS2B
+4 ; IHS/TUCSON/LAB - PART 2B OF BHS -- SUMMARY PRODUCTION COMPONENTS ; [ 06/10/03 11:13 AM ]
+5 ;;2.0;IHS RPMS/PCC Health Summary;**3,11,12**;JUN 24, 1997
+6 ;
OUTPT ; ********** OUTPATIENT ENCOUNTERS * 9000010/9000010.07 **********
+1 ; <SETUP>
+2 NEW BHSN,BHSNTE,BHSPRV,BHSQ,X
+3 SET BHSPAT=DFN
+4 IF '$DATA(^AUPNVSIT("AA",BHSPAT))
QUIT
+5 ; NOTE: THIS CONTROLS TYPES OF VISITS DISPLAYED
SET BHSOVT="ARSCOTE"
+6 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+7 ; <DISPLAY>
+8 SET BHSPVD=0
+9 SET BHSPFN=""
SET BHSDCX=""
SET BHSDPR=""
+10 IF GMPXHLOC="Y"
SET BHSDCX=1
+11 SET BHSDPR=1
+12 IF 'BHSDPR
IF 'BHSDCX
SET BHSDCL=23
+13 IF BHSDCX
IF 'BHSDPR
SET BHSDCL=32
+14 IF BHSDCX
IF BHSDPR
SET BHSDCL=35
+15 IF 'BHSDCX
IF BHSDPR
SET BHSDCL=28
+16 FOR BHSIVD=0:0
SET BHSIVD=$ORDER(^AUPNVSIT("AA",BHSPAT,BHSIVD))
IF BHSIVD=""!(BHSIVD>GMTSDLM)
QUIT
Begin DoDot:1
+17 SET BHSQT=1
+18 DO ONEDATE
+19 IF $DATA(GMTSQIT)
QUIT
+20 IF (BHSDAT'=BHSPVD)&BHSDTU
SET GMTSNDM=GMTSNDM-BHSDTU
SET BHSPVD=BHSDAT
+21 SET BHSQT=0
+22 QUIT
End DoDot:1
IF GMTSNDM=0!(BHSQT)
QUIT
+23 ;
OUTPTX ; <CLEANUP>
+1 KILL BHSIVD,BHSDTU,BHSDAT,BHSVDF,BHSFAC,BHSPFN,BHSSCL,BHSMTX,BHSMOD,BHSPVD,BHSOVT,GMTSNDT,BHSCLI,BHSPDN,BHSICD,BHSP,BHSICL,BHSNRQ,BHSDPR,BHSDCX
+2 KILL BHSNFL,BHSNSH,BHSCCL,BHSNAB,BHSVSC,BHSITE,BHSQT,BHSDCL,Y,BHSSNO,BHSNORM
+3 QUIT
+4 ;
ONEDATE ;
+1 SET BHSCCL=""
+2 SET X=-BHSIVD\1+9999999
DO REGDT4^GMTSU
SET BHSDAT=X
+3 SET BHSDTU=0
SET GMTSNDT=(BHSDAT'=BHSPVD)
+4 SET BHSVDF=""
FOR BHSQ=0:0
SET BHSVDF=$ORDER(^AUPNVSIT("AA",BHSPAT,BHSIVD,BHSVDF))
IF BHSVDF=""
QUIT
Begin DoDot:1
+5 SET BHSQT=1
+6 SET BHSSCL=""
+7 SET BHSN=^AUPNVSIT(BHSVDF,0)
+8 ;don't display events with no pov
IF $PIECE(BHSN,U,7)="E"
IF '$DATA(^AUPNVPOV("AD",BHSVDF))
QUIT
+9 ;don't display events with no pov
IF $PIECE(BHSN,U,7)="I"
IF '$DATA(^AUPNVPOV("AD",BHSVDF))
QUIT
+10 IF +$PIECE(BHSN,U,9)
IF '$PIECE(BHSN,U,11)
DO GETCLN
DO GETPROV
DO GETSITEV^BHSUTL
Begin DoDot:2
+11 IF BHSOVT[BHSVSC
DO DSPVIS
+12 QUIT
End DoDot:2
+13 IF $DATA(GMTSQIT)
QUIT
+14 SET BHSQT=0
+15 QUIT
End DoDot:1
IF BHSQT
QUIT
+16 QUIT
+17 ;
GETPROV ;
+1 SET BHSPRV=$$PRIMPROV^APCLV(BHSVDF,"T")
+2 QUIT
GETCLN ;
+1 SET BHSCLI=$PIECE(BHSN,U,8)
IF BHSCLI=""
SET BHSCCL="<none>"
QUIT
+2 SET BHSCLI=$PIECE(BHSN,U,8)
IF BHSCLI=""
QUIT
+3 IF '$DATA(^DIC(40.7,BHSCLI))
QUIT
+4 IF $DATA(^DIC(40.7,BHSCLI,9999999))
IF $PIECE(^(9999999),U,1)]""
SET BHSCLI=$EXTRACT($PIECE(^DIC(40.7,BHSCLI,9999999),U,1),1,6)
SET BHSCCL=BHSCLI
QUIT
+5 SET BHSCLI=$EXTRACT($PIECE(^DIC(40.7,BHSCLI,0),U,1),1,8)
+6 SET BHSCCL=BHSCLI
+7 QUIT
DSPVIS ;
+1 SET BHSDTU=1
+2 IF $ORDER(^AUPNVPOV("AD",BHSVDF,""))=""
DO NOPOV
QUIT
+3 SET BHSPDN=""
FOR BHSQ=0:0
SET BHSPDN=$ORDER(^AUPNVPOV("AD",BHSVDF,BHSPDN))
IF 'BHSPDN
QUIT
SET BHSN=^AUPNVPOV(BHSPDN,0)
DO HASPOV
+4 QUIT
+5 ;
NOPOV ;
+1 SET (BHSICD,BHSNRQ)="<purpose of visit not yet entered>"
SET BHSMOD=""
+2 GOTO COMMON
+3 ;
HASPOV ;
+1 ;IHS/MSC/MGH added norm/abnormal Patch 13
+2 SET BHSICD=$PIECE(BHSN,U,1)
DO GETICDDX^BHSUTL
+3 SET BHSSNO=$$GET1^DIQ(9000010.07,BHSPDN,1101)
+4 SET BHSNORM=$$GET1^DIQ(9000010.07,BHSPDN,.29)
+5 SET BHSNRQ=$PIECE(BHSN,U,4)
+6 ;D GETNARR^BHSUTL I $P(BHSN,U,5)]"" S BHSNRQ=BHSNRQ_" (Stage: "_$P(BHSN,U,5)_")" ;IHS/CMI/LAB - patched to display stage of 0
+7 ;patch 8 add SNOMED
DO GETNARR^BHSUTL
IF BHSSNO'=""
SET BHSNRQ=BHSNRQ_";"_BHSNORM_" ("_BHSSNO_")"
+8 SET BHSMOD=$PIECE(BHSN,U,6)
COMMON ;
+1 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
IF GMTSNPG
SET GMTSNDT=1
+2 IF GMTSNDT
WRITE BHSDAT
SET (BHSPFN,BHSSCL)=""
SET GMTSNDT=0
+3 IF BHSNSH=BHSPFN
SET BHSFAC=""
+4 IF '$TEST
SET (BHSFAC,BHSPFN)=BHSNSH
SET BHSSCL=""
+5 IF BHSCCL=BHSSCL
SET BHSCLI=""
+6 IF '$TEST
SET (BHSCLI,BHSSCL)=BHSCCL
+7 IF BHSICD["<purpose of visit not"&(BHSSCL="<none>")
SET BHSCLI=""
+8 IF BHSMOD]""
SET BHSMTX=$PIECE(^DD(9000010.07,.06,0),U,3)
SET BHSMTX=$PIECE($PIECE(BHSMTX,BHSMOD_":",2),";",1)
SET BHSMTX=$PIECE(BHSMTX,",",1)
SET BHSICD=BHSMTX_" "_BHSICD
+9 IF $DATA(^AUPNVCHS("AD",BHSVDF))
SET BHSNTE="*** CHS ***"
+10 ;S BHSICL=$S(BHSCLI'=" ":35,1:23)
+11 WRITE ?10,BHSFAC
+12 IF BHSDCX
IF BHSDPR
WRITE ?23,$EXTRACT(BHSCLI,1,6),?30,BHSPRV
+13 IF BHSDCX
IF 'BHSDPR
WRITE ?23,BHSCLI
+14 IF 'BHSDCX
IF BHSDPR
WRITE ?23,BHSPRV
+15 SET BHSICL=BHSDCL
+16 IF 0
SET BHSICD=BHSVSC_":"_BHSICD
DO PRTICD^BHSUTL
+17 ;Patch 8 add qualifiers
IF $DATA(BHSPDN)
DO QUAL(BHSPDN)
+18 QUIT
INHOSP ; ********** INHOSPITAL ENCOUNTERS * 9000010/9000010.07 **********
+1 ; <SETUP>
+2 NEW BHSPAT
+3 SET BHSPAT=DFN
+4 IF '$DATA(^AUPNVSIT("AA",BHSPAT))
QUIT
+5 ; NOTE: This controls types of visits displayed
SET BHSOVT="I"
+6 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+7 ; <DISPLAY>
+8 SET BHSDCX=""
SET BHSDPR=""
+9 IF GMPXHLOC="Y"
SET BHSDCX=1
+10 SET BHSDPR=1
+11 IF 'BHSDPR
IF 'BHSDCX
SET BHSDCL=23
+12 IF BHSDCX
IF 'BHSDPR
SET BHSDCL=32
+13 IF BHSDCX
IF BHSDPR
SET BHSDCL=35
+14 IF 'BHSDCX
IF BHSDPR
SET BHSDCL=28
+15 SET BHSPVD=0
+16 FOR BHSIVD=0:0
SET BHSIVD=$ORDER(^AUPNVSIT("AA",BHSPAT,BHSIVD))
IF BHSIVD=""!(BHSIVD>GMTSDLM)
QUIT
DO ONEDATE
IF $DATA(GMTSQIT)
QUIT
IF (BHSDAT'=BHSPVD)&BHSDTU
SET GMTSNDM=GMTSNDM-BHSDTU
SET BHSPVD=BHSDAT
IF GMTSNDM=0
QUIT
+17 ; <CLEANUP>
INHOSPX KILL BHSIVD,BHSDTU,BHSDAT,BHSVDF,BHSFAC,BHSPFN,BHSSCL,BHSMTX,BHSMOD,BHSPVD,BHSOVT,GMTSNDT,BHSCLI,BHSPDN,BHSICD,BHSICL,BHSNRQ
+1 KILL BHSNFL,BHSNSH,BHSNAB,BHSVSC,BHSITE,Y
+2 QUIT
+3 ;
QUAL(IEN) ;Get any qualifiers for this problem
+1 NEW AIEN,FNUM,Q,STRING,STRING2,STRING3,STRING4,X,IEN2
+2 IF $GET(IEN)=""
QUIT
+3 SET (STRING,STRING2,STRING3,STRING4)=""
+4 ;Return qualifiers
+5 FOR X=13,17,18,14
Begin DoDot:1
+6 SET STRING=""
+7 SET IEN2=0
FOR
SET IEN2=$ORDER(^AUPNVPOV(IEN,X,IEN2))
IF '+IEN2
QUIT
Begin DoDot:2
+8 SET FNUM=$SELECT(X=13:9000010.0713,X=17:9000010.0717,X=18:9000010.0718,X=14:9000010.0714)
+9 SET AIEN=IEN2_","_IEN_","
+10 SET Q=$$GET1^DIQ(FNUM,AIEN,.01)
+11 SET Q=$$CONCEPT^BGOPAUD(Q)
+12 SET STRING=$SELECT(STRING="":Q,1:STRING_" "_Q)
End DoDot:2
+13 IF STRING'=""
Begin DoDot:2
+14 WRITE ?30,STRING,!
End DoDot:2
End DoDot:1
