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

BHSPLST1.m

Go to the documentation of this file.
  1. BHSPLST1 ;IHS/MSC/MGH - Health Summary for Problem list;28-Apr-2016 14:48;DU
  1. ;;1.0;HEALTH SUMMARY COMPONENTS;**13**;Mar 17,2006;Build 6
  1. ; IHS/CMI/LAB - PART 4 OF APCHS -- SUMMARY PRODUCTION COMPONENTS ;31-Mar-2014 16:53;DU
  1. ;
  1. PROB ; ******************** PROBLEM / NOTES * 9000011 *********
  1. APROB S BHSTAT="ASEO" G COMMON
  1. CPROB S BHSTAT="A" G COMMON
  1. SPROB S BHSTAT="S" G COMMON
  1. OPROB S BHSTAT="O" G COMMON
  1. EPROB S BHSTAT="E" G COMMON
  1. IPROB S BHSTAT="I" G COMMON
  1. PPROB S BHSTAT="I",BHSPER=1
  1. ; <SETUP>
  1. COMMON ;
  1. K BHSDFT S BHSNDF=0
  1. S BHSPER=$G(BHSPER)
  1. S BHSPAT=DFN
  1. S BHSFAC="" F BHSQ=0:0 S BHSFAC=$O(^AUPNPROB("AA",BHSPAT,BHSFAC)) Q:'BHSFAC D PROBSCH
  1. D CKP^GMTSUP G:$D(GMTSQIT) PROBX I 'GMTSNPG W ! D CKP^GMTSUP G:$D(GMTSQIT) PROBX
  1. ; <DISPLAY>
  1. D CKP^GMTSUP Q:$D(GMTSQIT)
  1. W ?13,"ENT. MODIFIED",!
  1. S BHSFPP="" F BHSQ=0:0 S BHSFPP=$O(BHSDFT(BHSFPP)) Q:BHSFPP=""!($D(GMTSQIT)) S BHSDFN=BHSDFT(BHSFPP) D PROBDSP
  1. PROBX K BHSDFT,BHSNDF,BHSFPP,BHSFAC,BHSPLN,BHSPBN,BHSDTM,BHSDTN,BHSPRB,BHSTAT,BHSNFP,BHSNRQ,BHSPNM,BHSDFN,BHSFCN,BHSICD,BHSDOO
  1. K BHSICL,BHSILN,BHSN,BHSNAR,BHSNTE,BHSAX,BHSCL,BHSTXT,BHSQ,BHSICF,BHSP
  1. K BHSNFL,BHSNSH,BHSNAB,BHSVSC,BHSITE,Y,BHSVD,BHSX,BHSPAT,BHSPER,I,X
  1. Q
  1. PROBSCH ;
  1. S BHSPRB="" F BHSQ=0:0 S BHSPRB=$O(^AUPNPROB("AA",BHSPAT,BHSFAC,BHSPRB)) Q:BHSPRB="" D
  1. .S BHSDFN=$O(^(BHSPRB,""))
  1. .I BHSDFN'="" S BHSNAR=$$GET1^DIQ(9000011,BHSDFN,.05)
  1. .I BHSTAT[$P(^AUPNPROB(BHSDFN,0),U,12) D
  1. ..Q:BHSPER=1&($P(^AUPNPROB(BHSDFN,0),U,4)'="P")
  1. ..S BHSNDF=BHSNDF+1,BHSDFT(BHSNAR)=BHSDFN
  1. Q
  1. PROBDSP ;
  1. ; <SETUP PROBLEM>
  1. S BHSNTE="",BHSDOO=""
  1. S BHSN=^AUPNPROB(BHSDFN,0)
  1. S BHSVD=$P(^AUPNPROB(BHSDFN,0),U,3)
  1. S BHSICD=$P(BHSN,U,1) D GETPLICD^BHSUTL
  1. S BHSNRQ=""
  1. S BHSNRQ=$$GET1^DIQ(9000011,BHSDFN_",",.05)
  1. S X=$$GET1^DIQ(9000011,BHSDFN_",",80001) I X]"" S BHSNRQ=BHSNRQ_" ("_X_")"
  1. S BHSITE=$P(BHSN,U,6) D GETSITE^BHSUTL
  1. S BHSPNM=$P(BHSN,U,7) ;***** EDE *****
  1. S BHSPNM=BHSNAB_BHSPNM ;***** EDE *****
  1. S X=$P(BHSN,U,3) D REGDT4^GMTSU S BHSDTM=X
  1. S X=$P(BHSN,U,8) D REGDT4^GMTSU S BHSDTN=X
  1. S BHSCL=$$VAL^XBDIQ1(9000011,BHSDFN,.15)
  1. I BHSCL]"" S BHSNTE=" "_$$CAT^AUPNVPLC($P(BHSN,U,1))_": "_BHSCL
  1. S X=$P(BHSN,U,13) I X]"" D REGDT4^GMTSU S BHSDOO=X
  1. S:BHSDOO]"" BHSNTE=BHSNTE_" (onset "_BHSDOO_")"
  1. S BHSNTE=BHSNTE_"(Status: "_$$VAL^XBDIQ1(9000011,BHSDFN,.12)_")"
  1. S BHSPLN=BHSPNM_$E(" ",1,10-$L(BHSPNM))_BHSDTN_" "_BHSDTM
  1. D CKP^GMTSUP Q:$D(GMTSQIT) W:GMTSNPG ?12,"ENT. MODIFIED",!
  1. W BHSPLN S BHSICL=33,BHSILN=50 D PRTICD^BHSUTL
  1. I $P(BHSN,U,16)!($P(BHSN,U,17))!($P(BHSN,U,18)) D ECODEDSP
  1. ;SEVERITY
  1. I $O(^AUPNPROB(BHSDFN,13,0)) D
  1. .W ?33,"Severity: "
  1. .S BHSAX=0 F S BHSAX=$O(^AUPNPROB(BHSDFN,13,BHSAX)) Q:BHSAX'=+BHSAX D
  1. ..S I=BHSAX_","_BHSDFN
  1. ..W ?42,$$GET1^DIQ(9000011.13,I,.01)_" - "_$$GET1^DIQ(9000011.13,I,.019),!
  1. ;FINDING SITE
  1. I $O(^AUPNPROB(BHSDFN,17,0)) D
  1. .W ?33,"Finding Site: "
  1. .S BHSAX=0 F S BHSAX=$O(^AUPNPROB(BHSDFN,17,BHSAX)) Q:BHSAX'=+BHSAX D
  1. ..S I=BHSAX_","_BHSDFN
  1. ..W ?42,$$GET1^DIQ(9000011.17,I,.01),!
  1. ;clinical course
  1. I $O(^AUPNPROB(BHSDFN,18,0)) D
  1. .W ?33,"Clinical Course: "
  1. .S BHSAX=0 F S BHSAX=$O(^AUPNPROB(BHSDFN,18,BHSAX)) Q:BHSAX'=+BHSAX D
  1. ..S I=BHSAX_","_BHSDFN
  1. ..W ?42,$$GET1^DIQ(9000011.18,I,.01)_" - "_$$GET1^DIQ(9000011.18,I,.019),!
  1. D NOTEDSP
  1. Q
  1. ECODEDSP ;
  1. D CKP^GMTSUP Q:$D(GMTSQIT)
  1. W ?33,"CAUSE: ",!
  1. F BHSP=16,17,18 D Q:$D(GMTSQIT)
  1. .D CKP^GMTSUP Q:$D(GMTSQIT)
  1. .W:GMTSNPG ?13,"ENT. MODIFIED",!
  1. .S BHSTXT=""
  1. .S BHSICD=$P(BHSN,U,BHSP)
  1. .Q:BHSICD=""
  1. .S BHSNRQ=$S(BHSICF="N":$P($$ICDDX^ICDEX($P(BHSN,U,BHSP),"","","I"),U,4),BHSICF="L":$P($$ICDDX^AUPNVUTL($P(BHSN,U,BHSP)),U,4),1:"")
  1. .;D GETICDDX^BHSUTL
  1. . D GETPLICD^BHSUTL
  1. .I BHSICF="C"!(BHSICF="") S BHSNRQ=BHSICD_"-"_$P($$ICDDX^ICDEX($P(BHSN,U,BHSP),"","","I"),U,4)
  1. .I BHSICF="L" S BHSNRQ=BHSICD
  1. .S BHSICL=33,BHSILN=50
  1. .D PRTICDE^BHSUTL
  1. .Q
  1. Q
  1. NOTEDSP ; DISPLAY NOTES UNDER APCHSPRBLEM
  1. S BHSNFP=0 F BHSQ=0:0 S BHSNFP=$O(^AUPNPROB(BHSDFN,11,BHSNFP)) Q:'BHSNFP D DSPFACN
  1. Q
  1. DSPFACN ; DISPLAY NOTES FOR SELECTED APSHCFACILITY
  1. Q:$D(^AUPNPROB(BHSDFN,11,BHSNFP,11,0))'=1 Q:$O(^(0))=""
  1. S BHSITE=^AUPNPROB(BHSDFN,11,BHSNFP,0) D GETSITE^BHSUTL S BHSFCN=BHSNAB
  1. S BHSNDF=0 F BHSQ=0:0 S BHSNDF=$O(^AUPNPROB(BHSDFN,11,BHSNFP,11,BHSNDF)) Q:'BHSNDF S BHSN=^(BHSNDF,0) D DSPN
  1. Q
  1. DSPN ; DISPLAY SINGLE NOTE
  1. N NTEDTE
  1. Q:$P(BHSN,U,4)="E"
  1. Q:$P(BHSN,U,4)="I"
  1. S BHSNAR=$P(BHSN,U,3) S X=$P(BHSN,U,5)
  1. I X>0 D REGDT4^GMTSU S NTEDTE=X
  1. F BHSQ=0:0 Q:$E(BHSFCN)'=" " S BHSFCN=$E(BHSFCN,2,99)
  1. D CKP^GMTSUP Q:$D(GMTSQIT) W "Note: "_BHSFCN_" "_$P(BHSN,U)_" on "_NTEDTE
  1. S BHSTXT=BHSNAR,BHSICL=34 D PRTTXT^BHSUTL
  1. Q