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