APCHS40 ; IHS/CMI/LAB -- SUMMARY PRODUCTION COMPONENTS ;
;;2.0;IHS PCC SUITE;**5,6,7,11,16**;MAY 14, 2009;Build 9
;
;cmi/anch/maw 8/27/2007 code set versioning in PROBASCH
;
PROBA ; ************ ALLERGY PROB * 9000011 *********
; for PROBLEM LIST codes only!
I '$D(^AUPNPROB("AC",APCHSPAT)) X APCHSCKP G:$D(APCHSQIT) PROBAX I 'APCHSNPG W ! X APCHSCKP Q:$D(APCHSQIT) X:'APCHSNPG APCHSBRK W ! D PROBADNR,ALR Q
K APCHSPT S (APCHSFND,APCHSLEN)=0
S APCHSDFN="" F APCHSQ=0:0 S APCHSDFN=$O(^AUPNPROB("AC",APCHSPAT,APCHSDFN)) Q:'APCHSDFN I $D(^AUPNPROB(APCHSDFN,0)),$P(^AUPNPROB(APCHSDFN,0),U,12)'="D" D PROBASCH
X APCHSCKP G:$D(APCHSQIT) PROBAX I 'APCHSNPG W ! X APCHSCKP Q:$D(APCHSQIT) X:'APCHSNPG APCHSBRK
W !
I 'APCHSFND D PROBADNR,ALR G PROBAX
S APCHSDFN="" F APCHSQ=0:0 S APCHSDFN=$O(APCHSPT(APCHSDFN)) Q:'APCHSDFN D PROBADSP
ALR ;
;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^APCDAALG(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: ",?56,$E($S($P(APCHSX,U,3):$P($G(^VA(200,$P(APCHSX,U,3),0)),U),1:""),1,22),!
;get date last reviewed and display
S APCHSX=$$LASTPLR^APCLAPI6(APCHSPAT,,DT,"A")
X APCHSCKP Q:$D(APCHSQIT)
W !,"Problem 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=$$LASTPLU^APCLAPI6(APCHSPAT,,DT,"A")
X APCHSCKP Q:$D(APCHSQIT)
W "Problem 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=$$LASTNAP^APCLAPI6(APCHSPAT,,DT,"A")
X APCHSCKP Q:$D(APCHSQIT)
;I '$$ANYACTP^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 Problems Documented On: ",?36,$$FMTE^XLFDT($P(APCHSX,U,1)) W ?51,"By: ",$E($S($P(APCHSX,U,3):$P($G(^VA(200,$P(APCHSX,U,3),0)),U),1:""),1,25),!
PROBAX ;
K APCHSPT,APCHSFND,APCHSDFN,APCHSLEN,APCHSDAT,APCHSNKA
Q
;
PROBASCH ;active problem search
;S APCHSP=$P(^ICD9(+^AUPNPROB(APCHSDFN,0),0),U,1) D PROBACHK I D PROBALLG cmi/anch/maw 8/27/2007 orig line
S APCHSP=$P($$ICDDX^ICDEX(+^AUPNPROB(APCHSDFN,0),0),U,2) D PROBACHK I D PROBALLG ;cmi/anch/maw 8/27/2007 code set versioning
Q
PROBACHK ;checking for allergy codes
S APCHSNKA=0
Q:$P(^AUPNPROB(APCHSDFN,0),U,5)="" ;IHS/CMI/LAB - no narr
S APCHSNKA=0
I $$ICD^ATXAPI(+^AUPNPROB(APCHSDFN,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
;S N=$P(^AUTNPOV($P(^AUPNPROB(APCHSDFN,0),U,5),0),U) I APCHSP="799.9"!(APCHSP="V82.9"),N["NO KNOWN ALLERG"!(N["NKA")!(N["NKDA")!(N["NO KNOWN DRUG ALLERG") S APCHSNKA=1 Q
S N=$$VAL^XBDIQ1(9000011,APCHSDFN,.05) I N["NO KNOWN ALLERG"!(N["NKA")!(N["NKDA")!(N["NO KNOWN DRUG ALLERG") S APCHSNKA=1 Q
;I APCHSP="799.9",$P(^AUTNPOV($P(^AUPNPROB(APCHSDFN,0),U,5),0),U,1)["NO KNOWN ALLERG"!($P(^AUTNPOV($P(^AUPNPROB(APCHSDFN,0),U,5),0),U,1)["NKA")!($P(^AUTNPOV($P(^AUPNPROB(APCHSDFN,0),U,5),0),U)["NKDA") S APCHSNKA=1 Q
Q
;
PROBADSP ;display allergies
S:$L(APCHSPT(APCHSDFN))<APCHSLEN APCHSL1=$L(APCHSPT(APCHSDFN))/2,APCHSL1=(APCHSLEN/2)-APCHSL1 ; center recorded allergies
W ?((IOM-APCHSLEN-12)/2),"***** "
W ?((IOM-APCHSLEN)/2)+$G(APCHSL1),APCHSPT(APCHSDFN)
W ?((IOM+APCHSLEN)/2)," *****",!
K APCHSL1
Q
;
PROBADNR ;display "NONE RECORDED", if no allergies recorded
W ?((IOM-13-12)/2),"***** ",?((IOM-13)/2),"NONE RECORDED",?((IOM+13)/2)," *****",!
Q
;
PROBALLG ;if allergy
S APCHSFND=1
I APCHSNKA D I 1
. S Y=$P(^AUPNPROB(APCHSDFN,0),U,8) X APCHSCVD S APCHSDAT=Y
. S APCHSPT(APCHSDFN)="NO ALLERGY NOTED ON "_APCHSDAT_" ("_$$VAL^XBDIQ1(9000011,APCHSDFN,.05)_")"
. S:$L($P(APCHSPT(APCHSDFN),U))>APCHSLEN APCHSLEN=$L($P(APCHSPT(APCHSDFN),U))
. Q
E D
. ;Q:$P(^AUPNPROB(APCHSDFN,0),U,5)="" ;IHS/CMI/LAB - added this to prevent subscript
. S APCHSPT(APCHSDFN)=$$VAL^XBDIQ1(9000011,APCHSDFN,.05) ;$P($G(^AUTNPOV(+$P(^AUPNPROB(APCHSDFN,0),U,5),0)),U,1)
. I APCHSPT(APCHSDFN)="" S APCHSPT(APCHSDFN)="???"
. S:$L(APCHSPT(APCHSDFN))>APCHSLEN APCHSLEN=$L(APCHSPT(APCHSDFN))
. Q
Q
;
APCHS40 ; IHS/CMI/LAB -- SUMMARY PRODUCTION COMPONENTS ;
+1 ;;2.0;IHS PCC SUITE;**5,6,7,11,16**;MAY 14, 2009;Build 9
+2 ;
+3 ;cmi/anch/maw 8/27/2007 code set versioning in PROBASCH
+4 ;
PROBA ; ************ ALLERGY PROB * 9000011 *********
+1 ; for PROBLEM LIST codes only!
+2 IF '$DATA(^AUPNPROB("AC",APCHSPAT))
XECUTE APCHSCKP
IF $DATA(APCHSQIT)
GOTO PROBAX
IF 'APCHSNPG
WRITE !
XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
IF 'APCHSNPG
XECUTE APCHSBRK
WRITE !
DO PROBADNR
DO ALR
QUIT
+3 KILL APCHSPT
SET (APCHSFND,APCHSLEN)=0
+4 SET APCHSDFN=""
FOR APCHSQ=0:0
SET APCHSDFN=$ORDER(^AUPNPROB("AC",APCHSPAT,APCHSDFN))
IF 'APCHSDFN
QUIT
IF $DATA(^AUPNPROB(APCHSDFN,0))
IF $PIECE(^AUPNPROB(APCHSDFN,0),U,12)'="D"
DO PROBASCH
+5 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
GOTO PROBAX
IF 'APCHSNPG
WRITE !
XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
IF 'APCHSNPG
XECUTE APCHSBRK
+6 WRITE !
+7 IF 'APCHSFND
DO PROBADNR
DO ALR
GOTO PROBAX
+8 SET APCHSDFN=""
FOR APCHSQ=0:0
SET APCHSDFN=$ORDER(APCHSPT(APCHSDFN))
IF 'APCHSDFN
QUIT
DO PROBADSP
ALR ;
+1 ;get date last reviewed and display
+2 SET APCHSX=$$LASTALR^APCLAPI6(APCHSPAT,,DT,"A")
+3 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+4 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),!
+5 SET APCHSX=$$LASTALU^APCLAPI6(APCHSPAT,,DT,"A")
+6 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+7 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),!
+8 SET APCHSX=$$LASTNAA^APCLAPI6(APCHSPAT,,DT,"A")
+9 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+10 ;I '$$ANYACTA^APCDAALG(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),!
+11 WRITE "No Active Allergies documented On: ",?36,$$FMTE^XLFDT($PIECE(APCHSX,U,1))
WRITE ?51,"By: ",?56,$EXTRACT($SELECT($PIECE(APCHSX,U,3):$PIECE($GET(^VA(200,$PIECE(APCHSX,U,3),0)),U),1:""),1,22),!
+12 ;get date last reviewed and display
+13 SET APCHSX=$$LASTPLR^APCLAPI6(APCHSPAT,,DT,"A")
+14 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+15 WRITE !,"Problem 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),!
+16 SET APCHSX=$$LASTPLU^APCLAPI6(APCHSPAT,,DT,"A")
+17 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+18 WRITE "Problem 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),!
+19 SET APCHSX=$$LASTNAP^APCLAPI6(APCHSPAT,,DT,"A")
+20 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+21 ;I '$$ANYACTP^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),!
+22 WRITE "No Active Problems Documented On: ",?36,$$FMTE^XLFDT($PIECE(APCHSX,U,1))
WRITE ?51,"By: ",$EXTRACT($SELECT($PIECE(APCHSX,U,3):$PIECE($GET(^VA(200,$PIECE(APCHSX,U,3),0)),U),1:""),1,25),!
PROBAX ;
+1 KILL APCHSPT,APCHSFND,APCHSDFN,APCHSLEN,APCHSDAT,APCHSNKA
+2 QUIT
+3 ;
PROBASCH ;active problem search
+1 ;S APCHSP=$P(^ICD9(+^AUPNPROB(APCHSDFN,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(APCHSDFN,0),0),U,2)
DO PROBACHK
IF $TEST
DO PROBALLG
+3 QUIT
PROBACHK ;checking for allergy codes
+1 SET APCHSNKA=0
+2 ;IHS/CMI/LAB - no narr
IF $PIECE(^AUPNPROB(APCHSDFN,0),U,5)=""
QUIT
+3 SET APCHSNKA=0
+4 IF $$ICD^ATXAPI(+^AUPNPROB(APCHSDFN,0),$ORDER(^ATXAX("B","APCH ALLERGY DX CODES",0)),9)
QUIT
+5 ;I APCHSP="692.3" Q
+6 ;I APCHSP="693.0" Q
+7 ;I APCHSP="995.0" Q
+8 ;I APCHSP="995.2" Q
+9 ;I (+APCHSP'<999.4),(+APCHSP'>999.89) Q
+10 ;I APCHSP?1"V14."1E Q
+11 ;I APCHSP="692.5" Q
+12 ;I APCHSP="693.1" Q
+13 ;I APCHSP="V15.0" Q
+14 ;I APCHSP["V15.0" Q
+15 ;I $E(APCHSP,1,3)=692,APCHSP'="692.9" Q
+16 ;I APCHSP="693.8" Q
+17 ;I APCHSP="693.9" Q
+18 ;I APCHSP="989.5" Q
+19 ;I APCHSP="989.82" Q
+20 ;I APCHSP="995.3" Q
+21 ;I APCHSP["995.2" Q
+22 ;S N=$P(^AUTNPOV($P(^AUPNPROB(APCHSDFN,0),U,5),0),U) I APCHSP="799.9"!(APCHSP="V82.9"),N["NO KNOWN ALLERG"!(N["NKA")!(N["NKDA")!(N["NO KNOWN DRUG ALLERG") S APCHSNKA=1 Q
+23 SET N=$$VAL^XBDIQ1(9000011,APCHSDFN,.05)
IF N["NO KNOWN ALLERG"!(N["NKA")!(N["NKDA")!(N["NO KNOWN DRUG ALLERG")
SET APCHSNKA=1
QUIT
+24 ;I APCHSP="799.9",$P(^AUTNPOV($P(^AUPNPROB(APCHSDFN,0),U,5),0),U,1)["NO KNOWN ALLERG"!($P(^AUTNPOV($P(^AUPNPROB(APCHSDFN,0),U,5),0),U,1)["NKA")!($P(^AUTNPOV($P(^AUPNPROB(APCHSDFN,0),U,5),0),U)["NKDA") S APCHSNKA=1 Q
+25 QUIT
+26 ;
PROBADSP ;display allergies
+1 ; center recorded allergies
IF $LENGTH(APCHSPT(APCHSDFN))<APCHSLEN
SET APCHSL1=$LENGTH(APCHSPT(APCHSDFN))/2
SET APCHSL1=(APCHSLEN/2)-APCHSL1
+2 WRITE ?((IOM-APCHSLEN-12)/2),"***** "
+3 WRITE ?((IOM-APCHSLEN)/2)+$GET(APCHSL1),APCHSPT(APCHSDFN)
+4 WRITE ?((IOM+APCHSLEN)/2)," *****",!
+5 KILL APCHSL1
+6 QUIT
+7 ;
PROBADNR ;display "NONE RECORDED", if no allergies recorded
+1 WRITE ?((IOM-13-12)/2),"***** ",?((IOM-13)/2),"NONE RECORDED",?((IOM+13)/2)," *****",!
+2 QUIT
+3 ;
PROBALLG ;if allergy
+1 SET APCHSFND=1
+2 IF APCHSNKA
Begin DoDot:1
+3 SET Y=$PIECE(^AUPNPROB(APCHSDFN,0),U,8)
XECUTE APCHSCVD
SET APCHSDAT=Y
+4 SET APCHSPT(APCHSDFN)="NO ALLERGY NOTED ON "_APCHSDAT_" ("_$$VAL^XBDIQ1(9000011,APCHSDFN,.05)_")"
+5 IF $LENGTH($PIECE(APCHSPT(APCHSDFN),U))>APCHSLEN
SET APCHSLEN=$LENGTH($PIECE(APCHSPT(APCHSDFN),U))
+6 QUIT
End DoDot:1
IF 1
+7 IF '$TEST
Begin DoDot:1
+8 ;Q:$P(^AUPNPROB(APCHSDFN,0),U,5)="" ;IHS/CMI/LAB - added this to prevent subscript
+9 ;$P($G(^AUTNPOV(+$P(^AUPNPROB(APCHSDFN,0),U,5),0)),U,1)
SET APCHSPT(APCHSDFN)=$$VAL^XBDIQ1(9000011,APCHSDFN,.05)
+10 IF APCHSPT(APCHSDFN)=""
SET APCHSPT(APCHSDFN)="???"
+11 IF $LENGTH(APCHSPT(APCHSDFN))>APCHSLEN
SET APCHSLEN=$LENGTH(APCHSPT(APCHSDFN))
+12 QUIT
End DoDot:1
+13 QUIT
+14 ;
