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

APCHS40.m

Go to the documentation of this file. 
  1. APCHS40 ; IHS/CMI/LAB -- SUMMARY PRODUCTION COMPONENTS ;
  1.  ;;2.0;IHS PCC SUITE;**5,6,7,11,16**;MAY 14, 2009;Build 9
  1.  ;
  1.  ;cmi/anch/maw 8/27/2007 code set versioning in PROBASCH
  1.  ;
  1. PROBA ; ************ ALLERGY PROB * 9000011 *********
  1.  ; for PROBLEM LIST codes only!
  1.  I '$D(^AUPNPROB("AC",APCHSPAT)) X APCHSCKP G:$D(APCHSQIT) PROBAX I 'APCHSNPG W ! X APCHSCKP Q:$D(APCHSQIT)  X:'APCHSNPG APCHSBRK W ! D PROBADNR,ALR Q
  1.  K APCHSPT S (APCHSFND,APCHSLEN)=0
  1.  S APCHSDFN="" F APCHSQ=0:0 S APCHSDFN=$O(^AUPNPROB("AC",APCHSPAT,APCHSDFN)) Q:'APCHSDFN  I $D(^AUPNPROB(APCHSDFN,0)),$P(^AUPNPROB(APCHSDFN,0),U,12)'="D" D PROBASCH
  1.  X APCHSCKP G:$D(APCHSQIT) PROBAX I 'APCHSNPG W ! X APCHSCKP Q:$D(APCHSQIT)  X:'APCHSNPG APCHSBRK
  1.  W !
  1.  I 'APCHSFND D PROBADNR,ALR G PROBAX
  1.  S APCHSDFN="" F APCHSQ=0:0 S APCHSDFN=$O(APCHSPT(APCHSDFN)) Q:'APCHSDFN  D PROBADSP
  1. ALR ;
  1.  ;get date last reviewed and display
  1.  S APCHSX=$$LASTALR^APCLAPI6(APCHSPAT,,DT,"A")
  1.  X APCHSCKP Q:$D(APCHSQIT)
  1.  W !,"Allergy 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=$$LASTALU^APCLAPI6(APCHSPAT,,DT,"A")
  1.  X APCHSCKP Q:$D(APCHSQIT)
  1.  W "Allergy 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.  S APCHSX=$$LASTNAA^APCLAPI6(APCHSPAT,,DT,"A")
  1.  X APCHSCKP Q:$D(APCHSQIT)
  1.  ;I '$$ANYACTA^APCDAALG(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 Allergies documented On: ",?36,$$FMTE^XLFDT($P(APCHSX,U,1)) W ?51,"By: ",?56,$E($S($P(APCHSX,U,3):$P($G(^VA(200,$P(APCHSX,U,3),0)),U),1:""),1,22),!
  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.  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. PROBAX ;
  1.  K APCHSPT,APCHSFND,APCHSDFN,APCHSLEN,APCHSDAT,APCHSNKA
  1.  Q
  1.  ;
  1. PROBASCH ;active problem search
  1.  ;S APCHSP=$P(^ICD9(+^AUPNPROB(APCHSDFN,0),0),U,1) D PROBACHK I  D PROBALLG  cmi/anch/maw 8/27/2007 orig line
  1.  S APCHSP=$P($$ICDDX^ICDEX(+^AUPNPROB(APCHSDFN,0),0),U,2) D PROBACHK I  D PROBALLG  ;cmi/anch/maw 8/27/2007 code set versioning
  1.  Q
  1. PROBACHK ;checking for allergy codes
  1.  S APCHSNKA=0
  1.  Q:$P(^AUPNPROB(APCHSDFN,0),U,5)=""  ;IHS/CMI/LAB - no narr
  1.  S APCHSNKA=0
  1.  I $$ICD^ATXAPI(+^AUPNPROB(APCHSDFN,0),$O(^ATXAX("B","APCH ALLERGY DX CODES",0)),9) Q
  1.  ;I APCHSP="692.3" Q
  1.  ;I APCHSP="693.0" Q
  1.  ;I APCHSP="995.0" Q
  1.  ;I APCHSP="995.2" Q
  1.  ;I (+APCHSP'<999.4),(+APCHSP'>999.89) Q
  1.  ;I APCHSP?1"V14."1E Q
  1.  ;I APCHSP="692.5" Q
  1.  ;I APCHSP="693.1" Q
  1.  ;I APCHSP="V15.0" Q
  1.  ;I APCHSP["V15.0" Q
  1.  ;I $E(APCHSP,1,3)=692,APCHSP'="692.9" Q
  1.  ;I APCHSP="693.8" Q
  1.  ;I APCHSP="693.9" Q
  1.  ;I APCHSP="989.5" Q
  1.  ;I APCHSP="989.82" Q
  1.  ;I APCHSP="995.3" Q
  1.  ;I APCHSP["995.2" Q
  1.  ;S N=$P(^AUTNPOV($P(^AUPNPROB(APCHSDFN,0),U,5),0),U) I APCHSP="799.9"!(APCHSP="V82.9"),N["NO KNOWN ALLERG"!(N["NKA")!(N["NKDA")!(N["NO KNOWN DRUG ALLERG") S APCHSNKA=1 Q
  1.  S N=$$VAL^XBDIQ1(9000011,APCHSDFN,.05) I N["NO KNOWN ALLERG"!(N["NKA")!(N["NKDA")!(N["NO KNOWN DRUG ALLERG") S APCHSNKA=1 Q
  1.  ;I APCHSP="799.9",$P(^AUTNPOV($P(^AUPNPROB(APCHSDFN,0),U,5),0),U,1)["NO KNOWN ALLERG"!($P(^AUTNPOV($P(^AUPNPROB(APCHSDFN,0),U,5),0),U,1)["NKA")!($P(^AUTNPOV($P(^AUPNPROB(APCHSDFN,0),U,5),0),U)["NKDA") S APCHSNKA=1 Q
  1.  Q
  1.  ;
  1. PROBADSP ;display allergies
  1.  S:$L(APCHSPT(APCHSDFN))<APCHSLEN APCHSL1=$L(APCHSPT(APCHSDFN))/2,APCHSL1=(APCHSLEN/2)-APCHSL1 ;                       center recorded allergies
  1.  W ?((IOM-APCHSLEN-12)/2),"***** "
  1.  W ?((IOM-APCHSLEN)/2)+$G(APCHSL1),APCHSPT(APCHSDFN)
  1.  W ?((IOM+APCHSLEN)/2)," *****",!
  1.  K APCHSL1
  1.  Q
  1.  ;
  1. PROBADNR ;display "NONE RECORDED", if no allergies recorded
  1.  W ?((IOM-13-12)/2),"***** ",?((IOM-13)/2),"NONE RECORDED",?((IOM+13)/2)," *****",!
  1.  Q
  1.  ;
  1. PROBALLG ;if allergy
  1.  S APCHSFND=1
  1.  I APCHSNKA D  I 1
  1.  . S Y=$P(^AUPNPROB(APCHSDFN,0),U,8) X APCHSCVD S APCHSDAT=Y
  1.  . S APCHSPT(APCHSDFN)="NO ALLERGY NOTED ON "_APCHSDAT_" ("_$$VAL^XBDIQ1(9000011,APCHSDFN,.05)_")"
  1.  . S:$L($P(APCHSPT(APCHSDFN),U))>APCHSLEN APCHSLEN=$L($P(APCHSPT(APCHSDFN),U))
  1.  . Q
  1.  E  D
  1.  . ;Q:$P(^AUPNPROB(APCHSDFN,0),U,5)=""  ;IHS/CMI/LAB - added this to prevent subscript
  1.  . S APCHSPT(APCHSDFN)=$$VAL^XBDIQ1(9000011,APCHSDFN,.05) ;$P($G(^AUTNPOV(+$P(^AUPNPROB(APCHSDFN,0),U,5),0)),U,1)
  1.  . I APCHSPT(APCHSDFN)="" S APCHSPT(APCHSDFN)="???"
  1.  . S:$L(APCHSPT(APCHSDFN))>APCHSLEN APCHSLEN=$L(APCHSPT(APCHSDFN))
  1.  . Q
  1.  Q
  1.  ;