Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BSDX41C

BSDX41C.m

Go to the documentation of this file. 
  1. BSDX41C ; IHS/OIT/HMW/MSC/SAT - WINDOWS SCHEDULING RPCS ;
  1.  ;;3.0;IHS WINDOWS SCHEDULING;;DEC 09, 2010
  1.  ;                 
  1. ALLRG ;EP; -- call to adverse reation/allergy component
  1.  NEW APCHGMTS,GMTSNPG,GMTSLPG,GMTSLO,GMTSTYP
  1.  NEW GMTSE,GMTSEGH,GMTSEGL,GMTSEGN,GMTSSC,GMTSDTM
  1.  NEW GMTS,GMTSLCMP  ;variables not set here but left over after call
  1.  S DFN=APCHSPAT,APCHGMTS=1
  1.  S GMTSNPG=0,GMTSLPG=0,GMTSLO=3,GMTSTYP=0
  1.  S GMTSE=1,GMTSEGH="***** ADVERSE REACTIONS/ALLERGIES *****"
  1.  S GMTSSC="",GMTSDTM="",GMTSEGL="",GMTSEGN=1
  1.  D ALLRG1
  1.  Q
  1.  ;
  1.  ; External References
  1.  ;   DBIA 10096  ^%ZOSF("TEST"
  1.  ;   DBIA 10035  ^DPT(
  1.  ;   DBIA   905  ^GMR(120.8
  1.  ;   DBIA  2056  $$GET1^DIQ (file #120.86 and #200)
  1.  ;   DBIA 10011  ^DIWP
  1.  ;   DBIA 10099  EN1^GMRADPT 
  1.  ;   DBIA 10060  ^VA(200,
  1.  ;   DBIA  3449  ^GMR(120.86,
  1.  ;                   
  1. ALLRG1 ; Allergies
  1.  N X,GMTSALAS,GMTSALAD,GMTSALAW,GMTSALAT,GMTSAV,GMTSAFN,GMRAL,GMTSAL
  1.  N GMTSALNM,GMTSCNT,GMTSEACT,GMTSLN,GMTSMECH,GMTSPRT,GMTSTY,CC,C,KK
  1.  N ALLRG,TITLE,JJ K GMTSA S (SEQ,ALLRG)=0,TITLE="ALLERGY/ADVERSE REACTION (AR)"
  1.  S X="GMRADPT" X ^%ZOSF("TEST")
  1.  I $T D  Q:$D(GMTSQIT)
  1.  . D GETALLRG D:ALLRG TITLE,ALLRGP D:'ALLRG&($L($G(GMTSALAS))) TITLE,NKA
  1.  I 'ALLRG,'$L($G(GMTSALAS)) D
  1.  . I $D(GMTSPNF)&('ALLRG) S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)="Unknown, please evaluate"_$C(30)
  1.  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
  1.  Q
  1. ALLRGP ; Allergy Print
  1.  S II="" F  S II=$O(GMTSAL(II)) Q:II']""  I $O(GMTSAL(II,""))]"" D
  1.  . S BSDXI=BSDXI+1
  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)
  1.  . S JJ="" F  S JJ=$O(GMTSAL(II,JJ)) Q:JJ=""  D
  1.  .. N WKK S KK=""  F  S KK=$O(GMTSAL(II,JJ,KK)) Q:KK=""  D
  1.  ... 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
  1.  .... I $G(GMTSAV)=1 S BSDXTMP=BSDXTMP_" (AV"
  1.  .... 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:"")
  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)
  1.  .... I $L($P($G(WKK),"|",2)) S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=$P(WKK,"|",2)_$C(30)
  1.  .... S (M,MX,ALL)=0 F  S M=$O(GMTSAL(II,JJ,KK,L,"S",M)) Q:M=""  D  Q:$D(GMTSQIT)
  1.  ..... I ALL=0 S BSDXTMP=$$FILL^BSDX41(26)
  1.  ..... S MX=MX+1
  1.  ..... I MX>1 S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=BSDXTMP_", "_$C(30)
  1.  ..... S N=$P(GMTSAL(II,JJ,KK,L,"S",M),";")
  1.  ..... S ALL=1 I (74)'>($X+$L(N)) S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=N_$C(30) Q
  1.  ..... S ALL=1 S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=N_$C(30)
  1.  .... D SIGBLK($P($G(GMTSAFN),U,5))
  1.  .... 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)
  1.  ....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
  1.  Q
  1. NKA ; No known allergies
  1.  I $L($G(GMTSALAS))!($L($G(GMTSALAD))) S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=$C(30)
  1.  I $L($G(GMTSALAS)) S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=$$FILL^BSDX41(21)_$G(GMTSALAS)_$C(30)
  1.  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)
  1.  I $L($G(GMTSALAW)) S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=$$FILL^BSDX41(27)_"Assessed by:   "_GMTSALAW_$C(30)
  1.  I $L($G(GMTSALAW))&($L($G(GMTSALAT))) S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=$$FILL^BSDX41(33)_"Title:   "_GMTSALAT_$C(30)
  1.  Q
  1. GETALLRG ; Get Allergies
  1.  S GMRA="0^0^111" D EN1^GMRADPT I GMRAL="" S ALLRG=0 Q
  1.  I +($G(DFN))>0,+($G(GMRAL))=0 D ALLAS S ALLRG=0 Q
  1.  I $D(GMRAL)>9 D
  1.  . S I=0 F GMTSCNT=1:1 S I=$O(GMRAL(I)) Q:'I  D
  1.  .. S GMTSTY=$P(GMRAL(I),U,7) Q:GMTSTY']""
  1.  .. S GMTSEACT=$P(GMRAL(I),U,2) Q:GMTSEACT']""
  1.  .. S GMTSMECH=$P($P(GMRAL(I),U,8),";")
  1.  .. S:GMTSMECH']"" GMTSMECH="UNKNOWN"
  1.  .. S GMTSAL(GMTSTY,GMTSMECH,GMTSEACT,GMTSCNT)=I_"^"_GMRAL(I)
  1.  .. 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)
  1.  .. S ALLRG=1
  1.  Q
  1. ALLAS ; Allergy Assessment
  1.  N X,GMTSALG1,GMTSALG2,GMTSALG3,GMTSAU S (GMTSALAS,GMTSALAD,GMTSALAW)="" S GMTSALAS="No known allergies"
  1.  S GMTSALAD=$$GET1^DIQ(120.86,+($G(DFN)),3,"I",,"GMTSALG2") S:$D(GMTSALG2) GMTSALAD="" S:+GMTSALAD=0 GMTSALAD=""
  1.  I +GMTSALAD>0 S X=GMTSALAD D REGDT4^GMTSU S GMTSALAD=X
  1.  S GMTSAU=$$GET1^DIQ(120.86,+($G(DFN)),2,"I")
  1.  S GMTSALAW=$$GET1^DIQ(200,(+GMTSAU_","),.01,"E",,"GMTSALG3")
  1.  S GMTSALAT=$$GET1^DIQ(200,(+GMTSAU_","),20.3)
  1.  S:$D(GMTSALG3) (GMTSALAW,GMTSALAT)=""
  1.  Q
  1. AUTOV ; Autoverify
  1.  S GMTSAV=0,GMTSALNM=$P(GMTSAL(II,JJ,KK,L),U),GMTSAFN=$G(^GMR(120.8,GMTSALNM,0))
  1.  I $P(GMTSAFN,U,18)="",$P(GMTSAFN,U,16)=1 S GMTSAV=1
  1.  Q
  1. TITLE ; Print title
  1.  D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  I $D(GMTSPNF) S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=$$FILL^BSDX41(20)_TITLE_$C(30)
  1.  E  S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=$$FILL^BSDX41(20)_"Title: "_TITLE_$C(30)
  1.  Q
  1. TEXT ; Setup for print of allergy comments
  1.  S BSDXTMP=BSDXTMP_$$FILL^BSDX41(30-$L(BSDXTMP))_CD Q:$D(GMTSQIT)
  1.  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
  1.  I $D(^UTILITY($J,"W")) F GMTSLN=1:1:^UTILITY($J,"W",DIWL) D LINE Q:$D(GMTSQIT)
  1.  K ^UTILITY($J,"W")
  1.  Q:'GMTSLN
  1.  S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=BSDXTMP_$C(30)
  1.  Q
  1. FORMAT ; Formats each line
  1.  S DIWL=3,DIWR=80,DIWF="C58",X=GMTSPRT D ^DIWP
  1.  Q
  1. LINE ; Writes formatted lines of text
  1.  Q:$D(GMTSQIT)  S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=$$FILL^BSDX41(23)_^UTILITY($J,"W",DIWL,GMTSLN,0)_$C(30)
  1.  Q
  1. SIGBLK(GMTSALF) ; Signature block
  1.  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)
  1.  S BSDXDSP=$C(10,13)_$C(10,13)_$$FILL^BSDX41(23)_"Originator: "_$S(GMTSSB'="":GMTSSB,1:GMTSSN)
  1.  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)
  1.  Q
  1.  ;
  1. PROBA ; ************ ALLERGY PROB * 9000011 *********
  1.  ; for PROBLEM LIST codes only!
  1.  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
  1.  K APCHSPT S (APCHSFND,APCHSLEN)=0
  1.  S APCHSDFN="" F APCHSQ=0:0 S APCHSDFN=$O(^AUPNPROB("AC",APCHSPAT,APCHSDFN)) Q:'APCHSDFN  D PROBASCH
  1.  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
  1.  S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=$C(30)
  1.  I 'APCHSFND D PROBADNR G PROBAX
  1.  S APCHSDFN="" F APCHSQ=0:0 S APCHSDFN=$O(APCHSPT(APCHSDFN)) Q:'APCHSDFN  D PROBADSP
  1. PROBAX K APCHSPT,APCHSFND,APCHSDFN,APCHSLEN,APCHSDAT,APCHSNKA
  1.  Q
  1.  ;
  1. 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
  1.  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
  1.  Q
  1. PROBACHK ;checking for allergy codes
  1.  Q:$P(^AUPNPROB(APCHSDFN,0),U,5)=""  ;IHS/CMI/LAB - no narr
  1.  S APCHSNKA=0
  1.  I APCHSP="692.3" Q
  1.  I APCHSP="693.0" Q
  1.  I APCHSP="995.0" Q
  1.  I APCHSP="995.2" Q
  1.  I (+APCHSP'<999.4),(+APCHSP'>999.89) Q
  1.  I APCHSP?1"V14."1E Q
  1.  I APCHSP="692.5" Q
  1.  I APCHSP="693.1" Q
  1.  ;I APCHSP="V15.0" Q
  1.  I APCHSP["V15.0" Q
  1.  I $E(APCHSP,1,3)=692,APCHSP'="692.9" Q
  1.  I APCHSP="693.8" Q
  1.  I APCHSP="693.9" Q
  1.  I APCHSP="989.5" Q
  1.  I APCHSP="989.82" Q
  1.  I APCHSP="995.3" Q
  1.  I APCHSP["995.2" Q
  1.  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
  1.  ;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
  1.  Q
  1.  ;
  1. PROBADSP ;display allergies
  1.  S:$L(APCHSPT(APCHSDFN))<APCHSLEN APCHSL1=$L(APCHSPT(APCHSDFN))/2,APCHSL1=(APCHSLEN/2)-APCHSL1 ;                       center recorded allergies
  1.  S BSDXDSP=$$FILL^BSDX41((IOM-APCHSLEN-12)/2)_"***** "
  1.  S BSDXDSP=BSDXDSP_$$FILL^BSDX41(((IOM-APCHSLEN)/2)-$L(BSDXDSP))_+$G(APCHSL1)_APCHSPT(APCHSDFN)
  1.  S BSDXDSP=BSDXDSP_$$FILL^BSDX41(((IOM+APCHSLEN)/2))_" *****"
  1.  S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=BSDXDSP_$C(30)
  1.  K APCHSL1
  1.  Q
  1.  ;
  1. PROBADNR ;display "NONE RECORDED", if no allergies recorded
  1.  S BSDXDSP=$$FILL^BSDX41((IOM-13-12)/2)_"***** "
  1.  S BSDXDSP=BSDXDSP_$$FILL^BSDX41(((IOM-13)/2)-$L(BSDXDSP))_"NONE RECORDED"
  1.  S BSDXDSP=BSDXDSP_$$FILL^BSDX41(((IOM+13)/2)-$L(BSDXDSP))_" *****"
  1.  S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=BSDXDSP_$C(30)
  1.  Q
  1.  ;
  1. PROBALLG ;if allergy
  1.  S APCHSFND=1
  1.  I APCHSNKA D  I 1
  1.  . S Y=$P(^AUPNPROB(APCHSDFN,0),U,8) X APCHSCVD S APCHSDAT=Y
  1.  . S APCHSPT(APCHSDFN)="NO ALLERGY NOTED ON "_APCHSDAT
  1.  . S:$L($P(APCHSPT(APCHSDFN),U))>APCHSLEN APCHSLEN=$L($P(APCHSPT(APCHSDFN),U))
  1.  . Q
  1.  E  D
  1.  . ;Q:$P(^AUPNPROB(APCHSDFN,0),U,5)=""  ;IHS/CMI/LAB - added this to prevent subscript
  1.  . S APCHSPT(APCHSDFN)=$P(^AUTNPOV(+$P(^AUPNPROB(APCHSDFN,0),U,5),0),U,1)
  1.  . I APCHSPT(APCHSDFN)="" S APCHSPT(APCHSDFN)="???"
  1.  . S:$L(APCHSPT(APCHSDFN))>APCHSLEN APCHSLEN=$L(APCHSPT(APCHSDFN))
  1.  . Q
  1.  Q
  1.  ;