BSDX41C ; IHS/OIT/HMW/MSC/SAT - WINDOWS SCHEDULING RPCS ;
;;3.0;IHS WINDOWS SCHEDULING;;DEC 09, 2010
;
ALLRG ;EP; -- call to adverse reation/allergy component
NEW APCHGMTS,GMTSNPG,GMTSLPG,GMTSLO,GMTSTYP
NEW GMTSE,GMTSEGH,GMTSEGL,GMTSEGN,GMTSSC,GMTSDTM
NEW GMTS,GMTSLCMP ;variables not set here but left over after call
S DFN=APCHSPAT,APCHGMTS=1
S GMTSNPG=0,GMTSLPG=0,GMTSLO=3,GMTSTYP=0
S GMTSE=1,GMTSEGH="***** ADVERSE REACTIONS/ALLERGIES *****"
S GMTSSC="",GMTSDTM="",GMTSEGL="",GMTSEGN=1
D ALLRG1
Q
;
; External References
; DBIA 10096 ^%ZOSF("TEST"
; DBIA 10035 ^DPT(
; DBIA 905 ^GMR(120.8
; DBIA 2056 $$GET1^DIQ (file #120.86 and #200)
; DBIA 10011 ^DIWP
; DBIA 10099 EN1^GMRADPT
; DBIA 10060 ^VA(200,
; DBIA 3449 ^GMR(120.86,
;
ALLRG1 ; Allergies
N X,GMTSALAS,GMTSALAD,GMTSALAW,GMTSALAT,GMTSAV,GMTSAFN,GMRAL,GMTSAL
N GMTSALNM,GMTSCNT,GMTSEACT,GMTSLN,GMTSMECH,GMTSPRT,GMTSTY,CC,C,KK
N ALLRG,TITLE,JJ K GMTSA S (SEQ,ALLRG)=0,TITLE="ALLERGY/ADVERSE REACTION (AR)"
S X="GMRADPT" X ^%ZOSF("TEST")
I $T D Q:$D(GMTSQIT)
. D GETALLRG D:ALLRG TITLE,ALLRGP D:'ALLRG&($L($G(GMTSALAS))) TITLE,NKA
I 'ALLRG,'$L($G(GMTSALAS)) D
. I $D(GMTSPNF)&('ALLRG) S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)="Unknown, please evaluate"_$C(30)
K ALL,CC,CCC,CD,DIWF,DIWL,DIWR,GMTSALF,GMTSALNM,GMTSNODE,GMTSPRT,I,II,JJ,KK,L,M,MX,N,Z,X,SEQ,GMTSA,ALLRG,TITLE,GMRA,GMRAL,GMTSEACT,GMTSMECH,GMTSTY,GMTSPFN,GMTSAL,GMTSCNT,GMTSLN,ODT
Q
ALLRGP ; Allergy Print
S II="" F S II=$O(GMTSAL(II)) Q:II']"" I $O(GMTSAL(II,""))]"" D
. S BSDXI=BSDXI+1
. S ^BSDXTMP($J,BSDXI)=""_$C(30) S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=" "_$S(II="D":"Drug:",II="DF":"Drug/Food:",II="DFO":"Drug/Food/Other:",II="DO":"Drug/Other:",II="F":"Food:",II="FO":"Food/Other:",II="O":"Other:",1:II_":")_$C(30)
. S JJ="" F S JJ=$O(GMTSAL(II,JJ)) Q:JJ="" D
.. N WKK S KK="" F S KK=$O(GMTSAL(II,JJ,KK)) Q:KK="" D
... S L=0 F S L=$O(GMTSAL(II,JJ,KK,L)) Q:'L S BSDXTMP=" "_JJ_": " S:$L(KK)>30 WKK=KK,WKK=$$WRAP^GMTSORC(WKK,30) S BSDXTMP=BSDXTMP_$$FILL^BSDX41(24-$L(BSDXTMP))_$S($L(KK)>30:$P(WKK,"|"),1:KK) D
.... I $G(GMTSAV)=1 S BSDXTMP=BSDXTMP_" (AV"
.... E S BSDXTMP=BSDXTMP_$S($P(GMTSAL(II,JJ,KK,L),U,5)=1:" (V",$P(GMTSAL(II,JJ,KK,L),U,5)=0:" (NV",1:"")
.... S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=BSDXTMP_$S($G(GMTSALNM)="":")",$P($G(^GMR(120.8,GMTSALNM,0)),U,6)="h":"/Historical)",$P($G(^(0)),U,6)="o":"/Observed)",1:")")_$C(30)
.... I $L($P($G(WKK),"|",2)) S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=$P(WKK,"|",2)_$C(30)
.... S (M,MX,ALL)=0 F S M=$O(GMTSAL(II,JJ,KK,L,"S",M)) Q:M="" D Q:$D(GMTSQIT)
..... I ALL=0 S BSDXTMP=$$FILL^BSDX41(26)
..... S MX=MX+1
..... I MX>1 S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=BSDXTMP_", "_$C(30)
..... S N=$P(GMTSAL(II,JJ,KK,L,"S",M),";")
..... S ALL=1 I (74)'>($X+$L(N)) S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=N_$C(30) Q
..... S ALL=1 S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=N_$C(30)
.... D SIGBLK($P($G(GMTSAFN),U,5))
.... S BSDXTMP=$$FILL^BSDX41(23)_"Date/Time: " S ODT=$P($G(GMTSAFN),U,4) S X=ODT D REGDTM4^GMTSU S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=BSDXTMP_X_$C(30)
....I $G(GMTSALNM)'="" S CC="" F S CC=$O(^GMR(120.8,GMTSALNM,26,"B",CC)) Q:CC="" S BSDXTMP=$$FILL^BSDXTMP(23)_"Comments at: " S X=CC D REGDTM4^GMTSU S CD=X S CCC=0 F S CCC=$O(^GMR(120.8,$G(GMTSALNM),26,"B",CC,CCC)) Q:'CCC D TEXT
Q
NKA ; No known allergies
I $L($G(GMTSALAS))!($L($G(GMTSALAD))) S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=$C(30)
I $L($G(GMTSALAS)) S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=$$FILL^BSDX41(21)_$G(GMTSALAS)_$C(30)
I $L($G(GMTSALAS))!($L($G(GMTSALAD)))!($L($G(GMTSALAW))) S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=$$FILL^BSDX41(23)_"Assessment date: "_$G(GMTSALAD)_$C(30)
I $L($G(GMTSALAW)) S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=$$FILL^BSDX41(27)_"Assessed by: "_GMTSALAW_$C(30)
I $L($G(GMTSALAW))&($L($G(GMTSALAT))) S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=$$FILL^BSDX41(33)_"Title: "_GMTSALAT_$C(30)
Q
GETALLRG ; Get Allergies
S GMRA="0^0^111" D EN1^GMRADPT I GMRAL="" S ALLRG=0 Q
I +($G(DFN))>0,+($G(GMRAL))=0 D ALLAS S ALLRG=0 Q
I $D(GMRAL)>9 D
. S I=0 F GMTSCNT=1:1 S I=$O(GMRAL(I)) Q:'I D
.. S GMTSTY=$P(GMRAL(I),U,7) Q:GMTSTY']""
.. S GMTSEACT=$P(GMRAL(I),U,2) Q:GMTSEACT']""
.. S GMTSMECH=$P($P(GMRAL(I),U,8),";")
.. S:GMTSMECH']"" GMTSMECH="UNKNOWN"
.. S GMTSAL(GMTSTY,GMTSMECH,GMTSEACT,GMTSCNT)=I_"^"_GMRAL(I)
.. S JJ=0 F S JJ=$O(GMRAL(I,"S",JJ)) Q:'JJ S GMTSAL(GMTSTY,GMTSMECH,GMTSEACT,GMTSCNT,"S",JJ)=GMRAL(I,"S",JJ)
.. S ALLRG=1
Q
ALLAS ; Allergy Assessment
N X,GMTSALG1,GMTSALG2,GMTSALG3,GMTSAU S (GMTSALAS,GMTSALAD,GMTSALAW)="" S GMTSALAS="No known allergies"
S GMTSALAD=$$GET1^DIQ(120.86,+($G(DFN)),3,"I",,"GMTSALG2") S:$D(GMTSALG2) GMTSALAD="" S:+GMTSALAD=0 GMTSALAD=""
I +GMTSALAD>0 S X=GMTSALAD D REGDT4^GMTSU S GMTSALAD=X
S GMTSAU=$$GET1^DIQ(120.86,+($G(DFN)),2,"I")
S GMTSALAW=$$GET1^DIQ(200,(+GMTSAU_","),.01,"E",,"GMTSALG3")
S GMTSALAT=$$GET1^DIQ(200,(+GMTSAU_","),20.3)
S:$D(GMTSALG3) (GMTSALAW,GMTSALAT)=""
Q
AUTOV ; Autoverify
S GMTSAV=0,GMTSALNM=$P(GMTSAL(II,JJ,KK,L),U),GMTSAFN=$G(^GMR(120.8,GMTSALNM,0))
I $P(GMTSAFN,U,18)="",$P(GMTSAFN,U,16)=1 S GMTSAV=1
Q
TITLE ; Print title
D CKP^GMTSUP Q:$D(GMTSQIT)
I $D(GMTSPNF) S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=$$FILL^BSDX41(20)_TITLE_$C(30)
E S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=$$FILL^BSDX41(20)_"Title: "_TITLE_$C(30)
Q
TEXT ; Setup for print of allergy comments
S BSDXTMP=BSDXTMP_$$FILL^BSDX41(30-$L(BSDXTMP))_CD Q:$D(GMTSQIT)
K ^UTILITY($J,"W") S GMTSLN=0 F S GMTSLN=$O(^GMR(120.8,GMTSALNM,26,CCC,2,GMTSLN)) Q:'GMTSLN S GMTSPRT=^GMR(120.8,GMTSALNM,26,CCC,2,GMTSLN,0) D FORMAT
I $D(^UTILITY($J,"W")) F GMTSLN=1:1:^UTILITY($J,"W",DIWL) D LINE Q:$D(GMTSQIT)
K ^UTILITY($J,"W")
Q:'GMTSLN
S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=BSDXTMP_$C(30)
Q
FORMAT ; Formats each line
S DIWL=3,DIWR=80,DIWF="C58",X=GMTSPRT D ^DIWP
Q
LINE ; Writes formatted lines of text
Q:$D(GMTSQIT) S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=$$FILL^BSDX41(23)_^UTILITY($J,"W",DIWL,GMTSLN,0)_$C(30)
Q
SIGBLK(GMTSALF) ; Signature block
Q:+GMTSALF'>0 N GMTSSB,GMTSST,GMTSSN S GMTSSB=$$GET1^DIQ(200,(+GMTSALF_","),20.2),GMTSST=$$GET1^DIQ(200,(+GMTSALF_","),20.3),GMTSSN=$$GET1^DIQ(200,(+GMTSALF_","),.01)
S BSDXDSP=$C(10,13)_$C(10,13)_$$FILL^BSDX41(23)_"Originator: "_$S(GMTSSB'="":GMTSSB,1:GMTSSN)
I $L(GMTSST) S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=$C(30) S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=$$FILL^BSDX41(23)_"Title: "_GMTSST_$C(30)
Q
;
PROBA ; ************ ALLERGY PROB * 9000011 *********
; for PROBLEM LIST codes only!
I '$D(^AUPNPROB("AC",APCHSPAT)) X APCHSCKP G:$D(APCHSQIT) PROBAX I 'APCHSNPG S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=$C(30) X APCHSCKP Q:$D(APCHSQIT) X:'APCHSNPG APCHSBRK S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=$C(30) D PROBADNR Q
K APCHSPT S (APCHSFND,APCHSLEN)=0
S APCHSDFN="" F APCHSQ=0:0 S APCHSDFN=$O(^AUPNPROB("AC",APCHSPAT,APCHSDFN)) Q:'APCHSDFN D PROBASCH
X APCHSCKP G:$D(APCHSQIT) PROBAX I 'APCHSNPG S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=$C(30) X APCHSCKP Q:$D(APCHSQIT) X:'APCHSNPG APCHSBRK
S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=$C(30)
I 'APCHSFND D PROBADNR G PROBAX
S APCHSDFN="" F APCHSQ=0:0 S APCHSDFN=$O(APCHSPT(APCHSDFN)) Q:'APCHSDFN D PROBADSP
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^ICDCODE(+^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
Q:$P(^AUPNPROB(APCHSDFN,0),U,5)="" ;IHS/CMI/LAB - no narr
S APCHSNKA=0
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
;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
S BSDXDSP=$$FILL^BSDX41((IOM-APCHSLEN-12)/2)_"***** "
S BSDXDSP=BSDXDSP_$$FILL^BSDX41(((IOM-APCHSLEN)/2)-$L(BSDXDSP))_+$G(APCHSL1)_APCHSPT(APCHSDFN)
S BSDXDSP=BSDXDSP_$$FILL^BSDX41(((IOM+APCHSLEN)/2))_" *****"
S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=BSDXDSP_$C(30)
K APCHSL1
Q
;
PROBADNR ;display "NONE RECORDED", if no allergies recorded
S BSDXDSP=$$FILL^BSDX41((IOM-13-12)/2)_"***** "
S BSDXDSP=BSDXDSP_$$FILL^BSDX41(((IOM-13)/2)-$L(BSDXDSP))_"NONE RECORDED"
S BSDXDSP=BSDXDSP_$$FILL^BSDX41(((IOM+13)/2)-$L(BSDXDSP))_" *****"
S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=BSDXDSP_$C(30)
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
. 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)=$P(^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
;
BSDX41C ; IHS/OIT/HMW/MSC/SAT - WINDOWS SCHEDULING RPCS ;
+1 ;;3.0;IHS WINDOWS SCHEDULING;;DEC 09, 2010
+2 ;
ALLRG ;EP; -- call to adverse reation/allergy component
+1 NEW APCHGMTS,GMTSNPG,GMTSLPG,GMTSLO,GMTSTYP
+2 NEW GMTSE,GMTSEGH,GMTSEGL,GMTSEGN,GMTSSC,GMTSDTM
+3 ;variables not set here but left over after call
NEW GMTS,GMTSLCMP
+4 SET DFN=APCHSPAT
SET APCHGMTS=1
+5 SET GMTSNPG=0
SET GMTSLPG=0
SET GMTSLO=3
SET GMTSTYP=0
+6 SET GMTSE=1
SET GMTSEGH="***** ADVERSE REACTIONS/ALLERGIES *****"
+7 SET GMTSSC=""
SET GMTSDTM=""
SET GMTSEGL=""
SET GMTSEGN=1
+8 DO ALLRG1
+9 QUIT
+10 ;
+11 ; External References
+12 ; DBIA 10096 ^%ZOSF("TEST"
+13 ; DBIA 10035 ^DPT(
+14 ; DBIA 905 ^GMR(120.8
+15 ; DBIA 2056 $$GET1^DIQ (file #120.86 and #200)
+16 ; DBIA 10011 ^DIWP
+17 ; DBIA 10099 EN1^GMRADPT
+18 ; DBIA 10060 ^VA(200,
+19 ; DBIA 3449 ^GMR(120.86,
+20 ;
ALLRG1 ; Allergies
+1 NEW X,GMTSALAS,GMTSALAD,GMTSALAW,GMTSALAT,GMTSAV,GMTSAFN,GMRAL,GMTSAL
+2 NEW GMTSALNM,GMTSCNT,GMTSEACT,GMTSLN,GMTSMECH,GMTSPRT,GMTSTY,CC,C,KK
+3 NEW ALLRG,TITLE,JJ
KILL GMTSA
SET (SEQ,ALLRG)=0
SET TITLE="ALLERGY/ADVERSE REACTION (AR)"
+4 SET X="GMRADPT"
XECUTE ^%ZOSF("TEST")
+5 IF $TEST
Begin DoDot:1
+6 DO GETALLRG
IF ALLRG
DO TITLE
DO ALLRGP
IF 'ALLRG&($LENGTH($GET(GMTSALAS)))
DO TITLE
DO NKA
End DoDot:1
IF $DATA(GMTSQIT)
QUIT
+7 IF 'ALLRG
IF '$LENGTH($GET(GMTSALAS))
Begin DoDot:1
+8 IF $DATA(GMTSPNF)&('ALLRG)
SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)="Unknown, please evaluate"_$CHAR(30)
End DoDot:1
+9 KILL ALL,CC,CCC,CD,DIWF,DIWL,DIWR,GMTSALF,GMTSALNM,GMTSNODE,GMTSPRT,I,II,JJ,KK,L,M,MX,N,Z,X,SEQ,GMTSA,ALLRG,TITLE,GMRA,GMRAL,GMTSEACT,GMTSMECH,GMTSTY,GMTSPFN,GMTSAL,GMTSCNT,GMTSLN,ODT
+10 QUIT
ALLRGP ; Allergy Print
+1 SET II=""
FOR
SET II=$ORDER(GMTSAL(II))
IF II']""
QUIT
IF $ORDER(GMTSAL(II,""))]""
Begin DoDot:1
+2 SET BSDXI=BSDXI+1
+3 SET ^BSDXTMP($JOB,BSDXI)=""_$CHAR(30)
SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=" "_$SELECT(II="D":"Drug:",II="DF":"Drug/Food:",II="DFO":"Drug/Food/Other:",II="DO":"Drug/Other:",II="F":"Food:",II="FO":"Food/Other:",II="O":"Other:",1:II_":")_$CHAR(30)
+4 SET JJ=""
FOR
SET JJ=$ORDER(GMTSAL(II,JJ))
IF JJ=""
QUIT
Begin DoDot:2
+5 NEW WKK
SET KK=""
FOR
SET KK=$ORDER(GMTSAL(II,JJ,KK))
IF KK=""
QUIT
Begin DoDot:3
+6 SET L=0
FOR
SET L=$ORDER(GMTSAL(II,JJ,KK,L))
IF 'L
QUIT
SET BSDXTMP=" "_JJ_": "
IF $LENGTH(KK)>30
SET WKK=KK
SET WKK=$$WRAP^GMTSORC(WKK,30)
SET BSDXTMP=BSDXTMP_$$FILL^BSDX41(24-$LENGTH(BSDXTMP))_$SELECT($LENGTH(KK)>30:$PIECE(WKK,"|"),1:KK)
Begin DoDot:4
+7 IF $GET(GMTSAV)=1
SET BSDXTMP=BSDXTMP_" (AV"
+8 IF '$TEST
SET BSDXTMP=BSDXTMP_$SELECT($PIECE(GMTSAL(II,JJ,KK,L),U,5)=1:" (V",$PIECE(GMTSAL(II,JJ,KK,L),U,5)=0:" (NV",1:"")
+9 SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=BSDXTMP_$SELECT($GET(GMTSALNM)="":")",$PIECE($GET(^GMR(120.8,GMTSALNM,0)),U,6)="h":"/Historical)",$PIECE($GET(^(0)),U,6)="o":"/Observed)",1:")")_$CHAR(30)
+10 IF $LENGTH($PIECE($GET(WKK),"|",2))
SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=$PIECE(WKK,"|",2)_$CHAR(30)
+11 SET (M,MX,ALL)=0
FOR
SET M=$ORDER(GMTSAL(II,JJ,KK,L,"S",M))
IF M=""
QUIT
Begin DoDot:5
+12 IF ALL=0
SET BSDXTMP=$$FILL^BSDX41(26)
+13 SET MX=MX+1
+14 IF MX>1
SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=BSDXTMP_", "_$CHAR(30)
+15 SET N=$PIECE(GMTSAL(II,JJ,KK,L,"S",M),";")
+16 SET ALL=1
IF (74)'>($X+$LENGTH(N))
SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=N_$CHAR(30)
QUIT
+17 SET ALL=1
SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=N_$CHAR(30)
End DoDot:5
IF $DATA(GMTSQIT)
QUIT
+18 DO SIGBLK($PIECE($GET(GMTSAFN),U,5))
+19 SET BSDXTMP=$$FILL^BSDX41(23)_"Date/Time: "
SET ODT=$PIECE($GET(GMTSAFN),U,4)
SET X=ODT
DO REGDTM4^GMTSU
SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=BSDXTMP_X_$CHAR(30)
+20 IF $GET(GMTSALNM)'=""
SET CC=""
FOR
SET CC=$ORDER(^GMR(120.8,GMTSALNM,26,"B",CC))
IF CC=""
QUIT
SET BSDXTMP=$$FILL^BSDXTMP(23)_"Comments at: "
SET X=CC
DO REGDTM4^GMTSU
SET CD=X
SET CCC=0
FOR
SET CCC=$ORDER(^GMR(120.8,$GET(GMTSALNM),26,"B",CC,CCC))
IF 'CCC
QUIT
DO TEXT
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+21 QUIT
NKA ; No known allergies
+1 IF $LENGTH($GET(GMTSALAS))!($LENGTH($GET(GMTSALAD)))
SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=$CHAR(30)
+2 IF $LENGTH($GET(GMTSALAS))
SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=$$FILL^BSDX41(21)_$GET(GMTSALAS)_$CHAR(30)
+3 IF $LENGTH($GET(GMTSALAS))!($LENGTH($GET(GMTSALAD)))!($LENGTH($GET(GMTSALAW)))
SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=$$FILL^BSDX41(23)_"Assessment date: "_$GET(GMTSALAD)_$CHAR(30)
+4 IF $LENGTH($GET(GMTSALAW))
SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=$$FILL^BSDX41(27)_"Assessed by: "_GMTSALAW_$CHAR(30)
+5 IF $LENGTH($GET(GMTSALAW))&($LENGTH($GET(GMTSALAT)))
SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=$$FILL^BSDX41(33)_"Title: "_GMTSALAT_$CHAR(30)
+6 QUIT
GETALLRG ; Get Allergies
+1 SET GMRA="0^0^111"
DO EN1^GMRADPT
IF GMRAL=""
SET ALLRG=0
QUIT
+2 IF +($GET(DFN))>0
IF +($GET(GMRAL))=0
DO ALLAS
SET ALLRG=0
QUIT
+3 IF $DATA(GMRAL)>9
Begin DoDot:1
+4 SET I=0
FOR GMTSCNT=1:1
SET I=$ORDER(GMRAL(I))
IF 'I
QUIT
Begin DoDot:2
+5 SET GMTSTY=$PIECE(GMRAL(I),U,7)
IF GMTSTY']""
QUIT
+6 SET GMTSEACT=$PIECE(GMRAL(I),U,2)
IF GMTSEACT']""
QUIT
+7 SET GMTSMECH=$PIECE($PIECE(GMRAL(I),U,8),";")
+8 IF GMTSMECH']""
SET GMTSMECH="UNKNOWN"
+9 SET GMTSAL(GMTSTY,GMTSMECH,GMTSEACT,GMTSCNT)=I_"^"_GMRAL(I)
+10 SET JJ=0
FOR
SET JJ=$ORDER(GMRAL(I,"S",JJ))
IF 'JJ
QUIT
SET GMTSAL(GMTSTY,GMTSMECH,GMTSEACT,GMTSCNT,"S",JJ)=GMRAL(I,"S",JJ)
+11 SET ALLRG=1
End DoDot:2
End DoDot:1
+12 QUIT
ALLAS ; Allergy Assessment
+1 NEW X,GMTSALG1,GMTSALG2,GMTSALG3,GMTSAU
SET (GMTSALAS,GMTSALAD,GMTSALAW)=""
SET GMTSALAS="No known allergies"
+2 SET GMTSALAD=$$GET1^DIQ(120.86,+($GET(DFN)),3,"I",,"GMTSALG2")
IF $DATA(GMTSALG2)
SET GMTSALAD=""
IF +GMTSALAD=0
SET GMTSALAD=""
+3 IF +GMTSALAD>0
SET X=GMTSALAD
DO REGDT4^GMTSU
SET GMTSALAD=X
+4 SET GMTSAU=$$GET1^DIQ(120.86,+($GET(DFN)),2,"I")
+5 SET GMTSALAW=$$GET1^DIQ(200,(+GMTSAU_","),.01,"E",,"GMTSALG3")
+6 SET GMTSALAT=$$GET1^DIQ(200,(+GMTSAU_","),20.3)
+7 IF $DATA(GMTSALG3)
SET (GMTSALAW,GMTSALAT)=""
+8 QUIT
AUTOV ; Autoverify
+1 SET GMTSAV=0
SET GMTSALNM=$PIECE(GMTSAL(II,JJ,KK,L),U)
SET GMTSAFN=$GET(^GMR(120.8,GMTSALNM,0))
+2 IF $PIECE(GMTSAFN,U,18)=""
IF $PIECE(GMTSAFN,U,16)=1
SET GMTSAV=1
+3 QUIT
TITLE ; Print title
+1 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+2 IF $DATA(GMTSPNF)
SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=$$FILL^BSDX41(20)_TITLE_$CHAR(30)
+3 IF '$TEST
SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=$$FILL^BSDX41(20)_"Title: "_TITLE_$CHAR(30)
+4 QUIT
TEXT ; Setup for print of allergy comments
+1 SET BSDXTMP=BSDXTMP_$$FILL^BSDX41(30-$LENGTH(BSDXTMP))_CD
IF $DATA(GMTSQIT)
QUIT
+2 KILL ^UTILITY($JOB,"W")
SET GMTSLN=0
FOR
SET GMTSLN=$ORDER(^GMR(120.8,GMTSALNM,26,CCC,2,GMTSLN))
IF 'GMTSLN
QUIT
SET GMTSPRT=^GMR(120.8,GMTSALNM,26,CCC,2,GMTSLN,0)
DO FORMAT
+3 IF $DATA(^UTILITY($JOB,"W"))
FOR GMTSLN=1:1:^UTILITY($JOB,"W",DIWL)
DO LINE
IF $DATA(GMTSQIT)
QUIT
+4 KILL ^UTILITY($JOB,"W")
+5 IF 'GMTSLN
QUIT
+6 SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=BSDXTMP_$CHAR(30)
+7 QUIT
FORMAT ; Formats each line
+1 SET DIWL=3
SET DIWR=80
SET DIWF="C58"
SET X=GMTSPRT
DO ^DIWP
+2 QUIT
LINE ; Writes formatted lines of text
+1 IF $DATA(GMTSQIT)
QUIT
SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=$$FILL^BSDX41(23)_^UTILITY($JOB,"W",DIWL,GMTSLN,0)_$CHAR(30)
+2 QUIT
SIGBLK(GMTSALF) ; Signature block
+1 IF +GMTSALF'>0
QUIT
NEW GMTSSB,GMTSST,GMTSSN
SET GMTSSB=$$GET1^DIQ(200,(+GMTSALF_","),20.2)
SET GMTSST=$$GET1^DIQ(200,(+GMTSALF_","),20.3)
SET GMTSSN=$$GET1^DIQ(200,(+GMTSALF_","),.01)
+2 SET BSDXDSP=$CHAR(10,13)_$CHAR(10,13)_$$FILL^BSDX41(23)_"Originator: "_$SELECT(GMTSSB'="":GMTSSB,1:GMTSSN)
+3 IF $LENGTH(GMTSST)
SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=$CHAR(30)
SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=$$FILL^BSDX41(23)_"Title: "_GMTSST_$CHAR(30)
+4 QUIT
+5 ;
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
SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=$CHAR(30)
XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
IF 'APCHSNPG
XECUTE APCHSBRK
SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=$CHAR(30)
DO PROBADNR
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
DO PROBASCH
+5 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
GOTO PROBAX
IF 'APCHSNPG
SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=$CHAR(30)
XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
IF 'APCHSNPG
XECUTE APCHSBRK
+6 SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=$CHAR(30)
+7 IF 'APCHSFND
DO PROBADNR
GOTO PROBAX
+8 SET APCHSDFN=""
FOR APCHSQ=0:0
SET APCHSDFN=$ORDER(APCHSPT(APCHSDFN))
IF 'APCHSDFN
QUIT
DO PROBADSP
PROBAX KILL APCHSPT,APCHSFND,APCHSDFN,APCHSLEN,APCHSDAT,APCHSNKA
+1 QUIT
+2 ;
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^ICDCODE(+^AUPNPROB(APCHSDFN,0),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(APCHSDFN,0),U,5)=""
QUIT
+2 SET APCHSNKA=0
+3 IF APCHSP="692.3"
QUIT
+4 IF APCHSP="693.0"
QUIT
+5 IF APCHSP="995.0"
QUIT
+6 IF APCHSP="995.2"
QUIT
+7 IF (+APCHSP'<999.4)
IF (+APCHSP'>999.89)
QUIT
+8 IF APCHSP?1"V14."1E
QUIT
+9 IF APCHSP="692.5"
QUIT
+10 IF APCHSP="693.1"
QUIT
+11 ;I APCHSP="V15.0" Q
+12 IF APCHSP["V15.0"
QUIT
+13 IF $EXTRACT(APCHSP,1,3)=692
IF APCHSP'="692.9"
QUIT
+14 IF APCHSP="693.8"
QUIT
+15 IF APCHSP="693.9"
QUIT
+16 IF APCHSP="989.5"
QUIT
+17 IF APCHSP="989.82"
QUIT
+18 IF APCHSP="995.3"
QUIT
+19 IF APCHSP["995.2"
QUIT
+20 SET N=$PIECE(^AUTNPOV($PIECE(^AUPNPROB(APCHSDFN,0),U,5),0),U)
IF APCHSP="799.9"!(APCHSP="V82.9")
IF N["NO KNOWN ALLERG"!(N["NKA")!(N["NKDA")!(N["NO KNOWN DRUG ALLERG")
SET APCHSNKA=1
QUIT
+21 ;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
+22 QUIT
+23 ;
PROBADSP ;display allergies
+1 ; center recorded allergies
IF $LENGTH(APCHSPT(APCHSDFN))<APCHSLEN
SET APCHSL1=$LENGTH(APCHSPT(APCHSDFN))/2
SET APCHSL1=(APCHSLEN/2)-APCHSL1
+2 SET BSDXDSP=$$FILL^BSDX41((IOM-APCHSLEN-12)/2)_"***** "
+3 SET BSDXDSP=BSDXDSP_$$FILL^BSDX41(((IOM-APCHSLEN)/2)-$LENGTH(BSDXDSP))_+$GET(APCHSL1)_APCHSPT(APCHSDFN)
+4 SET BSDXDSP=BSDXDSP_$$FILL^BSDX41(((IOM+APCHSLEN)/2))_" *****"
+5 SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=BSDXDSP_$CHAR(30)
+6 KILL APCHSL1
+7 QUIT
+8 ;
PROBADNR ;display "NONE RECORDED", if no allergies recorded
+1 SET BSDXDSP=$$FILL^BSDX41((IOM-13-12)/2)_"***** "
+2 SET BSDXDSP=BSDXDSP_$$FILL^BSDX41(((IOM-13)/2)-$LENGTH(BSDXDSP))_"NONE RECORDED"
+3 SET BSDXDSP=BSDXDSP_$$FILL^BSDX41(((IOM+13)/2)-$LENGTH(BSDXDSP))_" *****"
+4 SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=BSDXDSP_$CHAR(30)
+5 QUIT
+6 ;
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
+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 SET APCHSPT(APCHSDFN)=$PIECE(^AUTNPOV(+$PIECE(^AUPNPROB(APCHSDFN,0),U,5),0),U,1)
+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 ;
