APCHS79 ; IHS/CMI/LAB - HEALTH SUMMARY COMPONENT FOR ALLERGY FILE (PATIENT ALLERGY) ;
;;2.0;IHS PCC SUITE;**5,6**;MAY 14, 2009;Build 11
;;
EN ;START HERE
S APCHDFN=APCHSPAT
K APCHNKAI
Q:'APCHDFN
;Q:'$D(^GMR(120.8,"B",APCHDFN))
X APCHSCKP G:$D(APCHSQIT) END I 'APCHSNPG W ! X APCHSCKP Q:$D(APCHSQIT) X:'APCHSNPG APCHSBRK
I '$D(^GMR(120.8,"B",APCHDFN)) D K APCHDFN G REV
.I $D(^GMR(120.86,APCHDFN,0)),$P(^GMR(120.86,APCHDFN,0),U,2)=0 D Q
..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
.W !,$$CJ^XLFSTR("NO ALLERGY INFORMATION RECORDED",IOM),! ;IHS/OKCAO/POC 4/27/2001
I $O(^GMR(120.8,"ANKA",APCHDFN,""))="n" D
.S APCHNKAI=$O(^GMR(120.8,"ANKA",APCHDFN,"n",""))
.I APCHNKAI S APCHNKAD=$P(^GMR(120.8,APCHNKAI,0),U,4)
.;W !,$$CJ^XLFSTR("NO ALLERGIES/ADVERSE DRUG REACTIONS "_$S(APCHNKAD:"noted on "_$$FMTE^XLFDT($P(APCHNKAD,".",1)),1:""),80),!
.W !,$$CJ^XLFSTR("NO KNOWN ALLERGIES/ADVERSE DRUG REACTIONS "_$S(APCHNKAD:"noted on "_$$FMTE^XLFDT($P(APCHNKAD,".",1)),2:""),80),!
I $G(APCHNKAI) G REV ;IHS/OKCAO/POC 5/2/2001
S APCHALG="" F S APCHALG=$O(^GMR(120.8,"B",APCHDFN,APCHALG)) Q:(APCHALG="")!($D(APCHSQIT)) D
.S APCHVER=0 ;ALWAYS START THIS WAY 5/25/2001
.Q:$$TEST(APCHALG)
.Q:$$INACTIVE(APCHALG) ;do not display inactive allergies per Susan Richards, patch 6
.S APCHPEC=$G(^GMR(120.8,APCHALG,0))
.Q:'APCHPEC
.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
.;S APCHMEC=$P(APCHPEC,U,14) ;,APCHMEC=$S(APCHMEC="A":"ALLERGY",APCHMEC="P":"ADVERSE REACTION",1:"UNSPECIFIED") ;IHS/OKCAO/POC 5/2/2001
.S APCHMEC=$P(APCHPEC,U,14) S:APCHMEC="" APCHMEC="U" ;IHS/OKCAO/POC 5/25/2001
.;I $G(APCHWARN) K APCHWARN S APCHMEC="W"
.S:$P(APCHPEC,U,16)=1 APCHVER=1 ;IHS/OKCAO/POC 5/25/2001
.S APCHDRUG=$P(APCHPEC,U,2)
.S:APCHDRUG']"" APCHDRUG="**NO DRUG ENTERED**" ;IHS/OKCAO/POC 5/2/2001
.S $P(APCHSPCE," ",24)=" " S APCHDRUG=$E(APCHDRUG_APCHSPCE,1,24) ;IHS/OKCAO/POC 5/25/2001 ;CMI 15 TO 20
.;S APCHDATE=$P($P(APCHPEC,U,4),".",1) ;,APCHDATE=$$FMTE^XLFDT(APCHDATE)
.S APCHDATE=$P($P(APCHPEC,U,4),".",1) Q:APCHDATE="" ;,APCHDATE=$$FMTE^XLFDT(APCHDATE,2)
.K APCHDATA
.S APCHREC="0" F S APCHREC=$O(^GMR(120.8,APCHALG,10,APCHREC)) Q:APCHREC'=+APCHREC D
..S APCHRNUM=+^GMR(120.8,APCHALG,10,APCHREC,0)
..S APCHDATA(APCHRNUM)=$P(^GMRD(120.83,APCHRNUM,0),U,1)
..S:APCHDATA(APCHRNUM)="OTHER REACTION" APCHDATA(APCHRNUM)=$P(^GMR(120.8,APCHALG,10,APCHREC,0),U,2)
.S APCHNN=0
.S (APCHCNT,APCHDATA)="" F S APCHCNT=$O(APCHDATA(APCHCNT)) Q:APCHCNT="" D
..S APCHNN=APCHNN+1
..S:APCHNN>1 APCHDATA=APCHDATA_", "
..S APCHDATA=APCHDATA_APCHDATA(APCHCNT)
.;S APCHENT(APCHMEC,APCHDATE,APCHALG)=APCHDRUG_" -- "_APCHDATA
.S APCHENT(APCHMEC,APCHDATE,APCHALG)=APCHDRUG_$S(APCHVER=0:" (not ",1:" (")_"verified)--"_APCHDATA ;IHS/OKCOA/POC 5/25/2001
;NOW FOR THE WRITING
;I $G(APCHWARN) W $$CJ^XLFSTR("WARNING: ENTRIES EXIST FOR DRUGS NOT VERIFIED",80),!
S APCHPREV=""
S APCHMEC="" F S APCHMEC=$O(APCHENT(APCHMEC)) Q:(APCHMEC="")!($D(APCHSQIT)) D
.S APCHDATE="" F S APCHDATE=$O(APCHENT(APCHMEC,APCHDATE)) Q:(APCHDATE="")!($D(APCHSQIT)) D
..S APCHALG="" F S APCHALG=$O(APCHENT(APCHMEC,APCHDATE,APCHALG)) Q:(APCHALG="")!($D(APCHSQIT)) D
...Q:$G(APCHENT(APCHMEC,APCHDATE,APCHALG))']""
...;I (APCHPREV="")!(APCHPREV'=APCHMEC) W $S(APCHMEC="A":"ALLERGIES:",APCHMEC="P":"ADVERSE REACTIONS:",1:"UNSPECIFIED:"),!
...;I (APCHPREV="")!(APCHPREV'=APCHMEC) W $S(APCHMEC="A":"ALLERGIES:",APCHMEC="P":"ADVERSE REACTIONS:",APCHMEC="W":"UNVERIFIED:",1:"UNSPECIFIED:"),!
...I (APCHPREV="")!(APCHPREV'=APCHMEC) W $S(APCHMEC="A":"ALLERGIES:",APCHMEC="P":"ADVERSE REACTIONS:",1:"UNSPECIFIED:"),! ;IHS/OKCAO/POC 5/25/2001
...S APCHPREV=APCHMEC
...;W !,?2,"date noted: ",$$FMTE^XLFDT(APCHDATE)," ",APCHENT(APCHMEC,APCHDATE,APCHALG)
...;W ?2,"date noted: ",$$FMTE^XLFDT(APCHDATE)," ",APCHENT(APCHMEC,APCHDATE,APCHALG)
...W ?1,"noted: ",$$FMTE^XLFDT(APCHDATE,2),?17,APCHENT(APCHMEC,APCHDATE,APCHALG) ;CMI/LAB - took out date moved other over 5
...X APCHSCKP Q:$D(APCHSQIT)
...I 'APCHSNPG W ! X APCHSCKP Q:$D(APCHSQIT)
REV ;get date last reviewed and display
S APCHSX=$$LASTALR^APCLAPI6(APCHSPAT,,DT,"A")
X APCHSCKP Q:$D(APCHSQIT)
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),!
S APCHSX=$$LASTALU^APCLAPI6(APCHSPAT,,DT,"A")
X APCHSCKP Q:$D(APCHSQIT)
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),!
S APCHSX=$$LASTNAA^APCLAPI6(APCHSPAT,,DT,"A")
X APCHSCKP Q:$D(APCHSQIT)
;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),!
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),!
D END
Q
TEST(CHECKIT) ;CHECK IF VERIFED AND NOT ENTERED IN ERROR
N CHECK
S CHECK=0 ;CHECK=1 ENTERED IN ERROR OR NOT VERIFED
;S:$D(^GMR(120.8,CHECKIT,"ER")) CHECK=1
S:$P($G(^GMR(120.8,CHECKIT,"ER")),U)=1 CHECK=1 ;CMI/GRL *17*
;S:$P(^GMR(120.8,CHECKIT,0),U,16)'=1 CHECK=1,APCHWARN=1
;S:$P(^GMR(120.8,CHECKIT,0),U,16)'=1 APCHWARN=1 ;IHS/OKCAO/POC 5/25/2001
Q CHECK
;
END ;CLEAN UP
K APCHWARN,APCHDATE,APCHMEC,APCHALG,APCHPREV,APCHENT
K APCHVER,APCHSPCE
QUIT
INACTIVE(%) ;EP - is ALLERGY INACTIVE? 1- yes, 0- no
I '$G(%) Q 1
I '$D(^GMR(120.8,%,0)) Q 1
NEW INZ,INACT,REACT,Z
S INZ=0 ;start with active and prove otherwise
S Z=$O(^GMR(120.8,%,9999999.12,$C(0)),-1) I +Z D
.S INACT=$P($G(^GMR(120.8,%,9999999.12,Z,0)),U,1)
.S REACT=$P($G(^GMR(120.8,%,9999999.12,Z,0)),U,4)
.I +INACT&(REACT="") S INZ=1
Q INZ
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
+2 ;;
EN ;START HERE
+1 SET APCHDFN=APCHSPAT
+2 KILL APCHNKAI
+3 IF 'APCHDFN
QUIT
+4 ;Q:'$D(^GMR(120.8,"B",APCHDFN))
+5 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
GOTO END
IF 'APCHSNPG
WRITE !
XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
IF 'APCHSNPG
XECUTE APCHSBRK
+6 IF '$DATA(^GMR(120.8,"B",APCHDFN))
Begin DoDot:1
+7 IF $DATA(^GMR(120.86,APCHDFN,0))
IF $PIECE(^GMR(120.86,APCHDFN,0),U,2)=0
Begin DoDot:2
+8 WRITE !,$$CJ^XLFSTR("NO KNOWN ALLERGIES/ADVERSE DRUG REACTIONS noted on "_$$FMTE^XLFDT($PIECE($PIECE(^GMR(120.86,APCHDFN,0),U,4),".",1)),80),!
QUIT
End DoDot:2
QUIT
+9 ;IHS/OKCAO/POC 4/27/2001
WRITE !,$$CJ^XLFSTR("NO ALLERGY INFORMATION RECORDED",IOM),!
End DoDot:1
KILL APCHDFN
GOTO REV
+10 IF $ORDER(^GMR(120.8,"ANKA",APCHDFN,""))="n"
Begin DoDot:1
+11 SET APCHNKAI=$ORDER(^GMR(120.8,"ANKA",APCHDFN,"n",""))
+12 IF APCHNKAI
SET APCHNKAD=$PIECE(^GMR(120.8,APCHNKAI,0),U,4)
+13 ;W !,$$CJ^XLFSTR("NO ALLERGIES/ADVERSE DRUG REACTIONS "_$S(APCHNKAD:"noted on "_$$FMTE^XLFDT($P(APCHNKAD,".",1)),1:""),80),!
+14 WRITE !,$$CJ^XLFSTR("NO KNOWN ALLERGIES/ADVERSE DRUG REACTIONS "_$SELECT(APCHNKAD:"noted on "_$$FMTE^XLFDT($PIECE(APCHNKAD,".",1)),2:""),80),!
End DoDot:1
+15 ;IHS/OKCAO/POC 5/2/2001
IF $GET(APCHNKAI)
GOTO REV
+16 SET APCHALG=""
FOR
SET APCHALG=$ORDER(^GMR(120.8,"B",APCHDFN,APCHALG))
IF (APCHALG="")!($DATA(APCHSQIT))
QUIT
Begin DoDot:1
+17 ;ALWAYS START THIS WAY 5/25/2001
SET APCHVER=0
+18 IF $$TEST(APCHALG)
QUIT
+19 ;do not display inactive allergies per Susan Richards, patch 6
IF $$INACTIVE(APCHALG)
QUIT
+20 SET APCHPEC=$GET(^GMR(120.8,APCHALG,0))
+21 IF 'APCHPEC
QUIT
+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
IF $PIECE(APCHPEC,U,22)]""
QUIT
+23 ;S APCHMEC=$P(APCHPEC,U,14) ;,APCHMEC=$S(APCHMEC="A":"ALLERGY",APCHMEC="P":"ADVERSE REACTION",1:"UNSPECIFIED") ;IHS/OKCAO/POC 5/2/2001
+24 ;IHS/OKCAO/POC 5/25/2001
SET APCHMEC=$PIECE(APCHPEC,U,14)
IF APCHMEC=""
SET APCHMEC="U"
+25 ;I $G(APCHWARN) K APCHWARN S APCHMEC="W"
+26 ;IHS/OKCAO/POC 5/25/2001
IF $PIECE(APCHPEC,U,16)=1
SET APCHVER=1
+27 SET APCHDRUG=$PIECE(APCHPEC,U,2)
+28 ;IHS/OKCAO/POC 5/2/2001
IF APCHDRUG']""
SET APCHDRUG="**NO DRUG ENTERED**"
+29 ;IHS/OKCAO/POC 5/25/2001 ;CMI 15 TO 20
SET $PIECE(APCHSPCE," ",24)=" "
SET APCHDRUG=$EXTRACT(APCHDRUG_APCHSPCE,1,24)
+30 ;S APCHDATE=$P($P(APCHPEC,U,4),".",1) ;,APCHDATE=$$FMTE^XLFDT(APCHDATE)
+31 ;,APCHDATE=$$FMTE^XLFDT(APCHDATE,2)
SET APCHDATE=$PIECE($PIECE(APCHPEC,U,4),".",1)
IF APCHDATE=""
QUIT
+32 KILL APCHDATA
+33 SET APCHREC="0"
FOR
SET APCHREC=$ORDER(^GMR(120.8,APCHALG,10,APCHREC))
IF APCHREC'=+APCHREC
QUIT
Begin DoDot:2
+34 SET APCHRNUM=+^GMR(120.8,APCHALG,10,APCHREC,0)
+35 SET APCHDATA(APCHRNUM)=$PIECE(^GMRD(120.83,APCHRNUM,0),U,1)
+36 IF APCHDATA(APCHRNUM)="OTHER REACTION"
SET APCHDATA(APCHRNUM)=$PIECE(^GMR(120.8,APCHALG,10,APCHREC,0),U,2)
End DoDot:2
+37 SET APCHNN=0
+38 SET (APCHCNT,APCHDATA)=""
FOR
SET APCHCNT=$ORDER(APCHDATA(APCHCNT))
IF APCHCNT=""
QUIT
Begin DoDot:2
+39 SET APCHNN=APCHNN+1
+40 IF APCHNN>1
SET APCHDATA=APCHDATA_", "
+41 SET APCHDATA=APCHDATA_APCHDATA(APCHCNT)
End DoDot:2
+42 ;S APCHENT(APCHMEC,APCHDATE,APCHALG)=APCHDRUG_" -- "_APCHDATA
+43 ;IHS/OKCOA/POC 5/25/2001
SET APCHENT(APCHMEC,APCHDATE,APCHALG)=APCHDRUG_$SELECT(APCHVER=0:" (not ",1:" (")_"verified)--"_APCHDATA
End DoDot:1
+44 ;NOW FOR THE WRITING
+45 ;I $G(APCHWARN) W $$CJ^XLFSTR("WARNING: ENTRIES EXIST FOR DRUGS NOT VERIFIED",80),!
+46 SET APCHPREV=""
+47 SET APCHMEC=""
FOR
SET APCHMEC=$ORDER(APCHENT(APCHMEC))
IF (APCHMEC="")!($DATA(APCHSQIT))
QUIT
Begin DoDot:1
+48 SET APCHDATE=""
FOR
SET APCHDATE=$ORDER(APCHENT(APCHMEC,APCHDATE))
IF (APCHDATE="")!($DATA(APCHSQIT))
QUIT
Begin DoDot:2
+49 SET APCHALG=""
FOR
SET APCHALG=$ORDER(APCHENT(APCHMEC,APCHDATE,APCHALG))
IF (APCHALG="")!($DATA(APCHSQIT))
QUIT
Begin DoDot:3
+50 IF $GET(APCHENT(APCHMEC,APCHDATE,APCHALG))']""
QUIT
+51 ;I (APCHPREV="")!(APCHPREV'=APCHMEC) W $S(APCHMEC="A":"ALLERGIES:",APCHMEC="P":"ADVERSE REACTIONS:",1:"UNSPECIFIED:"),!
+52 ;I (APCHPREV="")!(APCHPREV'=APCHMEC) W $S(APCHMEC="A":"ALLERGIES:",APCHMEC="P":"ADVERSE REACTIONS:",APCHMEC="W":"UNVERIFIED:",1:"UNSPECIFIED:"),!
+53 ;IHS/OKCAO/POC 5/25/2001
IF (APCHPREV="")!(APCHPREV'=APCHMEC)
WRITE $SELECT(APCHMEC="A":"ALLERGIES:",APCHMEC="P":"ADVERSE REACTIONS:",1:"UNSPECIFIED:"),!
+54 SET APCHPREV=APCHMEC
+55 ;W !,?2,"date noted: ",$$FMTE^XLFDT(APCHDATE)," ",APCHENT(APCHMEC,APCHDATE,APCHALG)
+56 ;W ?2,"date noted: ",$$FMTE^XLFDT(APCHDATE)," ",APCHENT(APCHMEC,APCHDATE,APCHALG)
+57 ;CMI/LAB - took out date moved other over 5
WRITE ?1,"noted: ",$$FMTE^XLFDT(APCHDATE,2),?17,APCHENT(APCHMEC,APCHDATE,APCHALG)
+58 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+59 IF 'APCHSNPG
WRITE !
XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
End DoDot:3
End DoDot:2
End DoDot:1
REV ;get date last reviewed and display
+1 SET APCHSX=$$LASTALR^APCLAPI6(APCHSPAT,,DT,"A")
+2 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+3 WRITE !,"Allergy List Reviewed On: ",?36,$$FMTE^XLFDT($PIECE(APCHSX,U,1))
WRITE ?51,"By: ",?54,$EXTRACT($SELECT($PIECE(APCHSX,U,3):$PIECE($GET(^VA(200,$PIECE(APCHSX,U,3),0)),U),1:""),1,25),!
+4 SET APCHSX=$$LASTALU^APCLAPI6(APCHSPAT,,DT,"A")
+5 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+6 WRITE "Allergy List Updated On: ",?36,$$FMTE^XLFDT($PIECE(APCHSX,U,1))
WRITE ?51,"By: ",?54,$EXTRACT($SELECT($PIECE(APCHSX,U,3):$PIECE($GET(^VA(200,$PIECE(APCHSX,U,3),0)),U),1:""),1,25),!
+7 SET APCHSX=$$LASTNAA^APCLAPI6(APCHSPAT,,DT,"A")
+8 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+9 ;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),!
+10 WRITE "No Active Allergies Documented On: ",?36,$$FMTE^XLFDT($PIECE(APCHSX,U,1))
WRITE ?51,"By: ",?54,$EXTRACT($SELECT($PIECE(APCHSX,U,3):$PIECE($GET(^VA(200,$PIECE(APCHSX,U,3),0)),U),1:""),1,22),!
+11 DO END
+12 QUIT
TEST(CHECKIT) ;CHECK IF VERIFED AND NOT ENTERED IN ERROR
+1 NEW CHECK
+2 ;CHECK=1 ENTERED IN ERROR OR NOT VERIFED
SET CHECK=0
+3 ;S:$D(^GMR(120.8,CHECKIT,"ER")) CHECK=1
+4 ;CMI/GRL *17*
IF $PIECE($GET(^GMR(120.8,CHECKIT,"ER")),U)=1
SET CHECK=1
+5 ;S:$P(^GMR(120.8,CHECKIT,0),U,16)'=1 CHECK=1,APCHWARN=1
+6 ;S:$P(^GMR(120.8,CHECKIT,0),U,16)'=1 APCHWARN=1 ;IHS/OKCAO/POC 5/25/2001
+7 QUIT CHECK
+8 ;
END ;CLEAN UP
+1 KILL APCHWARN,APCHDATE,APCHMEC,APCHALG,APCHPREV,APCHENT
+2 KILL APCHVER,APCHSPCE
+3 QUIT
INACTIVE(%) ;EP - is ALLERGY INACTIVE? 1- yes, 0- no
+1 IF '$GET(%)
QUIT 1
+2 IF '$DATA(^GMR(120.8,%,0))
QUIT 1
+3 NEW INZ,INACT,REACT,Z
+4 ;start with active and prove otherwise
SET INZ=0
+5 SET Z=$ORDER(^GMR(120.8,%,9999999.12,$CHAR(0)),-1)
IF +Z
Begin DoDot:1
+6 SET INACT=$PIECE($GET(^GMR(120.8,%,9999999.12,Z,0)),U,1)
+7 SET REACT=$PIECE($GET(^GMR(120.8,%,9999999.12,Z,0)),U,4)
+8 IF +INACT&(REACT="")
SET INZ=1
End DoDot:1
+9 QUIT INZ
