APCHPALG ; IHS/CMI/LAB - Patient Health Summary - Allergies ;
;;2.0;IHS PCC SUITE;**5,7,8,11**;MAY 14, 2009;Build 58
;;
;
;cmi/anch/maw 8/28/2007 code set versioning on PROBASCH
;
EN ;EP - START HERE
;
Q:'APCHSDFN
S APCHALG="" F S APCHALG=$O(^GMR(120.8,"B",APCHSDFN,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
.;Q:$P(APCHPEC,U,2)="" ;NO REACTANT??
.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 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:" (u) - ",1:" (v) - ")_APCHDATA ;IHS/OKCOA/POC 5/25/2001
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
;
;
;PROBLEMS FROM PROBLEM LIST
PROBA ;EP - CALLED TO CHECK PROBLEM LIST
; for PROBLEM LIST codes only!
I '$D(^AUPNPROB("AC",APCHSDFN)) Q
K APCHSPT S (APCHSFND,APCHSLEN)=0
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
;
K APCHSLEN,APCHSP,APCHPIEN,APCHSQ
;
Q
;
PROBASCH ;active problem search
;S APCHSP=$P(^ICD9(+^AUPNPROB(APCHPIEN,0),0),U,1) D PROBACHK I D PROBALLG cmi/anch/maw 8/27/2007 orig line
S APCHSP=$P($$ICDDX^ICDEX(+^AUPNPROB(APCHPIEN,0)),U,2) D PROBACHK I D PROBALLG ;cmi/anch/maw 8/27/2007 code set versioning
Q
PROBACHK ;checking for allergy codes
Q:$P(^AUPNPROB(APCHPIEN,0),U,5)="" ;IHS/CMI/LAB - no narr
S APCHSNKA=0
I $$ICD^ATXAPI(+^AUPNPROB(APCHPIEN,0),$O(^ATXAX("B","APCH ALLERGY DX CODES",0)),9) Q
;I APCHSP="692.3" Q
;I APCHSP="693.0" Q
;I APCHSP="995.0" Q
;I APCHSP="995.2" Q
;I (+APCHSP'<999.4),(+APCHSP'>999.89) Q
;I APCHSP?1"V14."1E Q
;I APCHSP="692.5" Q
;I APCHSP="693.1" Q
;I APCHSP="V15.0" Q
;I APCHSP["V15.0" Q
;I $E(APCHSP,1,3)=692,APCHSP'="692.9" Q
;I APCHSP="693.8" Q
;I APCHSP="693.9" Q
;I APCHSP="989.5" Q
;I APCHSP="989.82" Q
;I APCHSP="995.3" Q
;I APCHSP["995.2" Q
Q
;
PROBALLG ;if allergy
S APCHSALG=1
S APCHSPT(APCHPIEN)=$$VAL^XBDIQ1(9000011,APCHPIEN,.05) ;$P($G(^AUTNPOV(+$P(^AUPNPROB(APCHPIEN,0),U,5),0)),U,1)
I APCHSPT(APCHPIEN)="" S APCHSPT(APCHPIEN)="???"
S:$L(APCHSPT(APCHPIEN))>APCHSLEN APCHSLEN=$L(APCHSPT(APCHPIEN))
Q
APCHPALG ; IHS/CMI/LAB - Patient Health Summary - Allergies ;
+1 ;;2.0;IHS PCC SUITE;**5,7,8,11**;MAY 14, 2009;Build 58
+2 ;;
+3 ;
+4 ;cmi/anch/maw 8/28/2007 code set versioning on PROBASCH
+5 ;
EN ;EP - START HERE
+1 ;
+2 IF 'APCHSDFN
QUIT
+3 SET APCHALG=""
FOR
SET APCHALG=$ORDER(^GMR(120.8,"B",APCHSDFN,APCHALG))
IF (APCHALG="")!($DATA(APCHSQIT))
QUIT
Begin DoDot:1
+4 ;ALWAYS START THIS WAY 5/25/2001
SET APCHVER=0
+5 IF $$TEST(APCHALG)
QUIT
+6 ;no inactive allergies
IF $$INACTIVE^APCHS79(APCHALG)
QUIT
+7 SET APCHPEC=$GET(^GMR(120.8,APCHALG,0))
+8 IF 'APCHPEC
QUIT
+9 ;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
+10 ;Q:$P(APCHPEC,U,2)="" ;NO REACTANT??
+11 ;IHS/OKCAO/POC 5/25/2001
SET APCHMEC=$PIECE(APCHPEC,U,14)
IF APCHMEC=""
SET APCHMEC="A"
IF APCHMEC="U"
SET APCHMEC="A"
+12 ;IHS/OKCAO/POC 5/25/2001
IF $PIECE(APCHPEC,U,16)=1
SET APCHVER=1
+13 SET APCHDRUG=$PIECE(APCHPEC,U,2)
+14 ;IHS/OKCAO/POC 5/2/2001
IF APCHDRUG']""
SET APCHDRUG="**NO DRUG ENTERED**"
+15 SET APCHDATE=$PIECE($PIECE(APCHPEC,U,4),".",1)
IF APCHDATE=""
QUIT
+16 KILL APCHDATA
+17 SET APCHREC="0"
FOR
SET APCHREC=$ORDER(^GMR(120.8,APCHALG,10,APCHREC))
IF APCHREC'=+APCHREC
QUIT
Begin DoDot:2
+18 SET APCHRNUM=+^GMR(120.8,APCHALG,10,APCHREC,0)
+19 SET APCHDATA(APCHRNUM)=$PIECE(^GMRD(120.83,APCHRNUM,0),U,1)
+20 IF APCHDATA(APCHRNUM)="OTHER REACTION"
SET APCHDATA(APCHRNUM)=$PIECE(^GMR(120.8,APCHALG,10,APCHREC,0),U,2)
End DoDot:2
+21 SET APCHNN=0
+22 SET (APCHCNT,APCHDATA)=""
FOR
SET APCHCNT=$ORDER(APCHDATA(APCHCNT))
IF APCHCNT=""
QUIT
Begin DoDot:2
+23 SET APCHNN=APCHNN+1
+24 IF APCHNN>1
SET APCHDATA=APCHDATA_", "
+25 SET APCHDATA=APCHDATA_APCHDATA(APCHCNT)
End DoDot:2
+26 ;_$S(APCHVER=0:" (u) - ",1:" (v) - ")_APCHDATA ;IHS/OKCOA/POC 5/25/2001
SET APCHENT(APCHMEC,APCHDATE,APCHALG)=APCHDRUG
End DoDot:1
+27 QUIT
+28 ;
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 ;
+7 ;
+8 ;PROBLEMS FROM PROBLEM LIST
PROBA ;EP - CALLED TO CHECK PROBLEM LIST
+1 ; for PROBLEM LIST codes only!
+2 IF '$DATA(^AUPNPROB("AC",APCHSDFN))
QUIT
+3 KILL APCHSPT
SET (APCHSFND,APCHSLEN)=0
+4 SET APCHPIEN=""
FOR APCHSQ=0:0
SET APCHPIEN=$ORDER(^AUPNPROB("AC",APCHSDFN,APCHPIEN))
IF 'APCHPIEN
QUIT
IF $PIECE(^AUPNPROB(APCHPIEN,0),U,12)'="D"
DO PROBASCH
+5 ;
+6 KILL APCHSLEN,APCHSP,APCHPIEN,APCHSQ
+7 ;
+8 QUIT
+9 ;
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
+2 ;cmi/anch/maw 8/27/2007 code set versioning
SET APCHSP=$PIECE($$ICDDX^ICDEX(+^AUPNPROB(APCHPIEN,0)),U,2)
DO PROBACHK
IF $TEST
DO PROBALLG
+3 QUIT
PROBACHK ;checking for allergy codes
+1 ;IHS/CMI/LAB - no narr
IF $PIECE(^AUPNPROB(APCHPIEN,0),U,5)=""
QUIT
+2 SET APCHSNKA=0
+3 IF $$ICD^ATXAPI(+^AUPNPROB(APCHPIEN,0),$ORDER(^ATXAX("B","APCH ALLERGY DX CODES",0)),9)
QUIT
+4 ;I APCHSP="692.3" Q
+5 ;I APCHSP="693.0" Q
+6 ;I APCHSP="995.0" Q
+7 ;I APCHSP="995.2" Q
+8 ;I (+APCHSP'<999.4),(+APCHSP'>999.89) Q
+9 ;I APCHSP?1"V14."1E Q
+10 ;I APCHSP="692.5" Q
+11 ;I APCHSP="693.1" Q
+12 ;I APCHSP="V15.0" Q
+13 ;I APCHSP["V15.0" Q
+14 ;I $E(APCHSP,1,3)=692,APCHSP'="692.9" Q
+15 ;I APCHSP="693.8" Q
+16 ;I APCHSP="693.9" Q
+17 ;I APCHSP="989.5" Q
+18 ;I APCHSP="989.82" Q
+19 ;I APCHSP="995.3" Q
+20 ;I APCHSP["995.2" Q
+21 QUIT
+22 ;
PROBALLG ;if allergy
+1 SET APCHSALG=1
+2 ;$P($G(^AUTNPOV(+$P(^AUPNPROB(APCHPIEN,0),U,5),0)),U,1)
SET APCHSPT(APCHPIEN)=$$VAL^XBDIQ1(9000011,APCHPIEN,.05)
+3 IF APCHSPT(APCHPIEN)=""
SET APCHSPT(APCHPIEN)="???"
+4 IF $LENGTH(APCHSPT(APCHPIEN))>APCHSLEN
SET APCHSLEN=$LENGTH(APCHSPT(APCHPIEN))
+5 QUIT
