APCHS70 ; IHS/CMI/LAB - HEALTH SUMMARY COMPONENT FOR ALLERGY FILE (PATIENT ALLERGY) ;
;;2.0;IHS PCC SUITE;**2,5,6**;MAY 14, 2009;Build 11
;;
EN ;START HERE
S APCHDFN=APCHSPAT
K APCHNKAI
Q:'APCHDFN
;S X="GMTSALGB" X ^%ZOSF("TEST") I $T D ^APCHGMTS Q
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",80),! ;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 KNOWN ALLERGIES/ADVERSE DRUG REACTIONS "_$S(APCHNKAD:"noted on "_$$FMTE^XLFDT($P(APCHNKAD,".",1)),2:""),80),!
I $G(APCHNKAI) D REV,END Q ;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^APCHS79(APCHALG) ;no inactive allergies
.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) S:APCHMEC="" APCHMEC="A" S:APCHMEC="U" APCHMEC="A" ;IHS/OKCAO/POC 5/25/2001
.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)
.Q:APCHDATE=""
.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_$S(APCHVER=0:" (un",1:" (")_"verified) - "_APCHDATA ;IHS/OKCOA/POC 5/25/2001
;NOW FOR THE WRITING
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:")
...S APCHT=$S(APCHMEC="A":11,APCHMEC="P":19,1:13)
...S APCHPREV=APCHMEC
...W ?APCHT,APCHENT(APCHMEC,APCHDATE,APCHALG),!
...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*
Q CHECK
;
END ;CLEAN UP
K APCHWARN,APCHDATE,APCHMEC,APCHALG,APCHPREV,APCHENT
K APCHVER,APCHSPCE
QUIT
APCHS70 ; IHS/CMI/LAB - HEALTH SUMMARY COMPONENT FOR ALLERGY FILE (PATIENT ALLERGY) ;
+1 ;;2.0;IHS PCC SUITE;**2,5,6**;MAY 14, 2009;Build 11
+2 ;;
EN ;START HERE
+1 SET APCHDFN=APCHSPAT
+2 KILL APCHNKAI
+3 IF 'APCHDFN
QUIT
+4 ;S X="GMTSALGB" X ^%ZOSF("TEST") I $T D ^APCHGMTS Q
+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",80),!
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 WRITE !,$$CJ^XLFSTR("NO KNOWN ALLERGIES/ADVERSE DRUG REACTIONS "_$SELECT(APCHNKAD:"noted on "_$$FMTE^XLFDT($PIECE(APCHNKAD,".",1)),2:""),80),!
End DoDot:1
+14 ;IHS/OKCAO/POC 5/2/2001
IF $GET(APCHNKAI)
DO REV
DO END
QUIT
+15 SET APCHALG=""
FOR
SET APCHALG=$ORDER(^GMR(120.8,"B",APCHDFN,APCHALG))
IF (APCHALG="")!($DATA(APCHSQIT))
QUIT
Begin DoDot:1
+16 ;ALWAYS START THIS WAY 5/25/2001
SET APCHVER=0
+17 IF $$TEST(APCHALG)
QUIT
+18 ;no inactive allergies
IF $$INACTIVE^APCHS79(APCHALG)
QUIT
+19 SET APCHPEC=$GET(^GMR(120.8,APCHALG,0))
+20 IF 'APCHPEC
QUIT
+21 ;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
+22 ;IHS/OKCAO/POC 5/25/2001
SET APCHMEC=$PIECE(APCHPEC,U,14)
IF APCHMEC=""
SET APCHMEC="A"
IF APCHMEC="U"
SET APCHMEC="A"
+23 ;IHS/OKCAO/POC 5/25/2001
IF $PIECE(APCHPEC,U,16)=1
SET APCHVER=1
+24 SET APCHDRUG=$PIECE(APCHPEC,U,2)
+25 ;IHS/OKCAO/POC 5/2/2001
IF APCHDRUG']""
SET APCHDRUG="**NO DRUG ENTERED**"
+26 ;S $P(APCHSPCE," ",24)=" " S APCHDRUG=$E(APCHDRUG_APCHSPCE,1,24) ;IHS/OKCAO/POC 5/25/2001 ;CMI 15 TO 20
+27 SET APCHDATE=$PIECE($PIECE(APCHPEC,U,4),".",1)
+28 IF APCHDATE=""
QUIT
+29 KILL APCHDATA
+30 SET APCHREC="0"
FOR
SET APCHREC=$ORDER(^GMR(120.8,APCHALG,10,APCHREC))
IF APCHREC'=+APCHREC
QUIT
Begin DoDot:2
+31 SET APCHRNUM=+^GMR(120.8,APCHALG,10,APCHREC,0)
+32 SET APCHDATA(APCHRNUM)=$PIECE(^GMRD(120.83,APCHRNUM,0),U,1)
+33 IF APCHDATA(APCHRNUM)="OTHER REACTION"
SET APCHDATA(APCHRNUM)=$PIECE(^GMR(120.8,APCHALG,10,APCHREC,0),U,2)
End DoDot:2
+34 SET APCHNN=0
+35 SET (APCHCNT,APCHDATA)=""
FOR
SET APCHCNT=$ORDER(APCHDATA(APCHCNT))
IF APCHCNT=""
QUIT
Begin DoDot:2
+36 SET APCHNN=APCHNN+1
+37 IF APCHNN>1
SET APCHDATA=APCHDATA_", "
+38 SET APCHDATA=APCHDATA_APCHDATA(APCHCNT)
End DoDot:2
+39 ;IHS/OKCOA/POC 5/25/2001
SET APCHENT(APCHMEC,APCHDATE,APCHALG)=APCHDRUG_$SELECT(APCHVER=0:" (un",1:" (")_"verified) - "_APCHDATA
End DoDot:1
+40 ;NOW FOR THE WRITING
+41 SET APCHPREV=""
+42 SET APCHMEC=""
FOR
SET APCHMEC=$ORDER(APCHENT(APCHMEC))
IF (APCHMEC="")!($DATA(APCHSQIT))
QUIT
Begin DoDot:1
+43 SET APCHDATE=""
FOR
SET APCHDATE=$ORDER(APCHENT(APCHMEC,APCHDATE))
IF (APCHDATE="")!($DATA(APCHSQIT))
QUIT
Begin DoDot:2
+44 SET APCHALG=""
FOR
SET APCHALG=$ORDER(APCHENT(APCHMEC,APCHDATE,APCHALG))
IF (APCHALG="")!($DATA(APCHSQIT))
QUIT
Begin DoDot:3
+45 IF $GET(APCHENT(APCHMEC,APCHDATE,APCHALG))']""
QUIT
+46 IF APCHPREV=""!(APCHPREV'=APCHMEC)
WRITE $SELECT(APCHMEC="A":"Allergies:",APCHMEC="P":"Adverse Reactions:",1:"Unspecified:")
+47 SET APCHT=$SELECT(APCHMEC="A":11,APCHMEC="P":19,1:13)
+48 SET APCHPREV=APCHMEC
+49 WRITE ?APCHT,APCHENT(APCHMEC,APCHDATE,APCHALG),!
+50 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+51 ;I 'APCHSNPG W ! X APCHSCKP Q:$D(APCHSQIT)
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 QUIT CHECK
+6 ;
END ;CLEAN UP
+1 KILL APCHWARN,APCHDATE,APCHMEC,APCHALG,APCHPREV,APCHENT
+2 KILL APCHVER,APCHSPCE
+3 QUIT
