VPSMR52 ;WOIFO/BT - Get the last MRAR data for a patient (Allergy Level) ;01/29/15 15:30
;;1.0;VA POINT OF SERVICE (KIOSKS);**3**;Jan 29, 2015;Build 64
;;Per VHA Directive 2004-038, this routine should not be modified.
;
;
ALLERGY(VPSMRAR,DFN,LASTMRAR) ; -- retrieve Allergy level fields and store them in VPSMRAR
; INPUT
; DFN : Patient IEN
; LASTMRAR : The last MRAR Transaction IEN for the patient
; OUTPUT
; VPSMRAR: local array contains all field names/values for the last mrar
;
N REC,INVAL,EXVAL,ALRNO,FLD,SUBS
N FIL S FIL=853.52
N ALRIEN S ALRIEN=0
;
F S ALRIEN=$O(^VPS(853.5,DFN,"MRAR",LASTMRAR,"ALLERGY",ALRIEN)) Q:'ALRIEN D
. S SUBS=ALRIEN_","_LASTMRAR_","_DFN_","
. K REC D GETS^DIQ(FIL,SUBS,"*","IE","REC")
. S ALRNO=REC(FIL,SUBS,.01,"I")
. S FLD=""
. F S FLD=$O(REC(FIL,SUBS,FLD)) Q:'FLD D
. . K ATTR D FIELD^DID(FIL,FLD,"","LABEL;TYPE","ATTR")
. . S INVAL=REC(FIL,SUBS,FLD,"I")
. . S EXVAL=REC(FIL,SUBS,FLD,"E")
. . I FIL=853.52,FLD=.02 S EXVAL=$$GET1^DIQ(120.8,INVAL_",",.02,"E")
. . I ATTR("TYPE")="WORD-PROCESSING" S EXVAL=$$WP^VPSMRAR9(.REC,FIL,SUBS,FLD),INVAL=""
. . D ADD^VPSMRAR9(.VPSMRAR,ATTR("LABEL"),","_ALRNO,INVAL,EXVAL)
. ;
. D ALLIND(.VPSMRAR,VPSDFN,LASTMRAR,ALRIEN,ALRNO)
. D ALREACT(.VPSMRAR,VPSDFN,LASTMRAR,ALRIEN,ALRNO)
;
QUIT
;
ALLIND(VPSMRAR,DFN,LASTMRAR,ALRIEN,ALRNO) ; -- retrieve Allergy Indicator level fields and store them in VPSMRAR
; INPUT
; DFN : Patient IEN
; LASTMRAR : The last MRAR Transaction IEN for the patient
; ALRIEN : Allergy IEN
; ALRNO : Allergy Entry #
; OUTPUT
; VPSMRAR : local array contains all field names/values for the last mrar
;
N REC,INVAL,EXVAL,ATTR,SUBS
N FIL S FIL("ACHG")=853.525,FIL("ACNFR")=853.526,FIL("ADISCR")=853.527
N FLD S FLD=".01"
;
F IND="ACHG","ACNFR","ADISCR" D
. K ATTR D FIELD^DID(FIL(IND),FLD,"","LABEL;TYPE","ATTR")
. N INDIEN S INDIEN=0
. F S INDIEN=$O(^VPS(853.5,DFN,"MRAR",LASTMRAR,"ALLERGY",ALRIEN,IND,INDIEN)) Q:'INDIEN D
. . S SUBS=INDIEN_","_ALRIEN_","_LASTMRAR_","_DFN_","
. . K REC D GETS^DIQ(FIL(IND),SUBS,"*","IE","REC")
. . S INVAL=REC(FIL(IND),SUBS,FLD,"I")
. . S EXVAL=REC(FIL(IND),SUBS,FLD,"E")
. . D ADD^VPSMRAR9(.VPSMRAR,ATTR("LABEL"),","_ALRNO_","_INVAL,INVAL,EXVAL)
;
QUIT
;
ALREACT(VPSMRAR,VPSDFN,LASTMRAR,ALRIEN,ALRNO) ; -- retrieve Allergy Reaction level fields and store them in VPSMRAR
; INPUT
; DFN : Patient IEN
; LASTMRAR : The last MRAR Transaction IEN for the patient
; ALRIEN : Allergy IEN
; OUTPUT
; VPSMRAR : local array contains all field names/values for the last mrar
;
N REC,INVAL,EXVAL,ATTR,FLD,SUBS,REACTNO
N FIL S FIL=853.57
N REACTIEN S REACTIEN=0
;
F S REACTIEN=$O(^VPS(853.5,DFN,"MRAR",LASTMRAR,"ALLERGY",ALRIEN,"REACTIONS",REACTIEN)) Q:'REACTIEN D
. S SUBS=REACTIEN_","_ALRIEN_","_LASTMRAR_","_DFN_","
. K REC D GETS^DIQ(FIL,SUBS,"*","IE","REC")
. S REACTNO=REC(FIL,SUBS,".01","I")
. S FLD=0
. F S FLD=$O(REC(FIL,SUBS,FLD)) Q:'FLD D
. . K ATTR D FIELD^DID(FIL,FLD,"","LABEL;TYPE","ATTR")
. . S INVAL=REC(FIL,SUBS,FLD,"I")
. . S EXVAL=REC(FIL,SUBS,FLD,"E")
. . I ATTR("TYPE")="WORD-PROCESSING" S EXVAL=$$WP^VPSMRAR9(.REC,FIL,SUBS,FLD),INVAL=""
. . D ADD^VPSMRAR9(.VPSMRAR,ATTR("LABEL"),","_ALRNO_","_REACTNO,INVAL,EXVAL)
;
QUIT
;
ADDALLER(VPSMRAR,DFN,LASTMRAR) ; -- retrieve Additional Allergy level fields and store them in VPSMRAR
; INPUT
; DFN : Patient IEN
; LASTMRAR : The last MRAR Transaction IEN for the patient
; OUTPUT
; VPSMRAR: local array contains all field names/values for the last mrar
;
N REC,INVAL,EXVAL,ALRNO,FLD,SUBS
N FIL S FIL=853.53
N ALRIEN S ALRIEN=0
;
F S ALRIEN=$O(^VPS(853.5,DFN,"MRAR",LASTMRAR,"ALLERGYADD",ALRIEN)) Q:'ALRIEN D
. S SUBS=ALRIEN_","_LASTMRAR_","_DFN_","
. K REC D GETS^DIQ(FIL,SUBS,"*","IE","REC")
. S ALRNO=REC(FIL,SUBS,.01,"I")
. S FLD=""
. F S FLD=$O(REC(FIL,SUBS,FLD)) Q:'FLD D
. . K ATTR D FIELD^DID(FIL,FLD,"","LABEL;TYPE","ATTR")
. . S INVAL=REC(FIL,SUBS,FLD,"I")
. . S EXVAL=REC(FIL,SUBS,FLD,"E")
. . I ATTR("TYPE")="WORD-PROCESSING" S EXVAL=$$WP^VPSMRAR9(.REC,FIL,SUBS,FLD),INVAL=""
. . D ADD^VPSMRAR9(.VPSMRAR,ATTR("LABEL"),","_ALRNO,INVAL,EXVAL)
;
QUIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVPSMR52 4326 printed Sep 23, 2025@20:19:23 Page 2
VPSMR52 ;WOIFO/BT - Get the last MRAR data for a patient (Allergy Level) ;01/29/15 15:30
+1 ;;1.0;VA POINT OF SERVICE (KIOSKS);**3**;Jan 29, 2015;Build 64
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ;
ALLERGY(VPSMRAR,DFN,LASTMRAR) ; -- retrieve Allergy level fields and store them in VPSMRAR
+1 ; INPUT
+2 ; DFN : Patient IEN
+3 ; LASTMRAR : The last MRAR Transaction IEN for the patient
+4 ; OUTPUT
+5 ; VPSMRAR: local array contains all field names/values for the last mrar
+6 ;
+7 NEW REC,INVAL,EXVAL,ALRNO,FLD,SUBS
+8 NEW FIL
SET FIL=853.52
+9 NEW ALRIEN
SET ALRIEN=0
+10 ;
+11 FOR
SET ALRIEN=$ORDER(^VPS(853.5,DFN,"MRAR",LASTMRAR,"ALLERGY",ALRIEN))
if 'ALRIEN
QUIT
Begin DoDot:1
+12 SET SUBS=ALRIEN_","_LASTMRAR_","_DFN_","
+13 KILL REC
DO GETS^DIQ(FIL,SUBS,"*","IE","REC")
+14 SET ALRNO=REC(FIL,SUBS,.01,"I")
+15 SET FLD=""
+16 FOR
SET FLD=$ORDER(REC(FIL,SUBS,FLD))
if 'FLD
QUIT
Begin DoDot:2
+17 KILL ATTR
DO FIELD^DID(FIL,FLD,"","LABEL;TYPE","ATTR")
+18 SET INVAL=REC(FIL,SUBS,FLD,"I")
+19 SET EXVAL=REC(FIL,SUBS,FLD,"E")
+20 IF FIL=853.52
IF FLD=.02
SET EXVAL=$$GET1^DIQ(120.8,INVAL_",",.02,"E")
+21 IF ATTR("TYPE")="WORD-PROCESSING"
SET EXVAL=$$WP^VPSMRAR9(.REC,FIL,SUBS,FLD)
SET INVAL=""
+22 DO ADD^VPSMRAR9(.VPSMRAR,ATTR("LABEL"),","_ALRNO,INVAL,EXVAL)
End DoDot:2
+23 ;
+24 DO ALLIND(.VPSMRAR,VPSDFN,LASTMRAR,ALRIEN,ALRNO)
+25 DO ALREACT(.VPSMRAR,VPSDFN,LASTMRAR,ALRIEN,ALRNO)
End DoDot:1
+26 ;
+27 QUIT
+28 ;
ALLIND(VPSMRAR,DFN,LASTMRAR,ALRIEN,ALRNO) ; -- retrieve Allergy Indicator level fields and store them in VPSMRAR
+1 ; INPUT
+2 ; DFN : Patient IEN
+3 ; LASTMRAR : The last MRAR Transaction IEN for the patient
+4 ; ALRIEN : Allergy IEN
+5 ; ALRNO : Allergy Entry #
+6 ; OUTPUT
+7 ; VPSMRAR : local array contains all field names/values for the last mrar
+8 ;
+9 NEW REC,INVAL,EXVAL,ATTR,SUBS
+10 NEW FIL
SET FIL("ACHG")=853.525
SET FIL("ACNFR")=853.526
SET FIL("ADISCR")=853.527
+11 NEW FLD
SET FLD=".01"
+12 ;
+13 FOR IND="ACHG","ACNFR","ADISCR"
Begin DoDot:1
+14 KILL ATTR
DO FIELD^DID(FIL(IND),FLD,"","LABEL;TYPE","ATTR")
+15 NEW INDIEN
SET INDIEN=0
+16 FOR
SET INDIEN=$ORDER(^VPS(853.5,DFN,"MRAR",LASTMRAR,"ALLERGY",ALRIEN,IND,INDIEN))
if 'INDIEN
QUIT
Begin DoDot:2
+17 SET SUBS=INDIEN_","_ALRIEN_","_LASTMRAR_","_DFN_","
+18 KILL REC
DO GETS^DIQ(FIL(IND),SUBS,"*","IE","REC")
+19 SET INVAL=REC(FIL(IND),SUBS,FLD,"I")
+20 SET EXVAL=REC(FIL(IND),SUBS,FLD,"E")
+21 DO ADD^VPSMRAR9(.VPSMRAR,ATTR("LABEL"),","_ALRNO_","_INVAL,INVAL,EXVAL)
End DoDot:2
End DoDot:1
+22 ;
+23 QUIT
+24 ;
ALREACT(VPSMRAR,VPSDFN,LASTMRAR,ALRIEN,ALRNO) ; -- retrieve Allergy Reaction level fields and store them in VPSMRAR
+1 ; INPUT
+2 ; DFN : Patient IEN
+3 ; LASTMRAR : The last MRAR Transaction IEN for the patient
+4 ; ALRIEN : Allergy IEN
+5 ; OUTPUT
+6 ; VPSMRAR : local array contains all field names/values for the last mrar
+7 ;
+8 NEW REC,INVAL,EXVAL,ATTR,FLD,SUBS,REACTNO
+9 NEW FIL
SET FIL=853.57
+10 NEW REACTIEN
SET REACTIEN=0
+11 ;
+12 FOR
SET REACTIEN=$ORDER(^VPS(853.5,DFN,"MRAR",LASTMRAR,"ALLERGY",ALRIEN,"REACTIONS",REACTIEN))
if 'REACTIEN
QUIT
Begin DoDot:1
+13 SET SUBS=REACTIEN_","_ALRIEN_","_LASTMRAR_","_DFN_","
+14 KILL REC
DO GETS^DIQ(FIL,SUBS,"*","IE","REC")
+15 SET REACTNO=REC(FIL,SUBS,".01","I")
+16 SET FLD=0
+17 FOR
SET FLD=$ORDER(REC(FIL,SUBS,FLD))
if 'FLD
QUIT
Begin DoDot:2
+18 KILL ATTR
DO FIELD^DID(FIL,FLD,"","LABEL;TYPE","ATTR")
+19 SET INVAL=REC(FIL,SUBS,FLD,"I")
+20 SET EXVAL=REC(FIL,SUBS,FLD,"E")
+21 IF ATTR("TYPE")="WORD-PROCESSING"
SET EXVAL=$$WP^VPSMRAR9(.REC,FIL,SUBS,FLD)
SET INVAL=""
+22 DO ADD^VPSMRAR9(.VPSMRAR,ATTR("LABEL"),","_ALRNO_","_REACTNO,INVAL,EXVAL)
End DoDot:2
End DoDot:1
+23 ;
+24 QUIT
+25 ;
ADDALLER(VPSMRAR,DFN,LASTMRAR) ; -- retrieve Additional Allergy level fields and store them in VPSMRAR
+1 ; INPUT
+2 ; DFN : Patient IEN
+3 ; LASTMRAR : The last MRAR Transaction IEN for the patient
+4 ; OUTPUT
+5 ; VPSMRAR: local array contains all field names/values for the last mrar
+6 ;
+7 NEW REC,INVAL,EXVAL,ALRNO,FLD,SUBS
+8 NEW FIL
SET FIL=853.53
+9 NEW ALRIEN
SET ALRIEN=0
+10 ;
+11 FOR
SET ALRIEN=$ORDER(^VPS(853.5,DFN,"MRAR",LASTMRAR,"ALLERGYADD",ALRIEN))
if 'ALRIEN
QUIT
Begin DoDot:1
+12 SET SUBS=ALRIEN_","_LASTMRAR_","_DFN_","
+13 KILL REC
DO GETS^DIQ(FIL,SUBS,"*","IE","REC")
+14 SET ALRNO=REC(FIL,SUBS,.01,"I")
+15 SET FLD=""
+16 FOR
SET FLD=$ORDER(REC(FIL,SUBS,FLD))
if 'FLD
QUIT
Begin DoDot:2
+17 KILL ATTR
DO FIELD^DID(FIL,FLD,"","LABEL;TYPE","ATTR")
+18 SET INVAL=REC(FIL,SUBS,FLD,"I")
+19 SET EXVAL=REC(FIL,SUBS,FLD,"E")
+20 IF ATTR("TYPE")="WORD-PROCESSING"
SET EXVAL=$$WP^VPSMRAR9(.REC,FIL,SUBS,FLD)
SET INVAL=""
+21 DO ADD^VPSMRAR9(.VPSMRAR,ATTR("LABEL"),","_ALRNO,INVAL,EXVAL)
End DoDot:2
End DoDot:1
+22 ;
+23 QUIT
