GMRAOR5 ;HIRMFO/WAA,FPT-OERR HL7 UTILITY ;3/5/04 14:02
;;4.0;Adverse Reaction Tracking;**4,12,13,19**;Mar 29, 1996
;MSG = HL7 Message array
;GMRANODE = IEN of MSG array
;GMRAND = Date from MSG(GMRANODE)
;GMRAMTP = Message type
;Allergy Loader
;building GMRAL Array to be used to stuff only new data
;GMRAID=sequence number of allergy
;~=continuation
;GMRAIDO = Sequence # OBSERVED
;GMRAIDS = Sequence # SIGN
;GMRAIDN = Sequence # NOTES
; GMRADFN=DFN of patient in ^DPT(DFN) Patient (2) file
; GMRAL(GMRAID)=type^file ien^VA Free text drug^file^OERR entry date
; ^NKA Status^Originator Pt to 200^Observed/Historical
; GMRAL(GMRAID,"O",GMRAIDO)=Observed date^Severity^Observer's DUZ
; GMRAL(GMRAID,"S",GMRAIDS)=IEN of file^Free Text of entry^File of SS
; ^Date/Time of the SS
; GMRAL(GMRAID,"N",GMRAIDN)=Source of comments(Originator always)
;----------------------------------------------------------------------
; Example of data
; GMRADFN=270
; GMRAL(1)="D^5^SHELL FISH^99ALL^2940415.06^n^1270^o"
; GMRAL(1,"O",1)="2940401.1^3^1234"
; GMRAL(1,"S",1)="32^SEVERE RASH^99ALS^2951211.1120"
; GMRAL(1,"N",1)="n"
; GMRAL(1,"N",1,1)=FREE TEXT
;******************************************************************
EN1 ;Main entry point to file data
N %,GMRADUP,GMRAFDN,GMRANKA,GNRAY,X,Y
Q:'$G(GMRADFN)
S GMRAL=0
S GMRAPA=0,GMRADUP=0
; See if the patient has been ask about allergies
S (GMRAYN,GMRANKA)=0,GMRAYN=$P($G(^GMR(120.86,GMRADFN,0)),U,2)
;Loop through for each allergy
F S GMRAL=$O(GMRAL(GMRAL)) Q:GMRAL<1 D
.;If GMRANKA="" add the entry into the file
.I '$D(^GMR(120.86,GMRADFN,0)) K DD,DO,DIC,DINUM,DLAYGO S DIC="^GMR(120.86,",DLAYGO=120.86,DIC(0)="L",(DINUM,X)=GMRADFN D FILE^DICN K DD,DO,DIC,DINUM,DLAYGO D
..Q:Y=-1
..S GMRAYN=$S($P(GMRAL(GMRAL),U,6)="y":1,1:0)
..S $P(^GMR(120.86,GMRADFN,0),U,2,4)=GMRAYN_U_$P(GMRAL(GMRAL),U,7)_U_$P(GMRAL(GMRAL),U,5)
..Q
.N GMRALL,GMRAFN,%
.S GMRALL=$P(GMRAL(GMRAL),U,3)
.I $P(GMRAL(GMRAL),U,6)="n" D Q:GMRALL'=""
..; Change to no for allergies
..Q:GMRAYN="1"!$D(^GMR(120.86,GMRADFN,0))
..S $P(^GMR(120.86,GMRADFN,0),U,2,4)="0"_U_$P(GMRAL(GMRAL),U,7)_U_$P(GMRAL(GMRAL),U,5)
..S:'$D(^GMR(120.86,"B",GMRADFN,GMRADFN)) ^(GMRADFN)=""
..Q
.I GMRAYN="0",$P(GMRAL(GMRAL),U,6)="n" Q
.; see If the entry needs to be added
.; If the entry is an allergy set 120.86 to "y"
.I GMRALL'="",$D(^GMR(120.86,GMRADFN,0)) S GMRAYN=1 D
..; Change to yes for allergies
..S $P(^GMR(120.86,GMRADFN,0),U,2,4)=GMRAYN_U_$P(GMRAL(GMRAL),U,7)_U_$P(GMRAL(GMRAL),U,5)
..S:'$D(^GMR(120.86,"B",GMRADFN,GMRADFN)) ^(GMRADFN)=""
..Q
.; Quit if the reaction is a Dup
.Q:$$DUPCHK^GMRAOR0(GMRADFN,GMRALL)>0
.S GMRAPA=0
.K DD,DO,DIC,DINUM,DLAYGO S DIC="^GMR(120.8,",DLAYGO=120.8,DIC(0)="L",X=GMRADFN D FILE^DICN
.K DD,DO,DIC,DINUM,DLAYGO
.Q:Y=-1 S GMRAPA=+Y
.Q:$G(^GMR(120.8,GMRAPA,0))=""
.F Q:$$LOCK^GMRAUTL(120.8,GMRAPA)
.N GMRALN,GMRAVR
.S GMRALN=$G(^GMR(120.8,GMRAPA,0))
.S $P(GMRALN,U,4)=$P(GMRAL(GMRAL),U,5) ; Orig. DT
.S $P(GMRALN,U,5)=$P(GMRAL(GMRAL),U,7) ; Originator
.S %=$P(GMRAL(GMRAL),U,4),%=$S(%="99ALL"!(%="99OTH"):"GMRD(120.82,",%="99NDF":$P($$NDFREF^GMRAOR,U,2),%="99PSC":"PS(50.605,",1:"") Q:%="" ;Bad entry
.S:$P(GMRAL(GMRAL),U,2)="NOS" $P(GMRAL(GMRAL),U,2)=$S($O(^GMRD(120.82,"B","OTHER ALLERGY/ADVERSE REACTION",0))>0:$O(^GMRD(120.82,"B","OTHER ALLERGY/ADVERSE REACTION",0)),1:1)
.S GMRAAR=$P(GMRAL(GMRAL),U,2)_";"_%,$P(GMRALN,U,3)=GMRAAR ;File Ptr
.I $P(GMRAL(GMRAL),U,3)'="" S $P(GMRALN,U,2)=$P(GMRAL(GMRAL),U,3) ;Free text
.E D ; This code will resolve the free text pointer for the reaction
..N GMRALOC,GMRADATA
..S GMRALOC="^"_$P($P(GMRALN,U,3),";",2)_+$P(GMRALN,U,3)_",0)"
..S GMRADATA=@GMRALOC
..S $P(GMRALN,U,2)=$P(GMRADATA,U)
..Q
.S $P(GMRALN,U,20)=$P(GMRAL(GMRAL),U) ;Type of reaction
.S $P(GMRALN,U,6)=$P(GMRAL(GMRAL),U,8) ;Obs/Hist
.S $P(GMRALN,U,14)="U" ;Mechanism
.S $P(GMRALN,U,12)=1 ;Sign-off the reaction
.; auto-verify?
.S GMRAVR="",GMRAVR(0)=GMRALN
.S $P(GMRALN,U,16)=$$VFY^GMRASIGN(.GMRAVR)
.I $P(GMRALN,U,16) S $P(GMRALN,U,17)=$$NOW^XLFDT
.; save
.S ^GMR(120.8,GMRAPA,0)=GMRALN
.I $D(GMRAL(GMRAL,"S",1)) D SIGN^GMRAOR6(120.8,GMRAPA,.GMRAL) ; S/S
.; Comments
.I $D(GMRAL(GMRAL,"N",1)) D COMM^GMRAOR8(GMRAPA,.GMRAL) ; Add comments
.D EN1^GMRAOR9 K GMRAAR ;stuff ingredients & classes
.;Re-Index Whole file entry
.K DIK,DA S DIK="^GMR(120.8,",DA=GMRAPA D IX^DIK K DIK,DA
.D UNLOCK^GMRAUTL(120.8,GMRAPA)
.S ^TMP($J,"GMRASF",1,GMRAPA)="" D RANGE^GMRASIGN(1) ;**19 Send bulletins upon signing-off
.S GMRASITE(0)=$G(^GMRD(120.84,+GMRASITE,0)) D VAD^GMRAUTL1($P(^GMR(120.8,GMRAPA,0),U),"",.GMRALOC,.GMRANAM,"",.GMRASSN),BULLT^GMRASEND ;19 Send mark chart bulletin
.Q:($P(GMRAL(GMRAL),U,1)'["D"!($P(GMRAL(GMRAL),U,8)'["o")) ;quit if not an observed drug reaction
.; add Adverse Reaction report.
.I $G(GMRAL(GMRAL,"O",1))'="" D ADVERSE^GMRAOR7(GMRAPA,.GMRAL)
.Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMRAOR5 5093 printed Apr 09, 2024@20:44:33 Page 2
GMRAOR5 ;HIRMFO/WAA,FPT-OERR HL7 UTILITY ;3/5/04 14:02
+1 ;;4.0;Adverse Reaction Tracking;**4,12,13,19**;Mar 29, 1996
+2 ;MSG = HL7 Message array
+3 ;GMRANODE = IEN of MSG array
+4 ;GMRAND = Date from MSG(GMRANODE)
+5 ;GMRAMTP = Message type
+6 ;Allergy Loader
+7 ;building GMRAL Array to be used to stuff only new data
+8 ;GMRAID=sequence number of allergy
+9 ;~=continuation
+10 ;GMRAIDO = Sequence # OBSERVED
+11 ;GMRAIDS = Sequence # SIGN
+12 ;GMRAIDN = Sequence # NOTES
+13 ; GMRADFN=DFN of patient in ^DPT(DFN) Patient (2) file
+14 ; GMRAL(GMRAID)=type^file ien^VA Free text drug^file^OERR entry date
+15 ; ^NKA Status^Originator Pt to 200^Observed/Historical
+16 ; GMRAL(GMRAID,"O",GMRAIDO)=Observed date^Severity^Observer's DUZ
+17 ; GMRAL(GMRAID,"S",GMRAIDS)=IEN of file^Free Text of entry^File of SS
+18 ; ^Date/Time of the SS
+19 ; GMRAL(GMRAID,"N",GMRAIDN)=Source of comments(Originator always)
+20 ;----------------------------------------------------------------------
+21 ; Example of data
+22 ; GMRADFN=270
+23 ; GMRAL(1)="D^5^SHELL FISH^99ALL^2940415.06^n^1270^o"
+24 ; GMRAL(1,"O",1)="2940401.1^3^1234"
+25 ; GMRAL(1,"S",1)="32^SEVERE RASH^99ALS^2951211.1120"
+26 ; GMRAL(1,"N",1)="n"
+27 ; GMRAL(1,"N",1,1)=FREE TEXT
+28 ;******************************************************************
EN1 ;Main entry point to file data
+1 NEW %,GMRADUP,GMRAFDN,GMRANKA,GNRAY,X,Y
+2 if '$GET(GMRADFN)
QUIT
+3 SET GMRAL=0
+4 SET GMRAPA=0
SET GMRADUP=0
+5 ; See if the patient has been ask about allergies
+6 SET (GMRAYN,GMRANKA)=0
SET GMRAYN=$PIECE($GET(^GMR(120.86,GMRADFN,0)),U,2)
+7 ;Loop through for each allergy
+8 FOR
SET GMRAL=$ORDER(GMRAL(GMRAL))
if GMRAL<1
QUIT
Begin DoDot:1
+9 ;If GMRANKA="" add the entry into the file
+10 IF '$DATA(^GMR(120.86,GMRADFN,0))
KILL DD,DO,DIC,DINUM,DLAYGO
SET DIC="^GMR(120.86,"
SET DLAYGO=120.86
SET DIC(0)="L"
SET (DINUM,X)=GMRADFN
DO FILE^DICN
KILL DD,DO,DIC,DINUM,DLAYGO
Begin DoDot:2
+11 if Y=-1
QUIT
+12 SET GMRAYN=$SELECT($PIECE(GMRAL(GMRAL),U,6)="y":1,1:0)
+13 SET $PIECE(^GMR(120.86,GMRADFN,0),U,2,4)=GMRAYN_U_$PIECE(GMRAL(GMRAL),U,7)_U_$PIECE(GMRAL(GMRAL),U,5)
+14 QUIT
End DoDot:2
+15 NEW GMRALL,GMRAFN,%
+16 SET GMRALL=$PIECE(GMRAL(GMRAL),U,3)
+17 IF $PIECE(GMRAL(GMRAL),U,6)="n"
Begin DoDot:2
+18 ; Change to no for allergies
+19 if GMRAYN="1"!$DATA(^GMR(120.86,GMRADFN,0))
QUIT
+20 SET $PIECE(^GMR(120.86,GMRADFN,0),U,2,4)="0"_U_$PIECE(GMRAL(GMRAL),U,7)_U_$PIECE(GMRAL(GMRAL),U,5)
+21 if '$DATA(^GMR(120.86,"B",GMRADFN,GMRADFN))
SET ^(GMRADFN)=""
+22 QUIT
End DoDot:2
if GMRALL'=""
QUIT
+23 IF GMRAYN="0"
IF $PIECE(GMRAL(GMRAL),U,6)="n"
QUIT
+24 ; see If the entry needs to be added
+25 ; If the entry is an allergy set 120.86 to "y"
+26 IF GMRALL'=""
IF $DATA(^GMR(120.86,GMRADFN,0))
SET GMRAYN=1
Begin DoDot:2
+27 ; Change to yes for allergies
+28 SET $PIECE(^GMR(120.86,GMRADFN,0),U,2,4)=GMRAYN_U_$PIECE(GMRAL(GMRAL),U,7)_U_$PIECE(GMRAL(GMRAL),U,5)
+29 if '$DATA(^GMR(120.86,"B",GMRADFN,GMRADFN))
SET ^(GMRADFN)=""
+30 QUIT
End DoDot:2
+31 ; Quit if the reaction is a Dup
+32 if $$DUPCHK^GMRAOR0(GMRADFN,GMRALL)>0
QUIT
+33 SET GMRAPA=0
+34 KILL DD,DO,DIC,DINUM,DLAYGO
SET DIC="^GMR(120.8,"
SET DLAYGO=120.8
SET DIC(0)="L"
SET X=GMRADFN
DO FILE^DICN
+35 KILL DD,DO,DIC,DINUM,DLAYGO
+36 if Y=-1
QUIT
SET GMRAPA=+Y
+37 if $GET(^GMR(120.8,GMRAPA,0))=""
QUIT
+38 FOR
if $$LOCK^GMRAUTL(120.8,GMRAPA)
QUIT
+39 NEW GMRALN,GMRAVR
+40 SET GMRALN=$GET(^GMR(120.8,GMRAPA,0))
+41 ; Orig. DT
SET $PIECE(GMRALN,U,4)=$PIECE(GMRAL(GMRAL),U,5)
+42 ; Originator
SET $PIECE(GMRALN,U,5)=$PIECE(GMRAL(GMRAL),U,7)
+43 ;Bad entry
SET %=$PIECE(GMRAL(GMRAL),U,4)
SET %=$SELECT(%="99ALL"!(%="99OTH"):"GMRD(120.82,",%="99NDF":$PIECE($$NDFREF^GMRAOR,U,2),%="99PSC":"PS(50.605,",1:"")
if %=""
QUIT
+44 if $PIECE(GMRAL(GMRAL),U,2)="NOS"
SET $PIECE(GMRAL(GMRAL),U,2)=$SELECT($ORDER(^GMRD(120.82,"B","OTHER ALLERGY/ADVERSE REACTION",0))>0:$ORDER(^GMRD(120.82,"B","OTHER ALLERGY/ADVERSE REACTION",0)),1:1)
+45 ;File Ptr
SET GMRAAR=$PIECE(GMRAL(GMRAL),U,2)_";"_%
SET $PIECE(GMRALN,U,3)=GMRAAR
+46 ;Free text
IF $PIECE(GMRAL(GMRAL),U,3)'=""
SET $PIECE(GMRALN,U,2)=$PIECE(GMRAL(GMRAL),U,3)
+47 ; This code will resolve the free text pointer for the reaction
IF '$TEST
Begin DoDot:2
+48 NEW GMRALOC,GMRADATA
+49 SET GMRALOC="^"_$PIECE($PIECE(GMRALN,U,3),";",2)_+$PIECE(GMRALN,U,3)_",0)"
+50 SET GMRADATA=@GMRALOC
+51 SET $PIECE(GMRALN,U,2)=$PIECE(GMRADATA,U)
+52 QUIT
End DoDot:2
+53 ;Type of reaction
SET $PIECE(GMRALN,U,20)=$PIECE(GMRAL(GMRAL),U)
+54 ;Obs/Hist
SET $PIECE(GMRALN,U,6)=$PIECE(GMRAL(GMRAL),U,8)
+55 ;Mechanism
SET $PIECE(GMRALN,U,14)="U"
+56 ;Sign-off the reaction
SET $PIECE(GMRALN,U,12)=1
+57 ; auto-verify?
+58 SET GMRAVR=""
SET GMRAVR(0)=GMRALN
+59 SET $PIECE(GMRALN,U,16)=$$VFY^GMRASIGN(.GMRAVR)
+60 IF $PIECE(GMRALN,U,16)
SET $PIECE(GMRALN,U,17)=$$NOW^XLFDT
+61 ; save
+62 SET ^GMR(120.8,GMRAPA,0)=GMRALN
+63 ; S/S
IF $DATA(GMRAL(GMRAL,"S",1))
DO SIGN^GMRAOR6(120.8,GMRAPA,.GMRAL)
+64 ; Comments
+65 ; Add comments
IF $DATA(GMRAL(GMRAL,"N",1))
DO COMM^GMRAOR8(GMRAPA,.GMRAL)
+66 ;stuff ingredients & classes
DO EN1^GMRAOR9
KILL GMRAAR
+67 ;Re-Index Whole file entry
+68 KILL DIK,DA
SET DIK="^GMR(120.8,"
SET DA=GMRAPA
DO IX^DIK
KILL DIK,DA
+69 DO UNLOCK^GMRAUTL(120.8,GMRAPA)
+70 ;**19 Send bulletins upon signing-off
SET ^TMP($JOB,"GMRASF",1,GMRAPA)=""
DO RANGE^GMRASIGN(1)
+71 ;19 Send mark chart bulletin
SET GMRASITE(0)=$GET(^GMRD(120.84,+GMRASITE,0))
DO VAD^GMRAUTL1($PIECE(^GMR(120.8,GMRAPA,0),U),"",.GMRALOC,.GMRANAM,"",.GMRASSN)
DO BULLT^GMRASEND
+72 ;quit if not an observed drug reaction
if ($PIECE(GMRAL(GMRAL),U,1)'["D"!($PIECE(GMRAL(GMRAL),U,8)'["o"))
QUIT
+73 ; add Adverse Reaction report.
+74 IF $GET(GMRAL(GMRAL,"O",1))'=""
DO ADVERSE^GMRAOR7(GMRAPA,.GMRAL)
+75 QUIT
End DoDot:1
+76 QUIT
