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

BHSPL.m

Go to the documentation of this file. 
  1. BHSPL ;IHS/MSC/MGH  - Health Summary for Problem list ;18-Sep-2013 09:44;DU
  1.  ;;1.0;HEALTH SUMMARY COMPONENTS;**1,2,6,8**;Mar 17,2006;Build 22
  1.  ;===================================================================
  1.  ; IHS/TUCSON/LAB - PART 4 OF APCHS -- SUMMARY PRODUCTION COMPONENTS ;  [ 06/24/97  2:42 PM ]
  1.  ;;2.0;IHS RPMS/PCC Health Summary;;JUN 24, 1997
  1.  ;Copied and changed to be used in VA health summary
  1.  ;Patch 8 updated for SNOMED problem list
  1.  ;
  1. PROB ; EP ******************** PROBLEM / NOTES * 9000011 *********
  1. APROB S BHSTAT="ASEO" G COMMON
  1. IPROB S BHSTAT="I"
  1.  ; <SETUP>
  1. COMMON ;
  1.  N BHSPAT,BHSX,BHSFPP,BHSFAC,BHSQ
  1.  S BHSPAT=DFN
  1.  ;Q:'$D(^AUPNPROB("AC",BHSPAT))
  1.  K BHSDFT S BHSNDF=0
  1.  S BHSFAC="" F BHSQ=0:0 S BHSFAC=$O(^AUPNPROB("AA",BHSPAT,BHSFAC)) Q:'BHSFAC  D PROBSCH
  1.  ;Q:BHSNDF=0
  1.  D CKP^GMTSUP G:$D(GMTSQIT) PROBX
  1.  ; <DISPLAY>
  1.  D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  I BHSNDF>0 W ?13,"ENT.    MODIFIED",!
  1.  S BHSFPP="" F BHSQ=0:0 S BHSFPP=$O(BHSDFT(BHSFPP)) Q:BHSFPP=""  S BHSDFN=BHSDFT(BHSFPP) D PROBDSP
  1. COMMON1 ;additional stuff for review IHS/MSC/MGH
  1.  ;get date last reviewed and display
  1.  S BHSX=$$LASTPLR^APCLAPI6(BHSPAT,,DT,"A")
  1.  D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  W !,"Problem List Reviewed On: ",?36,$$FMTE^XLFDT($P(BHSX,U,1)) W ?51,"By: ",?54,$E($S($P(BHSX,U,3):$P($G(^VA(200,$P(BHSX,U,3),0)),U),1:""),1,25),!
  1.  S BHSX=$$LASTPLU^APCLAPI6(BHSPAT,,DT,"A")
  1.  D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  W "Problem List Updated On: ",?36,$$FMTE^XLFDT($P(BHSX,U,1)) W ?51,"By: ",?54,$E($S($P(BHSX,U,3):$P($G(^VA(200,$P(BHSX,U,3),0)),U),1:""),1,25),!
  1.  I BHSTAT]"" D
  1.  .S BHSX=$$LASTNAP^APCLAPI6(BHSPAT,,DT,"A")
  1.  .D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  .W "No Active Problems Documented On: ",?36,$$FMTE^XLFDT($P(BHSX,U,1)) W ?51,"By: ",$E($S($P(BHSX,U,3):$P($G(^VA(200,$P(BHSX,U,3),0)),U),1:""),1,25),!
  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,BHSQ,BHSTXT,BHSSNO
  1.  K BHSNFL,BHSNSH,BHSNAB,BHSVSC,BHSITE,Y,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(^AUPNPROB("AA",BHSPAT,BHSFAC,BHSPRB,"")) Q:BHSDFN=""  D
  1.  ..S:BHSTAT[$P(^AUPNPROB(BHSDFN,0),U,12) BHSNDF=BHSNDF+1,BHSDFT(BHSFAC_BHSPRB)=BHSDFN
  1.  Q
  1. PROBDSP ;
  1.  ; <SETUP PROBLEM>
  1.  S BHSN=^AUPNPROB(BHSDFN,0)
  1.  S BHSSNO=$$GET1^DIQ(9000011,BHSDFN,80001)
  1.  S BHSICD=$P(BHSN,U,1) D GETPLICD^BHSUTL
  1.  S BHSNRQ=$P(BHSN,U,5) D GETNARR^BHSUTL
  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 X=$P(BHSN,U,13)
  1.  I X]"" D REGDT4^GMTSU S BHSDOO=X
  1.  I X="" S BHSDOO=""
  1.  S:BHSDOO]"" BHSNTE=" (onset "_BHSDOO_")"
  1.  S BHSPLN=BHSPNM_$E("         ",1,12-$L(BHSPNM))_BHSDTN_" "_BHSDTM_" "
  1.  D CKP^GMTSUP Q:$D(GMTSQIT)  W:GMTSNPG ?13,"ENT.    MODIFIED",!
  1.  I BHSSNO'="" S BHSNRQ=BHSNRQ_" ("_BHSSNO_")"
  1.  W BHSPLN S BHSICL=30,BHSILN=50 D PRTICD^BHSUTL
  1.  D NOTEDSP
  1.  D QUAL(BHSDFN)
  1.  D RECON(BHSDFN)
  1.  Q
  1. NOTEDSP ; DISPLAY NOTES UNDER BHSPRBLEM
  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.  Q:$P(BHSN,U,4)="I"
  1.  S BHSNAR=$P(BHSN,U,3) S X=$P(BHSN,U,5) ;S:Y="" Y="            "
  1.  I X>0 D REGDT4^GMTSU S X=X_" -  "
  1.  S BHSNAR=BHSNAR_" "_X
  1.  ;W ?22,BHSFCN,"#",$E(1000+$P(BHSN,U,1),2,4)_" ",$P(BHSN,U,3),!
  1.  F BHSQ=0:0 Q:$E(BHSFCN)'=" "  S BHSFCN=$E(BHSFCN,2,99)
  1.  D CKP^GMTSUP Q:$D(GMTSQIT)  W ?10,BHSFCN_" Note "_$P(BHSN,U)
  1.  S BHSTXT=BHSNAR,BHSICL=31 D PRTTXT^BHSUTL
  1.  Q
  1. PLDETAIL ;DISPLAY PROBLEM DETAILS IN HELATH SUMMARY
  1.  N PROB,CNT,RET,PRIEN,I,STAT,LINE,Y,TYPE
  1.  S TYPE="ASEO"
  1.  I $G(NUM)="" S NUM=99999
  1.  S RET=""
  1.  S (CNT,PRIEN)=0
  1.  D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  F  S PRIEN=$O(^AUPNPROB("AC",DFN,PRIEN)) Q:'PRIEN  D
  1.  .;Check for which statuses to return
  1.  .S STAT=$P($G(^AUPNPROB(PRIEN,0)),U,12)
  1.  .Q:STAT="D"
  1.  .Q:TYPE'[STAT
  1.  .D DETAIL^BGOPRDD(.RET,PRIEN,DFN,"A",NUM)             ;Get a detail report on one problem
  1.  .S LINE=0
  1.  .F  S LINE=$O(@RET@(LINE)) Q:LINE=""  D
  1.  ..D CKP^GMTSUP Q:$D(GMTSQIT)  I GMTSNPG W !,"Active Problem List",!
  1.  ..W @RET@(LINE),!
  1.  K RET
  1.  Q
  1. INPROB ;DISPLAY PROBLEM DETAILS OF INACTIVE PROBLEMS
  1.  N PROB,CNT,RET,PRIEN,I,STAT,LINE,Y
  1.  S TYPE="I"
  1.  ;For Visit instructions and treatments, the default is the latest visit
  1.  I $G(NUM)="" S NUM=99999
  1.  S RET=$$TMPGBL
  1.  S (CNT,PRIEN)=0
  1.  D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  F  S PRIEN=$O(^AUPNPROB("AC",DFN,PRIEN)) Q:'PRIEN  D
  1.  .;Check for which statuses to return
  1.  .S STAT=$P($G(^AUPNPROB(PRIEN,0)),U,12)
  1.  .Q:STAT="D"
  1.  .Q:TYPE'[STAT
  1.  .D DETAIL^BGOPRDD(.RET,PRIEN,DFN,"C",NUM)             ;Get a detail report on one problem
  1.  .S LINE=0
  1.  .F  S LINE=$O(@RET@(LINE)) Q:LINE=""  D
  1.  ..D CKP^GMTSUP Q:$D(GMTSQIT)  I GMTSNPG W !,"Inactive Problem List",!
  1.  ..W @RET@(LINE),!
  1.  K RET
  1.  Q
  1. RECON(PROB) ;Find when this problem was reconciled
  1.  N REC,IEN,AIEN,WHEN,BY
  1.  S REC=""
  1.  F  S REC=$O(^BEHOCIR("G","P",PROB,REC)) Q:REC=""  D
  1.  .S IEN="" F  S IEN=$O(^BEHOCIR("G","P",PROB,REC,IEN)) Q:IEN=""  D
  1.  ..S AIEN=IEN_","_REC_","
  1.  ..S WHEN=$$GET1^DIQ(90461.632,AIEN,.01)
  1.  ..S BY=$$GET1^DIQ(90461.632,AIEN,.02)
  1.  ..W ?10,"Reconciled on: "_WHEN_" by "_BY,!
  1.  Q
  1. QUAL(IEN) ;Get any qualifiers for this problem
  1.  N AIEN,IEN2,BY,WHEN,X,FNUM,Q,STRING,STRING2,STRING3
  1.  I $D(^AUPNPROB(IEN,13))!($D(^AUPNPROB(IEN,17)))!($D(^AUPNPROB(IEN,18)))
  1.  S (STRING,STRING2,STRING3)=""
  1.  F X=13,17,18 D
  1.  .S FNUM=$S(X=13:9000011.13,X=17:9000011.17,X=18:9000011.18)
  1.  .S IEN2=0 F  S IEN2=$O(^AUPNPROB(IEN,X,IEN2)) Q:'+IEN2  D
  1.  ..S AIEN=IEN2_","_IEN_","
  1.  ..S Q=$$GET1^DIQ(FNUM,AIEN,.01)
  1.  ..S Q=$$CONCEPT^BGOPAUD(Q)
  1.  ..I X=13 D
  1.  ...I STRING="" S STRING=Q
  1.  ...E  S STRING=STRING_" "_Q
  1.  ..I X=17 D
  1.  ...I STRING2="" S STRING2=Q
  1.  ...E  S STRING2=STRING2_" "_Q
  1.  ..I X=18 D
  1.  ...I STRING="" S STRING=Q
  1.  ...E  S STRING=STRING_" "_Q
  1.  I STRING'=""!(STRING2'="")!(STRING3'="") W !,?10,"QUALIFIERS",!
  1.  I STRING'="" W ?10,STRING,!
  1.  I STRING2'="" W ?10,STRING2,!
  1.  I STRING3'="" W ?10,STRING3,!
  1. TMPGBL() ;EP
  1.  K ^TMP("BHSPL",$J) Q $NA(^($J))