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

APCHS4.m

Go to the documentation of this file.
  1. APCHS4 ; IHS/CMI/LAB - PART 4 OF APCHS -- SUMMARY PRODUCTION COMPONENTS ;
  1. ;;2.0;IHS PCC SUITE;**5,10,11,16**;MAY 14, 2009;Build 9
  1. ;
  1. PROBST ;EP - problems by status
  1. NEW APCHPBST,APCHST
  1. S APCHSTAT="AEOSR"
  1. S APCHSNDF=0
  1. S APCHSFAC="" F APCHSQ=0:0 S APCHSFAC=$O(^AUPNPROB("AA",APCHSPAT,APCHSFAC)) Q:'APCHSFAC D
  1. .S APCHSPRB="" F APCHSQ=0:0 S APCHSPRB=$O(^AUPNPROB("AA",APCHSPAT,APCHSFAC,APCHSPRB)) Q:APCHSPRB="" D
  1. ..S APCHSDFN=$O(^AUPNPROB("AA",APCHSPAT,APCHSFAC,APCHSPRB,""))
  1. ..S APCHST=$P(^AUPNPROB(APCHSDFN,0),U,12)
  1. ..Q:APCHST=""
  1. ..Q:"AEOSR"'[APCHST
  1. ..S APCHSNDF=APCHSNDF+1,APCHSDFT(APCHST,APCHSFAC_APCHSPRB)=APCHSDFN
  1. X APCHSCKP G:$D(APCHSQIT) PROBX I 'APCHSNPG W ! X APCHSCKP G:$D(APCHSQIT) PROBX X:'APCHSNPG APCHSBRK
  1. I APCHSNDF=0 G COMMON1
  1. F APCHST="A","S","E","O","R" D
  1. .S APCHSFPP="" F APCHSQ=0:0 S APCHSFPP=$O(APCHSDFT(APCHST,APCHSFPP)) Q:APCHSFPP="" S APCHSDFN=APCHSDFT(APCHST,APCHSFPP) D PROBDSP
  1. G COMMON1
  1. PROB ; ******************** PROBLEM / NOTES * 9000011 *********
  1. APROB S APCHSTAT="AS" S:$P(^APCHSCTL(APCHSTYP,0),U,4) APCHSTAT=APCHSTAT_"O" G COMMON
  1. CPROB S APCHSTAT="A" G COMMON
  1. SPROB S APCHSTAT="S" G COMMON
  1. OPROB S APCHSTAT="O" G COMMON
  1. EPROB S APCHSTAT="E" G COMMON
  1. RPROB S APCHSTAT="R" G COMMON
  1. IPROB S APCHSTAT="I"
  1. ; <SETUP>
  1. COMMON ;
  1. K APCHSDFT S APCHSNDF=0
  1. S APCHSFAC="" F APCHSQ=0:0 S APCHSFAC=$O(^AUPNPROB("AA",APCHSPAT,APCHSFAC)) Q:'APCHSFAC D PROBSCH
  1. X APCHSCKP G:$D(APCHSQIT) PROBX I 'APCHSNPG W ! X APCHSCKP G:$D(APCHSQIT) PROBX X:'APCHSNPG APCHSBRK
  1. I APCHSNDF=0 G COMMON1
  1. ; <DISPLAY>
  1. X APCHSCKP Q:$D(APCHSQIT) W ?13,"ENT. MODIFIED",!
  1. S APCHSFPP="" F APCHSQ=0:0 S APCHSFPP=$O(APCHSDFT(APCHSFPP)) Q:APCHSFPP=""!($D(APCHSQIT)) S APCHSDFN=APCHSDFT(APCHSFPP) D PROBDSP
  1. COMMON1 ;additional stuff for CHHIT bjpc 2.0 patch 5
  1. ;get date last reviewed and display
  1. S APCHSX=$$LASTPLR^APCLAPI6(APCHSPAT,,DT,"A")
  1. X APCHSCKP Q:$D(APCHSQIT)
  1. W !,"Problem List Reviewed On: ",?36,$$FMTE^XLFDT($P(APCHSX,U,1)) W ?51,"By: ",?54,$E($S($P(APCHSX,U,3):$P($G(^VA(200,$P(APCHSX,U,3),0)),U),1:""),1,25),!
  1. S APCHSX=$$LASTPLU^APCLAPI6(APCHSPAT,,DT,"A")
  1. X APCHSCKP Q:$D(APCHSQIT)
  1. W "Problem List Updated On: ",?36,$$FMTE^XLFDT($P(APCHSX,U,1)) W ?51,"By: ",?54,$E($S($P(APCHSX,U,3):$P($G(^VA(200,$P(APCHSX,U,3),0)),U),1:""),1,25),!
  1. I APCHSTAT]"" D
  1. .S APCHSX=$$LASTNAP^APCLAPI6(APCHSPAT,,DT,"A")
  1. .X APCHSCKP Q:$D(APCHSQIT)
  1. .;I '$$ANYACTP^APCDAPRB(APCHSPAT) W !,"No Active Problems: ",?24,$$FMTE^XLFDT($P(APCHSX,U,1)) I $P(APCHSX,U,3) W ?39,"Documented By: ",?54,$E($P($G(^VA(200,$P(APCHSX,U,3),0)),U),1,25),!
  1. .W "No Active Problems Documented On: ",?36,$$FMTE^XLFDT($P(APCHSX,U,1)) W ?51,"By: ",$E($S($P(APCHSX,U,3):$P($G(^VA(200,$P(APCHSX,U,3),0)),U),1:""),1,25),!
  1. PROBX K APCHSDFT,APCHSNDF,APCHSFPP,APCHSFAC,APCHSPLN,APCHSPBN,APCHSDTM,APCHSDTN,APCHSPRB,APCHSTAT,APCHSNFP,APCHSNRQ,APCHSPNM,APCHSDFN,APCHSFCN,APCHSICD,APCHSDOO
  1. K APCHSICL,APCHSILN,APCHSN,APCHSNAR,APCHSNTE
  1. K APCHSNFL,APCHSNSH,APCHSNAB,APCHSVSC,APCHSITE,Y,APCHCSVD,APCHSX
  1. Q
  1. PROBSCH ;
  1. S APCHSPRB="" F APCHSQ=0:0 S APCHSPRB=$O(^AUPNPROB("AA",APCHSPAT,APCHSFAC,APCHSPRB)) Q:APCHSPRB="" S APCHSDFN=$O(^(APCHSPRB,"")) S:APCHSTAT[$P(^AUPNPROB(APCHSDFN,0),U,12) APCHSNDF=APCHSNDF+1,APCHSDFT(APCHSFAC_APCHSPRB)=APCHSDFN
  1. Q
  1. PROBDSP ;
  1. ; <SETUP PROBLEM>
  1. S APCHSNTE=""
  1. S APCHSN=^AUPNPROB(APCHSDFN,0)
  1. S APCHCSVD=$P(^AUPNPROB(APCHSDFN,0),U,3)
  1. S APCHSICD=$P(APCHSN,U,1) D GETICDDX^APCHSUTL
  1. S APCHSNRQ="" I $$WANTPN^APCHSUTL(APCHSTYP) D
  1. .S APCHSNRQ=$$GET1^DIQ(9000011,APCHSDFN_",",.05)
  1. .I $P(^APCHSCTL(APCHSTYP,0),U,3) S X=$$GET1^DIQ(9000011,APCHSDFN_",",80001) I X]"" S APCHSNRQ=APCHSNRQ_" ("_X_")"
  1. S APCHSITE=$P(APCHSN,U,6) D GETSITE^APCHSUTL
  1. S APCHSPNM=$P(APCHSN,U,7) ;***** EDE *****
  1. S APCHSPNM=APCHSNAB_APCHSPNM ;***** EDE *****
  1. S Y=$P(APCHSN,U,3) X APCHSCVD S APCHSDTM=Y
  1. S Y=$P(APCHSN,U,8) X APCHSCVD S APCHSDTN=Y
  1. S APCHSCL=$$VAL^XBDIQ1(9000011,APCHSDFN,.15)
  1. I APCHSCL]"" S APCHSNTE=" "_$$CAT^AUPNVPLC($P(APCHSN,U,1))_": "_APCHSCL
  1. S Y=$P(APCHSN,U,13) X:Y]"" APCHSCVD S APCHSDOO=Y
  1. S:APCHSDOO]"" APCHSNTE=APCHSNTE_" (onset "_APCHSDOO_")"
  1. S APCHSNTE=APCHSNTE_"(Status: "_$$VAL^XBDIQ1(9000011,APCHSDFN,.12)_")"
  1. S APCHSPLN=APCHSPNM_$E(" ",1,12-$L(APCHSPNM))_APCHSDTN_" "_APCHSDTM
  1. X APCHSCKP Q:$D(APCHSQIT) W:APCHSNPG ?12,"ENT. MODIFIED",!
  1. W APCHSPLN S APCHSICL=31,APCHSILN=50 D PRTICD^APCHSUTL
  1. I $P(APCHSN,U,16)!($P(APCHSN,U,17))!($P(APCHSN,U,18)) D ECODEDSP
  1. ;SEVERITY
  1. I $O(^AUPNPROB(APCHSDFN,13,0)) D
  1. .W ?30,"Severity: "
  1. .S APCHSAX=0 F S APCHSAX=$O(^AUPNPROB(APCHSDFN,13,APCHSAX)) Q:APCHSAX'=+APCHSAX D
  1. ..S I=APCHSAX_","_APCHSDFN
  1. ..W ?42,$$GET1^DIQ(9000011.13,I,.01)_" - "_$$GET1^DIQ(9000011.13,I,.019),!
  1. ;FINDING SITE
  1. I $O(^AUPNPROB(APCHSDFN,17,0)) D
  1. .W ?30,"Finding Site: "
  1. .S APCHSAX=0 F S APCHSAX=$O(^AUPNPROB(APCHSDFN,17,APCHSAX)) Q:APCHSAX'=+APCHSAX D
  1. ..S I=APCHSAX_","_APCHSDFN
  1. ..W ?42,$$GET1^DIQ(9000011.17,I,.01),!
  1. ;clinical course
  1. I $O(^AUPNPROB(APCHSDFN,18,0)) D
  1. .W ?30,"Clinical Course: "
  1. .S APCHSAX=0 F S APCHSAX=$O(^AUPNPROB(APCHSDFN,18,APCHSAX)) Q:APCHSAX'=+APCHSAX D
  1. ..S I=APCHSAX_","_APCHSDFN
  1. ..W ?42,$$GET1^DIQ(9000011.18,I,.01)_" - "_$$GET1^DIQ(9000011.18,I,.019),!
  1. D NOTEDSP
  1. Q
  1. ECODEDSP ;
  1. X APCHSCKP Q:$D(APCHSQIT) W ?30,"CAUSE: ",!
  1. F APCHSP=16,17,18 D Q:$D(APCHSQIT)
  1. .X APCHSCKP Q:$D(APCHSQIT) W:APCHSNPG ?13,"ENT. MODIFIED",!
  1. .S APCHSTXT=""
  1. .S APCHSICD=$P(APCHSN,U,APCHSP)
  1. .Q:APCHSICD=""
  1. .S APCHSNRQ=$S(APCHSICF="N":$P($$ICDDX^ICDEX($P(APCHSN,U,APCHSP)),U,4),APCHSICF="L":$P($$ICDDX^ICDEX($P(APCHSN,U,APCHSP)),U,4),1:"")
  1. .D GETICDDX^APCHSUTL
  1. .I APCHSICF="C"!(APCHSICF="") S APCHSNRQ=APCHSICD_"-"_$P($$ICDDX^ICDEX($P(APCHSN,U,APCHSP)),U,4)
  1. .I APCHSICF="L" S APCHSNRQ=APCHSICD
  1. .S APCHSICL=31,APCHSILN=50
  1. .D PRTICDE^APCHSUTL
  1. .Q
  1. Q
  1. NOTEDSP ; DISPLAY NOTES UNDER APCHSPRBLEM
  1. S APCHSNFP=0 F APCHSQ=0:0 S APCHSNFP=$O(^AUPNPROB(APCHSDFN,11,APCHSNFP)) Q:'APCHSNFP D DSPFACN
  1. Q
  1. DSPFACN ; DISPLAY NOTES FOR SELECTED APSHCFACILITY
  1. Q:$D(^AUPNPROB(APCHSDFN,11,APCHSNFP,11,0))'=1 Q:$O(^(0))=""
  1. S APCHSITE=^AUPNPROB(APCHSDFN,11,APCHSNFP,0) D GETSITE^APCHSUTL S APCHSFCN=APCHSNAB
  1. S APCHSNDF=0 F APCHSQ=0:0 S APCHSNDF=$O(^AUPNPROB(APCHSDFN,11,APCHSNFP,11,APCHSNDF)) Q:'APCHSNDF S APCHSN=^(APCHSNDF,0) D DSPN
  1. Q
  1. DSPN ; DISPLAY SINGLE NOTE
  1. Q:$P(APCHSN,U,4)'="A"
  1. S APCHSNAR=$P(APCHSN,U,3) S Y=$P(APCHSN,U,5) ;S:Y="" Y=" "
  1. I Y>0 X APCHSCVD S Y=Y_" - "
  1. S APCHSNAR=Y_APCHSNAR
  1. F APCHSQ=0:0 Q:$E(APCHSFCN)'=" " S APCHSFCN=$E(APCHSFCN,2,99)
  1. X APCHSCKP Q:$D(APCHSQIT) W APCHSPNM,APCHSFCN,$P(APCHSN,U)
  1. S APCHSTXT=APCHSNAR,APCHSICL=31 D PRTTXT^APCHSUTL
  1. Q