- 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