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

APCHS79.m

Go to the documentation of this file.
  1. APCHS79 ; IHS/CMI/LAB - HEALTH SUMMARY COMPONENT FOR ALLERGY FILE (PATIENT ALLERGY) ;
  1. ;;2.0;IHS PCC SUITE;**5,6**;MAY 14, 2009;Build 11
  1. ;;
  1. EN ;START HERE
  1. S APCHDFN=APCHSPAT
  1. K APCHNKAI
  1. Q:'APCHDFN
  1. ;Q:'$D(^GMR(120.8,"B",APCHDFN))
  1. X APCHSCKP G:$D(APCHSQIT) END I 'APCHSNPG W ! X APCHSCKP Q:$D(APCHSQIT) X:'APCHSNPG APCHSBRK
  1. I '$D(^GMR(120.8,"B",APCHDFN)) D K APCHDFN G REV
  1. .I $D(^GMR(120.86,APCHDFN,0)),$P(^GMR(120.86,APCHDFN,0),U,2)=0 D Q
  1. ..W !,$$CJ^XLFSTR("NO KNOWN ALLERGIES/ADVERSE DRUG REACTIONS noted on "_$$FMTE^XLFDT($P($P(^GMR(120.86,APCHDFN,0),U,4),".",1)),80),! Q
  1. .W !,$$CJ^XLFSTR("NO ALLERGY INFORMATION RECORDED",IOM),! ;IHS/OKCAO/POC 4/27/2001
  1. I $O(^GMR(120.8,"ANKA",APCHDFN,""))="n" D
  1. .S APCHNKAI=$O(^GMR(120.8,"ANKA",APCHDFN,"n",""))
  1. .I APCHNKAI S APCHNKAD=$P(^GMR(120.8,APCHNKAI,0),U,4)
  1. .;W !,$$CJ^XLFSTR("NO ALLERGIES/ADVERSE DRUG REACTIONS "_$S(APCHNKAD:"noted on "_$$FMTE^XLFDT($P(APCHNKAD,".",1)),1:""),80),!
  1. .W !,$$CJ^XLFSTR("NO KNOWN ALLERGIES/ADVERSE DRUG REACTIONS "_$S(APCHNKAD:"noted on "_$$FMTE^XLFDT($P(APCHNKAD,".",1)),2:""),80),!
  1. I $G(APCHNKAI) G REV ;IHS/OKCAO/POC 5/2/2001
  1. S APCHALG="" F S APCHALG=$O(^GMR(120.8,"B",APCHDFN,APCHALG)) Q:(APCHALG="")!($D(APCHSQIT)) D
  1. .S APCHVER=0 ;ALWAYS START THIS WAY 5/25/2001
  1. .Q:$$TEST(APCHALG)
  1. .Q:$$INACTIVE(APCHALG) ;do not display inactive allergies per Susan Richards, patch 6
  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. .;S APCHMEC=$P(APCHPEC,U,14) ;,APCHMEC=$S(APCHMEC="A":"ALLERGY",APCHMEC="P":"ADVERSE REACTION",1:"UNSPECIFIED") ;IHS/OKCAO/POC 5/2/2001
  1. .S APCHMEC=$P(APCHPEC,U,14) S:APCHMEC="" APCHMEC="U" ;IHS/OKCAO/POC 5/25/2001
  1. .;I $G(APCHWARN) K APCHWARN S APCHMEC="W"
  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 $P(APCHSPCE," ",24)=" " S APCHDRUG=$E(APCHDRUG_APCHSPCE,1,24) ;IHS/OKCAO/POC 5/25/2001 ;CMI 15 TO 20
  1. .;S APCHDATE=$P($P(APCHPEC,U,4),".",1) ;,APCHDATE=$$FMTE^XLFDT(APCHDATE)
  1. .S APCHDATE=$P($P(APCHPEC,U,4),".",1) Q:APCHDATE="" ;,APCHDATE=$$FMTE^XLFDT(APCHDATE,2)
  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_" -- "_APCHDATA
  1. .S APCHENT(APCHMEC,APCHDATE,APCHALG)=APCHDRUG_$S(APCHVER=0:" (not ",1:" (")_"verified)--"_APCHDATA ;IHS/OKCOA/POC 5/25/2001
  1. ;NOW FOR THE WRITING
  1. ;I $G(APCHWARN) W $$CJ^XLFSTR("WARNING: ENTRIES EXIST FOR DRUGS NOT VERIFIED",80),!
  1. S APCHPREV=""
  1. S APCHMEC="" F S APCHMEC=$O(APCHENT(APCHMEC)) Q:(APCHMEC="")!($D(APCHSQIT)) D
  1. .S APCHDATE="" F S APCHDATE=$O(APCHENT(APCHMEC,APCHDATE)) Q:(APCHDATE="")!($D(APCHSQIT)) D
  1. ..S APCHALG="" F S APCHALG=$O(APCHENT(APCHMEC,APCHDATE,APCHALG)) Q:(APCHALG="")!($D(APCHSQIT)) D
  1. ...Q:$G(APCHENT(APCHMEC,APCHDATE,APCHALG))']""
  1. ...;I (APCHPREV="")!(APCHPREV'=APCHMEC) W $S(APCHMEC="A":"ALLERGIES:",APCHMEC="P":"ADVERSE REACTIONS:",1:"UNSPECIFIED:"),!
  1. ...;I (APCHPREV="")!(APCHPREV'=APCHMEC) W $S(APCHMEC="A":"ALLERGIES:",APCHMEC="P":"ADVERSE REACTIONS:",APCHMEC="W":"UNVERIFIED:",1:"UNSPECIFIED:"),!
  1. ...I (APCHPREV="")!(APCHPREV'=APCHMEC) W $S(APCHMEC="A":"ALLERGIES:",APCHMEC="P":"ADVERSE REACTIONS:",1:"UNSPECIFIED:"),! ;IHS/OKCAO/POC 5/25/2001
  1. ...S APCHPREV=APCHMEC
  1. ...;W !,?2,"date noted: ",$$FMTE^XLFDT(APCHDATE)," ",APCHENT(APCHMEC,APCHDATE,APCHALG)
  1. ...;W ?2,"date noted: ",$$FMTE^XLFDT(APCHDATE)," ",APCHENT(APCHMEC,APCHDATE,APCHALG)
  1. ...W ?1,"noted: ",$$FMTE^XLFDT(APCHDATE,2),?17,APCHENT(APCHMEC,APCHDATE,APCHALG) ;CMI/LAB - took out date moved other over 5
  1. ...X APCHSCKP Q:$D(APCHSQIT)
  1. ...I 'APCHSNPG W ! X APCHSCKP Q:$D(APCHSQIT)
  1. REV ;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^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 Allergies Documented 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,22),!
  1. D END
  1. Q
  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. ;S:$P(^GMR(120.8,CHECKIT,0),U,16)'=1 CHECK=1,APCHWARN=1
  1. ;S:$P(^GMR(120.8,CHECKIT,0),U,16)'=1 APCHWARN=1 ;IHS/OKCAO/POC 5/25/2001
  1. Q CHECK
  1. ;
  1. END ;CLEAN UP
  1. K APCHWARN,APCHDATE,APCHMEC,APCHALG,APCHPREV,APCHENT
  1. K APCHVER,APCHSPCE
  1. QUIT
  1. INACTIVE(%) ;EP - is ALLERGY INACTIVE? 1- yes, 0- no
  1. I '$G(%) Q 1
  1. I '$D(^GMR(120.8,%,0)) Q 1
  1. NEW INZ,INACT,REACT,Z
  1. S INZ=0 ;start with active and prove otherwise
  1. S Z=$O(^GMR(120.8,%,9999999.12,$C(0)),-1) I +Z D
  1. .S INACT=$P($G(^GMR(120.8,%,9999999.12,Z,0)),U,1)
  1. .S REACT=$P($G(^GMR(120.8,%,9999999.12,Z,0)),U,4)
  1. .I +INACT&(REACT="") S INZ=1
  1. Q INZ