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

APCHPALG.m

Go to the documentation of this file. 
  1. APCHPALG ; IHS/CMI/LAB - Patient Health Summary - Allergies ;
  1.  ;;2.0;IHS PCC SUITE;**5,7,8,11**;MAY 14, 2009;Build 58
  1.  ;;
  1.  ;
  1.  ;cmi/anch/maw 8/28/2007 code set versioning on PROBASCH
  1.  ;
  1. EN ;EP - START HERE 
  1.   ;
  1.  Q:'APCHSDFN
  1.  S APCHALG="" F  S APCHALG=$O(^GMR(120.8,"B",APCHSDFN,APCHALG)) Q:(APCHALG="")!($D(APCHSQIT))  D
  1.  .S APCHVER=0 ;ALWAYS START THIS WAY 5/25/2001
  1.  .Q:$$TEST(APCHALG)
  1.  .Q:$$INACTIVE^APCHS79(APCHALG)  ;no inactive allergies
  1.  .S APCHPEC=$G(^GMR(120.8,APCHALG,0))
  1.  .Q:'APCHPEC
  1.  .Q:$P(APCHPEC,U,22)]""  ;DONT WANT IN EITHER CASE-N SHOULD ALREADY BE TAKEN CARE OF IN XREF AND NOT GET HERE AND IF Y NEED TO LOOK ELSEWHERE IHS/OKCAO/POC 5/25/2001
  1.  .;Q:$P(APCHPEC,U,2)=""  ;NO REACTANT??
  1.  .S APCHMEC=$P(APCHPEC,U,14) S:APCHMEC="" APCHMEC="A" S:APCHMEC="U" APCHMEC="A" ;IHS/OKCAO/POC 5/25/2001
  1.  .S:$P(APCHPEC,U,16)=1 APCHVER=1 ;IHS/OKCAO/POC 5/25/2001
  1.  .S APCHDRUG=$P(APCHPEC,U,2)
  1.  .S:APCHDRUG']"" APCHDRUG="**NO DRUG ENTERED**" ;IHS/OKCAO/POC 5/2/2001
  1.  .S APCHDATE=$P($P(APCHPEC,U,4),".",1) Q:APCHDATE=""
  1.  .K APCHDATA
  1.  .S APCHREC="0" F  S APCHREC=$O(^GMR(120.8,APCHALG,10,APCHREC)) Q:APCHREC'=+APCHREC  D
  1.  ..S APCHRNUM=+^GMR(120.8,APCHALG,10,APCHREC,0)
  1.  ..S APCHDATA(APCHRNUM)=$P(^GMRD(120.83,APCHRNUM,0),U,1)
  1.  ..S:APCHDATA(APCHRNUM)="OTHER REACTION" APCHDATA(APCHRNUM)=$P(^GMR(120.8,APCHALG,10,APCHREC,0),U,2)
  1.  .S APCHNN=0
  1.  .S (APCHCNT,APCHDATA)="" F  S APCHCNT=$O(APCHDATA(APCHCNT)) Q:APCHCNT=""  D
  1.  ..S APCHNN=APCHNN+1
  1.  ..S:APCHNN>1 APCHDATA=APCHDATA_", "
  1.  ..S APCHDATA=APCHDATA_APCHDATA(APCHCNT)
  1.  .S APCHENT(APCHMEC,APCHDATE,APCHALG)=APCHDRUG  ;_$S(APCHVER=0:" (u) - ",1:" (v) - ")_APCHDATA ;IHS/OKCOA/POC 5/25/2001
  1.  Q
  1.  ;
  1. TEST(CHECKIT) ;CHECK IF VERIFED AND NOT ENTERED IN ERROR
  1.  N CHECK
  1.  S CHECK=0 ;CHECK=1 ENTERED IN ERROR OR NOT VERIFED
  1.  ;S:$D(^GMR(120.8,CHECKIT,"ER")) CHECK=1
  1.  S:$P($G(^GMR(120.8,CHECKIT,"ER")),U)=1 CHECK=1  ;CMI/GRL *17*
  1.  Q CHECK
  1.  ;
  1.  ;
  1.  ;PROBLEMS FROM PROBLEM LIST
  1. PROBA ;EP - CALLED TO CHECK PROBLEM LIST
  1.  ; for PROBLEM LIST codes only!
  1.  I '$D(^AUPNPROB("AC",APCHSDFN)) Q
  1.  K APCHSPT S (APCHSFND,APCHSLEN)=0
  1.  S APCHPIEN="" F APCHSQ=0:0 S APCHPIEN=$O(^AUPNPROB("AC",APCHSDFN,APCHPIEN)) Q:'APCHPIEN  I $P(^AUPNPROB(APCHPIEN,0),U,12)'="D" D PROBASCH
  1.  ;
  1.  K APCHSLEN,APCHSP,APCHPIEN,APCHSQ
  1.  ;
  1.  Q
  1.  ;
  1. PROBASCH ;active problem search
  1.  ;S APCHSP=$P(^ICD9(+^AUPNPROB(APCHPIEN,0),0),U,1) D PROBACHK I  D PROBALLG  cmi/anch/maw 8/27/2007 orig line
  1.  S APCHSP=$P($$ICDDX^ICDEX(+^AUPNPROB(APCHPIEN,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.  Q:$P(^AUPNPROB(APCHPIEN,0),U,5)=""  ;IHS/CMI/LAB - no narr
  1.  S APCHSNKA=0
  1.  I $$ICD^ATXAPI(+^AUPNPROB(APCHPIEN,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.  Q
  1.  ;
  1. PROBALLG ;if allergy
  1.  S APCHSALG=1
  1.  S APCHSPT(APCHPIEN)=$$VAL^XBDIQ1(9000011,APCHPIEN,.05) ;$P($G(^AUTNPOV(+$P(^AUPNPROB(APCHPIEN,0),U,5),0)),U,1)
  1.  I APCHSPT(APCHPIEN)="" S APCHSPT(APCHPIEN)="???"
  1.  S:$L(APCHSPT(APCHPIEN))>APCHSLEN APCHSLEN=$L(APCHSPT(APCHPIEN))
  1.  Q