BHSENC2 ;IHS/CIA/MGH - Encounters from PCC ;09-Mar-2016 09:59;du
;;1.0;HEALTH SUMMARY COMPONENTS;**8,13**;Jan 6,2006;Build 6
;===================================================================
;Taken from APCH2H
; IHS/TUCSON/LAB - PART 2B OF BHS -- SUMMARY PRODUCTION COMPONENTS ; [ 02/20/04 1:17 PM ]
;;2.0;IHS RPMS/PCC Health Summary;**6,11**;JUN 24, 1997
;=====================================================================
OUTPT ; ********** OUTPATIENT ENCOUNTERS WITHOUT CHR * 9000010/9000010.07 **********
; <SETUP>
N BHSPAT,BHSN,BHSNTE,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,BHSICL,BHSNRQ
K BHSNFL,BHSNSH,BHSCCL,BHSNAB,BHSVSC,BHSITE,BHSQT,BHSDCL,Y,BHSDCX,BHSDPR,BHSQ,BHSPRV,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,9),'$P(BHSN,U,11) D GETCLN,GETPROV,GETSITEV^BHSUTL D
.. Q:$$PRIMPROV^APCLV(BHSVDF,"D")=53 ;exclude chr prim prov
.. I $P(BHSN,U,7)="E",'$D(^AUPNVPOV("AD",BHSVDF)) Q ;don't display events with no pov
.. 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=$P(^DIC(40.7,BHSCLI,9999999),U,1),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 normal/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
S BHSNRQ=$P(BHSN,U,4)
D GETNARR^BHSUTL I BHSSNO'="" S BHSNRQ=BHSNRQ_";"_BHSNORM_" ("_BHSSNO_")" ;Patch 8 added SNOMED
S BHSMOD=$P(BHSN,U,6)
I $D(BHSPDN) D QUAL^BHSENC(BHSPDN) ;Patch 8 added qualifers
;
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 ***"
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^BHSENC(BHSPDN) ;Patch 8 added qualifers
Q
INHOSP ; ********** INHOSPITAL ENCOUNTERS * 9000010/9000010.07 **********
; <SETUP>
Q:'$D(^AUPNVSIT("AA",BHSPAT))
S BHSOVT="I" ; NOTE: This controls types of visits displayed
D CKP^GMTSUP Q:$D(GMTSQIT)
; <DISPLAY>
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
;
BHSENC2 ;IHS/CIA/MGH - Encounters from PCC ;09-Mar-2016 09:59;du
+1 ;;1.0;HEALTH SUMMARY COMPONENTS;**8,13**;Jan 6,2006;Build 6
+2 ;===================================================================
+3 ;Taken from APCH2H
+4 ; IHS/TUCSON/LAB - PART 2B OF BHS -- SUMMARY PRODUCTION COMPONENTS ; [ 02/20/04 1:17 PM ]
+5 ;;2.0;IHS RPMS/PCC Health Summary;**6,11**;JUN 24, 1997
+6 ;=====================================================================
OUTPT ; ********** OUTPATIENT ENCOUNTERS WITHOUT CHR * 9000010/9000010.07 **********
+1 ; <SETUP>
+2 NEW BHSPAT,BHSN,BHSNTE,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=""
+10 SET BHSDCX=""
SET BHSDPR=""
+11 IF GMPXHLOC="Y"
SET BHSDCX=1
+12 SET BHSDPR=1
+13 IF 'BHSDPR
IF 'BHSDCX
SET BHSDCL=23
+14 IF BHSDCX
IF 'BHSDPR
SET BHSDCL=32
+15 IF BHSDCX
IF BHSDPR
SET BHSDCL=35
+16 IF 'BHSDCX
IF BHSDPR
SET BHSDCL=28
+17 FOR BHSIVD=0:0
SET BHSIVD=$ORDER(^AUPNVSIT("AA",BHSPAT,BHSIVD))
IF BHSIVD=""!(BHSIVD>GMTSDLM)
QUIT
Begin DoDot:1
+18 SET BHSQT=1
+19 DO ONEDATE
+20 IF $DATA(GMTSQIT)
QUIT
+21 IF (BHSDAT'=BHSPVD)&BHSDTU
SET GMTSNDM=GMTSNDM-BHSDTU
SET BHSPVD=BHSDAT
+22 SET BHSQT=0
+23 QUIT
End DoDot:1
IF GMTSNDM=0!(BHSQT)
QUIT
+24 ;
OUTPTX ; <CLEANUP>
+1 KILL BHSIVD,BHSDTU,BHSDAT,BHSVDF,BHSFAC,BHSPFN,BHSSCL,BHSMTX,BHSMOD,BHSPVD,BHSOVT,GMTSNDT,BHSCLI,BHSPDN,BHSICD,BHSICL,BHSNRQ
+2 KILL BHSNFL,BHSNSH,BHSCCL,BHSNAB,BHSVSC,BHSITE,BHSQT,BHSDCL,Y,BHSDCX,BHSDPR,BHSQ,BHSPRV,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 IF +$PIECE(BHSN,U,9)
IF '$PIECE(BHSN,U,11)
DO GETCLN
DO GETPROV
DO GETSITEV^BHSUTL
Begin DoDot:2
+9 ;exclude chr prim prov
IF $$PRIMPROV^APCLV(BHSVDF,"D")=53
QUIT
+10 ;don't display events with no pov
IF $PIECE(BHSN,U,7)="E"
IF '$DATA(^AUPNVPOV("AD",BHSVDF))
QUIT
+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=$PIECE(^DIC(40.7,BHSCLI,9999999),U,1)
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 normal/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 ;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
+6 SET BHSNRQ=$PIECE(BHSN,U,4)
+7 ;Patch 8 added SNOMED
DO GETNARR^BHSUTL
IF BHSSNO'=""
SET BHSNRQ=BHSNRQ_";"_BHSNORM_" ("_BHSSNO_")"
+8 SET BHSMOD=$PIECE(BHSN,U,6)
+9 ;Patch 8 added qualifers
IF $DATA(BHSPDN)
DO QUAL^BHSENC(BHSPDN)
+10 ;
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 WRITE ?10,BHSFAC
+11 IF BHSDCX
IF BHSDPR
WRITE ?23,$EXTRACT(BHSCLI,1,6),?30,BHSPRV
+12 IF BHSDCX
IF 'BHSDPR
WRITE ?23,BHSCLI
+13 IF 'BHSDCX
IF BHSDPR
WRITE ?23,BHSPRV
+14 SET BHSICL=BHSDCL
+15 IF 0
SET BHSICD=BHSVSC_":"_BHSICD
DO PRTICD^BHSUTL
+16 ;Patch 8 added qualifers
IF $DATA(BHSPDN)
DO QUAL^BHSENC(BHSPDN)
+17 QUIT
INHOSP ; ********** INHOSPITAL ENCOUNTERS * 9000010/9000010.07 **********
+1 ; <SETUP>
+2 IF '$DATA(^AUPNVSIT("AA",BHSPAT))
QUIT
+3 ; NOTE: This controls types of visits displayed
SET BHSOVT="I"
+4 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+5 ; <DISPLAY>
+6 SET BHSPVD=0
+7 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
+8 ; <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 ;
