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

BHSALG.m

Go to the documentation of this file. 
  1. BHSALG ; IHS/MSC/MGH - ALL Health Summary Allergies ;10-Jun-2013 16:43;DU
  1.  ;;1.0;HEALTH SUMMARY COMPONENTS;**5,6,8**;March 17, 2006;Build 22
  1.  ;
  1.  ;Patch 6 updated for allergy review
  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. ALLRG ; Allergies
  1.  N X,GMTSALAS,GMTSALAD,GMTSALAW,GMTSALAT,GMTSAV,GMTSAFN,GMRAL,GMTSAL,GMRAUNDT,GMRAUNRE,GMRAUOTH,GMTSNO,GMTSN1
  1.  N GMTSALNM,GMTSCNT,GMTSEACT,GMTSLN,GMTSMECH,GMTSPRT,GMTSTY,CC,C,KK,INACT,GMRAUNFX,GMTSRC,GMTSSTM,INIEN
  1.  N ALLRG,TITLE,JJ,RXN,ADR,IN,JK
  1.  K GMTSA S (SEQ,ALLRG)=0,TITLE="ALL 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.  . D UNASS(DFN)
  1.  . I 'ALLRG D CKP^GMTSUP Q:$D(GMTSQIT)  W !,"Unknown, please evaluate",!
  1.  K ALL,CC,CCC,CD,DIWF,DIWL,DIWR,GMTSALF,GMRAIIEN,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.  D UNASS(DFN)
  1.  S II="" F  S II=$O(GMTSAL(II)) Q:II']""  I $O(GMTSAL(II,""))]"" D
  1.  . D CKP^GMTSUP Q:$D(GMTSQIT)  W !?2,$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_":")
  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  D
  1.  ....S ADR=$P($G(GMTSAL(II,JJ,KK,L)),U,1)
  1.  ....S IN=$$INACCK(ADR)
  1.  ....D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  ....D AUTOV
  1.  ....I IN=1 S JK="INACTIVE-"_JJ
  1.  ....I IN=0 S JK=JJ
  1.  ....W !?5,JK_": " S:$L(KK)>40 WKK=KK,WKK=$$WRAP^GMTSORC(WKK,40) W ?15,$S($L(KK)>40:$P(WKK,"|"),1:KK) D
  1.  ....D EN1^GMRAOR2(ADR,"RXN")
  1.  ....I II="D"  D CLS,ING
  1.  ....I GMTSAV=1 W ?5,"(AV"
  1.  ....E  W ?5,$S($P(GMTSAL(II,JJ,KK,L),U,5)=1:" (V",$P(GMTSAL(II,JJ,KK,L),U,5)=0:" (NV",1:"")
  1.  ....W $S($P($G(^GMR(120.8,GMTSALNM,0)),U,6)="h":"/Historical)",$P($G(^(0)),U,6)="o":"/Observed)",1:")")
  1.  ....I $L($P($G(WKK),"|",2)) D CKP^GMTSUP Q:$D(GMTSQIT)  W !,?15,$P(WKK,"|",2)
  1.  ....;IHS/MSC/MGH source added
  1.  ....I $P(GMTSAL(II,JJ,KK,L),U,11)'="" D
  1.  .....S GMTSRC=$P(GMTSAL(II,JJ,KK,L),U,11) S GMTSRC=$P($G(^BEHOAR(90460.05,GMTSRC,0)),U,1)
  1.  .....W !,?10,"Source: "_GMTSRC
  1.  ....I $P(GMTSAL(II,JJ,KK,L),U,12)'="" D
  1.  .....S GMTSNO=$P(GMTSAL(II,JJ,KK,L),U,12)
  1.  .....I GMTSNO'="" S GMTSN1=$P($G(^BEHOAR(90460.06,GMTSNO,0)),U,1)_" "_$P($G(^BEHOAR(90460.06,GMTSNO,0)),U,2)
  1.  .....W !,?10,"Snomed: "_GMTSN1
  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 D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  .....W !?10,"REACTION: "
  1.  .....S MX=MX+1
  1.  .....;W:MX>1 ", "
  1.  .....S N=$P(GMTSAL(II,JJ,KK,L,"S",M),";")
  1.  .....S ALL=1 I (74)'>($X+$L(N)) D CKP^GMTSUP Q:$D(GMTSQIT)  W !,?15,N Q
  1.  .....S ALL=1 W N
  1.  .....;IHS/MSC/MGH source of reaction added
  1.  .....I $P($G(GMTSAL(II,JJ,KK,L,"S",M)),U,3)'="" D
  1.  ......S GMTSSRC=$P($G(GMTSAL(II,JJ,KK,L,"S",M)),U,3) S GMTSSRC=$P($G(^BEHOAR(90460.05,GMTSSRC,0)),U,1)
  1.  ......S GMTSSTM=$P($G(GMTSAL(II,JJ,KK,L,"S",M)),U,2) S X=GMTSSTM D REGDTM4^GMTSU
  1.  ......D CKP^GMTSUP Q:$D(GMTSQIT)  W !,?15,"Date Noted: "_X
  1.  ......D CKP^GMTSUP Q:$D(GMTSQIT)  W !,?15,"Reaction Source: "_GMTSSRC,!
  1.  ....;IHS/MSC/MGH Inactivation data
  1.  ....S M=0 F  S M=$O(^GMR(120.8,GMTSALNM,9999999.12,M)) Q:'+M  D  Q:$D(GMTSQIT)
  1.  .....S GMRAIIEN=M_","_GMTSALNM_","
  1.  .....D INACTIVE(GMRAIIEN)
  1.  ....D SIGBLK($P(GMTSAFN,U,5))
  1.  ....D CKP^GMTSUP Q:$D(GMTSQIT)  W !,?10,"Date/Time:  " S ODT=$P(GMTSAFN,U,4) S X=ODT D REGDTM4^GMTSU W X,!
  1.  ....D DATES
  1.  ....D RECON(ADR)
  1.  ....S CC="" F  S CC=$O(^GMR(120.8,GMTSALNM,26,"B",CC)) Q:CC=""  D CKP^GMTSUP Q:$D(GMTSQIT)  W !,?15,"Comments at: " S X=CC D REGDTM4^GMTSU S CD=X S CCC=0 F  S CCC=$O(^GMR(120.8,GMTSALNM,26,"B",CC,CCC)) Q:'CCC  D TEXT
  1. COMMON1 ;additional stuff for CHHIT bjpc 2.0 patch 5
  1.  ;get date last reviewed and display
  1.  N BHSX
  1.  S BHSX=$$LASTALR^APCLAPI6(DFN,,DT,"A")
  1.  D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  W !,"Allergy List Reviewed On: ",?36,$$FMTE^XLFDT($P(BHSX,U,1)) W ?51,"By: ",?54,$E($S($P(BHSX,U,3):$P($G(^VA(200,$P(BHSX,U,3),0)),U),1:""),1,25),!
  1.  S BHSX=$$LASTALU^APCLAPI6(DFN,,DT,"A")
  1.  D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  W "Allergy List Updated On: ",?36,$$FMTE^XLFDT($P(BHSX,U,1)) W ?51,"By: ",?54,$E($S($P(BHSX,U,3):$P($G(^VA(200,$P(BHSX,U,3),0)),U),1:""),1,25),!
  1.  S BHSX=$$LASTNAA^APCLAPI6(DFN,,DT,"A")
  1.  D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  W "No Allergies Documented On: ",?36,$$FMTE^XLFDT($P(BHSX,U,1)) W ?51,"By: ",$E($S($P(BHSX,U,3):$P($G(^VA(200,$P(BHSX,U,3),0)),U),1:""),1,25),!
  1.  Q
  1. NKA ; No known allergies
  1.  D UNASS(DFN)
  1.  D CKP^GMTSUP Q:$D(GMTSQIT)  W:$L($G(GMTSALAS))!($L($G(GMTSALAD))) !
  1.  D CKP^GMTSUP Q:$D(GMTSQIT)  W:$L($G(GMTSALAS)) ?15,$G(GMTSALAS),!
  1.  D CKP^GMTSUP Q:$D(GMTSQIT)  W:$L($G(GMTSALAS))!($L($G(GMTSALAD)))!($L($G(GMTSALAW))) ?15,"Assessment date:   ",$G(GMTSALAD),!
  1.  D CKP^GMTSUP Q:$D(GMTSQIT)  W:$L($G(GMTSALAW)) ?15,"Assessed by:   ",GMTSALAW,!
  1.  D CKP^GMTSUP Q:$D(GMTSQIT)  W:$L($G(GMTSALAW))&($L($G(GMTSALAT))) ?25,"Title:   ",GMTSALAT,!
  1.  Q
  1. GETALLRG ; Get Allergies
  1.  S GMRA="0^0^111^1" 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 GMTSRC=$P(GMRAL(I),U,10)
  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) I $D(GMRAL(I,"I",JJ)) S GMTSAL(GMTSTY,GMTSMECH,GMTSEACT,GMTSCNT,"I",JJ)=GMRAL(I,"I",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) W ?21,TITLE,!
  1.  E  W ?21,"Title: ",TITLE,!
  1.  Q
  1. TEXT ; Setup for print of allergy comments
  1.  W ?31,CD D CKP^GMTSUP 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.  W ! 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.  D CKP^GMTSUP Q:$D(GMTSQIT)  W !,?15,^UTILITY($J,"W",DIWL,GMTSLN,0)
  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.  D CKP^GMTSUP Q:$D(GMTSQIT)  W !!,?10,"Originator: ",$S(GMTSSB'="":GMTSSB,1:GMTSSN)
  1.  D CKP^GMTSUP Q:$D(GMTSQIT)  W:$L(GMTSST) !,?10,"Title:      ",GMTSST
  1.  Q
  1. INACCK(GMTSALNM) ;CHECK FOR INACTIVE
  1.  N CK,M,INACT,REACT
  1.  S CK=0
  1.  S M=9999999 F  S M=$O(^GMR(120.8,GMTSALNM,9999999.12,M),-1) Q:'+M  D
  1.  .S INACT=$P($G(^GMR(120.8,GMTSALNM,9999999.12,M,0)),U,1)
  1.  .S REACT=$P($G(^GMR(120.8,GMTSALNM,9999999.12,M,0)),U,4)
  1.  .I +INACT&(REACT="") S CK=1
  1.  Q CK
  1. INACTIVE(IIEN) ;IHS/MSC/MGH Display the inactive data as needed
  1.  N X,X1,X2,X3,X4,X5
  1.  S X=$$GET1^DIQ(120.899999912,IIEN,.01),X2=$$GET1^DIQ(120.899999912,IIEN,1),X3=$$GET1^DIQ(120.899999912,IIEN,2)
  1.  S X4=$$GET1^DIQ(120.899999912,IIEN,3),X5=$$GET1^DIQ(120.899999912,IIEN,4)
  1.  D CKP^GMTSUP Q:$D(GMTSQIT)  W !,?15,"Inactivation: ",X_"( "_X2_" )"
  1.  D CKP^GMTSUP Q:$D(GMTSQIT)  W !,?20,"Inactivated by: ",X3
  1.  I X4'="" D CKP^GMTSUP Q:$D(GMTSQIT)  W !,?15,"Reactivation: ",X4,?40,"by "_X5
  1.  Q
  1. UNASS(DFN) ;IHS/MSC/MGH Check if patient is unassessable
  1.  N Y,IIEN
  1.  S (GMRAUNDT,GMRAUNRE,GMRAUNFX)=""
  1.  I '$D(^GMR(120.86,DFN,9999999.11)) Q
  1.  D CKP^GMTSUP Q:$D(GMTSQIT)  W !,?1,"UNASSESSABLE DATA",!
  1.  S Y=0 F  S Y=$O(^GMR(120.86,DFN,9999999.11,Y)) Q:'+Y  D
  1.  .S INIEN=Y_","_DFN
  1.  .S GMRAUNDT=$$GET1^DIQ(120.869999911,INIEN,.01)
  1.  .S GMRAUNRE=$$GET1^DIQ(120.869999911,INIEN,1)
  1.  .S GMRAUNFX=$$GET1^DIQ(120.869999911,INIEN,4)
  1.  .S GMRAUOTH=$$GET1^DIQ(120.869999911,INIEN,5)
  1.  .D PRUN
  1.  Q
  1. PRUN ;IHS/MSC/MGH Print unassessable
  1.  D CKP^GMTSUP Q:$D(GMTSQIT)  W:$L($G(GMRAUNDT)) !,?3,"Unassessable Date: ",GMRAUNDT
  1.  D CKP^GMTSUP Q:$D(GMTSQIT)  W:$L($G(GMRAUNRE)) ?50,"Reason ",GMRAUNRE_" "_GMRAUOTH
  1.  D CKP^GMTSUP Q:$D(GMTSQIT)  W:$L($G(GMRAUNFX)) !,?3,"Resolved: ",GMRAUNFX,!
  1.  Q
  1. CLS ;Drug classes
  1.  N CNT,LP,TITLE
  1.  S CNT=0
  1.  D CKP^GMTSUP Q:$D(GMTSQIT)  W !,?5,"Drug Classes: "
  1.  S LP=0 F  S LP=$O(RXN("V",LP)) Q:'LP  D
  1.  .S CNT=CNT+1
  1.  .D CKP^GMTSUP Q:$D(GMTSQIT)  W ?25,$P($G(RXN("V",LP)),U,2),!
  1.  Q
  1. ING ;Drug classes
  1.  N CNT,LP,TITLE
  1.  S CNT=0
  1.  D CKP^GMTSUP Q:$D(GMTSQIT)  W !,?5,"Ingredients: "
  1.  S LP=0 F  S LP=$O(RXN("I",LP)) Q:'LP  D
  1.  .S CNT=CNT+1
  1.  .D CKP^GMTSUP Q:$D(GMTSQIT)  W ?25,$P($G(RXN("I",LP)),U,1),!
  1.  Q
  1. DATES ;Get verification data and last edited
  1.  N VER,VBY,VERTX
  1.  S VER=$P(RXN,U,4)
  1.  S VERTX=$S(VER="VERIFIED":"Verified on: ",1:"Not verified")
  1.  D CKP^GMTSUP Q:$D(GMTSQIT)  W ?10,VERTX
  1.  I VER="VERIFIED" D
  1.  .D CKP^GMTSUP Q:$D(GMTSQIT)  W ?25,$$FMTE^XLFDT($P(RXN,U,9)),!
  1.  .D CKP^GMTSUP Q:$D(GMTSQIT)  W ?10,"Verified by: "_$P(RXN,U,8),!
  1.  E  W !
  1.  ;Date last modified
  1.  N LP,MOD,IIEN,X,Y
  1.  S LP=9999999 S LP=$O(^GMR(120.8,ADR,9999999.14,LP),-1) Q:'+LP  D
  1.  .S MOD=$G(^GMR(120.8,ADR,9999999.14,LP,0))
  1.  .S IIEN=LP_","_ADR_","
  1.  .S X=$$GET1^DIQ(120.899999914,IIEN,.01),Y=$$GET1^DIQ(120.899999914,IIEN,.02)
  1.  .S X=X_" by "_Y
  1.  .D CKP^GMTSUP Q:$D(GMTSQIT)  W ?10,"Last Modified: "_X,!
  1.  W !
  1. RECON(ADR) ;Get dates reconciled
  1.  N REC,IEN,AIEN,WHEN,BY
  1.  I $D(^BEHOCIR("G","A",ADR))>0 W !,?10,"Reconciliation Data",!
  1.  S REC=""
  1.  F  S REC=$O(^BEHOCIR("G","A",ADR,REC)) Q:REC=""  D
  1.  .S IEN="" F  S IEN=$O(^BEHOCIR("G","A",ADR,REC,IEN)) Q:IEN=""  D
  1.  ..S AIEN=IEN_","_REC_","
  1.  ..S WHEN=$$GET1^DIQ(90461.632,AIEN,.01)
  1.  ..S BY=$$GET1^DIQ(90461.632,AIEN,.02)
  1.  ..W ?10,"When: "_WHEN_" By "_BY,!
  1.  Q