Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BHSENC

BHSENC.m

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