VPSPDO2 ;DALOI/KML,WOIFO/BT - PDO OUTPUT DISPLAY - ALLERGIES (Continue);11/20/11 15:30
;;1.0;VA POINT OF SERVICE (KIOSKS);**3**;Oct 21, 2011;Build 64
;;Per VHA Directive 2004-038, this routine should not be modified.
;
Q
;
BLDADD(OREF) ; build additional allergies section for Patient Entered allergy medication review note
; INPUT
; OREF : Object Reference for the VPS PDO object
;
D ADDCJ^VPSOBJ(OREF,"Patient-entered allergy reactions/comments")
N PTIEN S PTIEN=$$GETDFN^VPSOBJ(OREF)
N LASTMRAR S LASTMRAR=$$GETLSTMR^VPSOBJ(OREF)
;
N HDR S HDR=0
N VPSX S VPSX=""
N ALRID,ALRIEN S (ALRID,ALRIEN)=0
;
F S ALRID=$O(^VPS(853.5,PTIEN,"MRAR",LASTMRAR,"ALLERGYADD","B",ALRID)) Q:'ALRID F S ALRIEN=$O(^(ALRID,ALRIEN)) Q:'ALRIEN D
. D INTADDAL(OREF,ALRIEN) ; initialize additional allergy info
. D PREPCOM(OREF) ; prepare additional allergies comments to build
. I 'HDR S HDR=1 D ADDADHDR(OREF) ; build additional allergy header
. D ADDADALR(OREF) ; build additional allergy items
. D ADDBLANK^VPSOBJ(OREF) ; add a blank line between each additional allergies
;
D ADDBLANK^VPSOBJ(OREF) ; add a blank line between additional allergies and next section
Q
;
INTADDAL(OREF,ALRIEN) ; initialize additional allergy info
; INPUT
; OREF : Object Reference for the VPS PDO object
; ALRIEN : Additional Allergy IEN
;
N PTIEN S PTIEN=$$GETDFN^VPSOBJ(OREF)
N LASTMRAR S LASTMRAR=$$GETLSTMR^VPSOBJ(OREF)
N STAFF S STAFF=$$GETSTAFF^VPSOBJ(OREF)
;
N ADALRVT S ADALRVT=$$GET1^DIQ(853.53,ALRIEN_","_LASTMRAR_","_PTIEN_",",1,"","ADALRVT") ; Additional allergy entered by the patient
D SETADDVT^VPSOBJ(OREF,.ADALRVT)
K ADALRVT
;
N ADALRPR S ADALRPR=$$GET1^DIQ(853.53,ALRIEN_","_LASTMRAR_","_PTIEN_",",1.5,"","ADALRPR") ; Additional allergy typed in by provider
D SETADDPR^VPSOBJ(OREF,.ADALRPR)
K ADALRPR
;
N ADDREACT S ADDREACT=$$GET1^DIQ(853.53,ALRIEN_","_LASTMRAR_","_PTIEN_",",2) ; REACTION to the additional allergy typed in by the provider (staff-facing)
D SETADRCT^VPSOBJ(OREF,ADDREACT)
;
I STAFF D
. N MARKFOL S MARKFOL=$S($$GET1^DIQ(853.53,ALRIEN_","_LASTMRAR_","_PTIEN_",",4)]"":">>",1:"") ; mark for follow-up for patient facilitated output
. D SETADDMF^VPSOBJ(OREF,MARKFOL)
Q
;
PREPCOM(OREF) ; prepare additional allergies comments to build
; INPUT
; OREF : Object Reference for the VPS PDO object
;
N COL D GETFORMT^VPSOBJ(OREF,.COL)
N STAFF S STAFF=$$GETSTAFF^VPSOBJ(OREF)
;
I 'STAFF D ; prepare additional veteran comment
. N ALRVET D GETADDVT^VPSOBJ(OREF,.ALRVET)
. Q:$G(ALRVET)']""
. S ^TMP("VPSPUTL1",$J)=0
. N FALRVET D FCOMM^VPSPUTL1(.ALRVET,$P(COL("ADDALLERGY-VET"),U,2),.FALRVET)
. N DONTKNOW S DONTKNOW=$$GETDKNW^VPSOBJ(OREF)
. N FDONTKNW
. I DONTKNOW]"" S DONTKNOW(1)=" ;"_DONTKNOW D FCOMM^VPSPUTL1(.DONTKNOW,$P(COL("ADDALLERGY-VET"),U,2),.FDONTKNW)
. N TEMP M TEMP=FALRVET,TEMP=FDONTKNW
. S ^TMP("VPSPUTL1",$J)=0
. N ADDCOMM D FCOMM^VPSPUTL1(.TEMP,$P(COL("ADDALLERGY-VET"),U,2),.ADDCOMM)
. D SETADDFV^VPSOBJ(OREF,.ADDCOMM)
. K FALRVET,FDONTKNOW,ALRVET,ADDCOMM
;
I STAFF D ; prepare additional comment by provider
. N ALRPR D GETADDPR^VPSOBJ(OREF,.ALRPR)
. I $G(ALRPR)]"" D
. . S ^TMP("VPSPUTL1",$J)=0
. . N FALRPR D FCOMM^VPSPUTL1(.ALRPR,$P(COL("ALLERNM"),U,2),.FALRPR)
. . D SETADDFP^VPSOBJ(OREF,.FALRPR)
. . K FALRPR
. ;
. N ADDREACT S ADDREACT=$$GETADRCT^VPSOBJ(OREF)
. I ADDREACT]"" D
. . S ADDREACT(1)=ADDREACT
. . S ^TMP("VPSPUTL1",$J)=0
. . N FADDRCT D FCOMM^VPSPUTL1(.ADDREACT,$P(COL("REACTION"),U,2),.FADDRCT)
. . D SETADDFR^VPSOBJ(OREF,.FADDRCT)
. . K FADDRCT
Q
;
ADDADHDR(OREF) ; build additional allergy header
; INPUT
; OREF : Object Reference for the VPS PDO object
;
N COL D GETFORMT^VPSOBJ(OREF,.COL)
N VPSX S VPSX=""
S VPSX=$$SETFLD^VPSPUTL1("Name",VPSX,COL("ALLERNM"))
S VPSX=$$SETFLD^VPSPUTL1("Reaction",VPSX,COL("REACTION"))
D ADDPDO^VPSOBJ(OREF,VPSX)
Q
;
ADDADALR(OREF) ; build additional allergy items
; INPUT
; OREF : Object Reference for the VPS PDO object
;
N COL D GETFORMT^VPSOBJ(OREF,.COL)
N STAFF S STAFF=$$GETSTAFF^VPSOBJ(OREF)
;
I 'STAFF D
. N ADDCOMM D GETADDFV^VPSOBJ(OREF,.ADDCOMM)
. N VPSX S VPSX=""
. N RSS S RSS=0
. F S RSS=$O(ADDCOMM(RSS)) Q:'RSS D
. . S VPSX=$$SETFLD^VPSPUTL1(ADDCOMM(RSS),VPSX,COL("ADDALLERGY-VET"))
. . D ADDPDO^VPSOBJ(OREF,VPSX)
;
I STAFF D
. N ADDCOMM D GETADDFP^VPSOBJ(OREF,.ADDCOMM)
. N REACT D GETADDFR^VPSOBJ(OREF,.REACT)
. N MARKFOL S MARKFOL=0
. N VPSX S VPSX=""
. N RSS S RSS=0
. F S RSS=$O(ADDCOMM(RSS)) Q:'RSS D
. . I RSS=1 D
. . . S MARKFOL=$$GETADDMF^VPSOBJ(OREF)
. . . S VPSX=$$SETFLD^VPSPUTL1(MARKFOL,VPSX,COL("FOLLOWUP"))
. . S VPSX=$$SETFLD^VPSPUTL1(ADDCOMM(RSS),VPSX,COL("ALLERNM"))
. . S VPSX=$$SETFLD^VPSPUTL1($G(REACT(RSS)),VPSX,COL("REACTION"))
. . D ADDPDO^VPSOBJ(OREF,VPSX)
. ;build the rest of reaction incase reaction lines are longer than allergy lines
. S RSS=$O(ADDCOMM(""),-1)
. S VPSX=""
. F S RSS=$O(REACT(RSS)) Q:'RSS D
. . S VPSX=$$SETFLD^VPSPUTL1(MARKFOL,VPSX,COL("FOLLOWUP"))
. . S VPSX=$$SETFLD^VPSPUTL1($G(REACT(RSS)),VPSX,COL("REACTION"))
. . D ADDPDO^VPSOBJ(OREF,VPSX)
Q
;
GETCH(OREF) ;retrieve any changes to allergy profile since last MRAR
; ICR 5843 - Controlled Subscription for read of PATIENT ALLERGIES file (120.8)
; INPUT
; OREF : Object Reference for the VPS PDO object
;
N PTIEN S PTIEN=$$GETDFN^VPSOBJ(OREF)
N LASTMRAR S LASTMRAR=$$GETLSTMR^VPSOBJ(OREF)
N ALLITMS D GETALLR^VPSOBJ(OREF,.ALLITMS)
;
N HDR S HDR=0
N VPSX S VPSX=""
N VDA S VDA=0
;
F S VDA=$O(^GMR(120.8,"B",PTIEN,VDA)) Q:'VDA D
. Q:LASTMRAR>+$$GET1^DIQ(120.8,VDA_",",20,"I") ; if VPS trxn date/time is greater than what is stored in patient allergy profile then not a changed or added allergy so skip this allergy entry
. Q:+$$GET1^DIQ(120.8,VDA_",",21,"I")=0 ; if VERIFIED BY is not populated do not display the allergy
. ;
. ; -- get the newly entered allergy
. N ANAME S ANAME=$$GET1^DIQ(120.8,VDA_",",.02)
. ;
. ; -- set action
. N ENTERR S ENTERR=+$$GET1^DIQ(120.8,VDA_",",22,"I") ;entered in error
. N ACTION
. I '$D(ALLITMS(ANAME)) S ACTION=$S(ENTERR:"Deleted",1:"Added")
. I $D(ALLITMS(ANAME)) S ACTION=$S(ENTERR:"Deleted",1:"Changed")
. ;
. ; -- get reactions
. N REACTION
. N VIEN S VIEN=0
. N SEQ S SEQ=0
. F S VIEN=$O(^GMR(120.8,VDA,10,VIEN)) Q:'VIEN D
. . N VIENS S VIENS=VIEN_","_VDA_","
. . S SEQ=SEQ+1,REACTION(SEQ)=$$GET1^DIQ(120.81,VIENS,".01")
. ;
. ; build allergies changes
. I 'HDR S HDR=1 D ADDCHGHD(OREF)
. D ADDCHG(OREF,ANAME,.REACTION,ACTION)
. D ADDBLANK^VPSOBJ(OREF) ; add a blank line between allergy sets with multiple reactions
Q
;
ADDCHGHD(OREF) ; build allergies changes header
D ADDCJ^VPSOBJ(OREF,"*** CHANGES TO ALLERGIES SINCE MRAR LAST COMPLETED ***")
N COL D GETFORMT^VPSOBJ(OREF,.COL)
N VPSX S VPSX=""
S VPSX=$$SETFLD^VPSPUTL1("Name",VPSX,COL("ALLERNM"))
S VPSX=$$SETFLD^VPSPUTL1("Reaction",VPSX,COL("REACTION"))
S VPSX=$$SETFLD^VPSPUTL1("Action",VPSX,COL("ACTION"))
D ADDPDO^VPSOBJ(OREF,VPSX)
Q
;
ADDCHG(OREF,ANAME,REACTION,ACTION) ; build allergies changes
; INPUT
; OREF : Object Reference for the VPS PDO object
; ANAME : newly entered Allergy name
; REACTION : array of reactions of the allergy
; ACTION : what to do with the reaction review
;
N COL D GETFORMT^VPSOBJ(OREF,.COL)
N VPSX S VPSX=""
S VPSX=$$SETFLD^VPSPUTL1(ANAME,VPSX,COL("ALLERNM"))
S VPSX=$$SETFLD^VPSPUTL1(REACTION(1),VPSX,COL("REACTION"))
S VPSX=$$SETFLD^VPSPUTL1(ACTION,VPSX,COL("ACTION"))
D ADDPDO^VPSOBJ(OREF,VPSX)
;
N RSS S RSS=1
S VPSX=""
F S RSS=$O(REACTION(RSS)) Q:'RSS D
. S VPSX=$$SETFLD^VPSPUTL1(REACTION(RSS),VPSX,COL("REACTION"))
. D ADDPDO^VPSOBJ(OREF,VPSX)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVPSPDO2 7929 printed Sep 23, 2025@20:19:37 Page 2
VPSPDO2 ;DALOI/KML,WOIFO/BT - PDO OUTPUT DISPLAY - ALLERGIES (Continue);11/20/11 15:30
+1 ;;1.0;VA POINT OF SERVICE (KIOSKS);**3**;Oct 21, 2011;Build 64
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 QUIT
+5 ;
BLDADD(OREF) ; build additional allergies section for Patient Entered allergy medication review note
+1 ; INPUT
+2 ; OREF : Object Reference for the VPS PDO object
+3 ;
+4 DO ADDCJ^VPSOBJ(OREF,"Patient-entered allergy reactions/comments")
+5 NEW PTIEN
SET PTIEN=$$GETDFN^VPSOBJ(OREF)
+6 NEW LASTMRAR
SET LASTMRAR=$$GETLSTMR^VPSOBJ(OREF)
+7 ;
+8 NEW HDR
SET HDR=0
+9 NEW VPSX
SET VPSX=""
+10 NEW ALRID,ALRIEN
SET (ALRID,ALRIEN)=0
+11 ;
+12 FOR
SET ALRID=$ORDER(^VPS(853.5,PTIEN,"MRAR",LASTMRAR,"ALLERGYADD","B",ALRID))
if 'ALRID
QUIT
FOR
SET ALRIEN=$ORDER(^(ALRID,ALRIEN))
if 'ALRIEN
QUIT
Begin DoDot:1
+13 ; initialize additional allergy info
DO INTADDAL(OREF,ALRIEN)
+14 ; prepare additional allergies comments to build
DO PREPCOM(OREF)
+15 ; build additional allergy header
IF 'HDR
SET HDR=1
DO ADDADHDR(OREF)
+16 ; build additional allergy items
DO ADDADALR(OREF)
+17 ; add a blank line between each additional allergies
DO ADDBLANK^VPSOBJ(OREF)
End DoDot:1
+18 ;
+19 ; add a blank line between additional allergies and next section
DO ADDBLANK^VPSOBJ(OREF)
+20 QUIT
+21 ;
INTADDAL(OREF,ALRIEN) ; initialize additional allergy info
+1 ; INPUT
+2 ; OREF : Object Reference for the VPS PDO object
+3 ; ALRIEN : Additional Allergy IEN
+4 ;
+5 NEW PTIEN
SET PTIEN=$$GETDFN^VPSOBJ(OREF)
+6 NEW LASTMRAR
SET LASTMRAR=$$GETLSTMR^VPSOBJ(OREF)
+7 NEW STAFF
SET STAFF=$$GETSTAFF^VPSOBJ(OREF)
+8 ;
+9 ; Additional allergy entered by the patient
NEW ADALRVT
SET ADALRVT=$$GET1^DIQ(853.53,ALRIEN_","_LASTMRAR_","_PTIEN_",",1,"","ADALRVT")
+10 DO SETADDVT^VPSOBJ(OREF,.ADALRVT)
+11 KILL ADALRVT
+12 ;
+13 ; Additional allergy typed in by provider
NEW ADALRPR
SET ADALRPR=$$GET1^DIQ(853.53,ALRIEN_","_LASTMRAR_","_PTIEN_",",1.5,"","ADALRPR")
+14 DO SETADDPR^VPSOBJ(OREF,.ADALRPR)
+15 KILL ADALRPR
+16 ;
+17 ; REACTION to the additional allergy typed in by the provider (staff-facing)
NEW ADDREACT
SET ADDREACT=$$GET1^DIQ(853.53,ALRIEN_","_LASTMRAR_","_PTIEN_",",2)
+18 DO SETADRCT^VPSOBJ(OREF,ADDREACT)
+19 ;
+20 IF STAFF
Begin DoDot:1
+21 ; mark for follow-up for patient facilitated output
NEW MARKFOL
SET MARKFOL=$SELECT($$GET1^DIQ(853.53,ALRIEN_","_LASTMRAR_","_PTIEN_",",4)]"":">>",1:"")
+22 DO SETADDMF^VPSOBJ(OREF,MARKFOL)
End DoDot:1
+23 QUIT
+24 ;
PREPCOM(OREF) ; prepare additional allergies comments to build
+1 ; INPUT
+2 ; OREF : Object Reference for the VPS PDO object
+3 ;
+4 NEW COL
DO GETFORMT^VPSOBJ(OREF,.COL)
+5 NEW STAFF
SET STAFF=$$GETSTAFF^VPSOBJ(OREF)
+6 ;
+7 ; prepare additional veteran comment
IF 'STAFF
Begin DoDot:1
+8 NEW ALRVET
DO GETADDVT^VPSOBJ(OREF,.ALRVET)
+9 if $GET(ALRVET)']""
QUIT
+10 SET ^TMP("VPSPUTL1",$JOB)=0
+11 NEW FALRVET
DO FCOMM^VPSPUTL1(.ALRVET,$PIECE(COL("ADDALLERGY-VET"),U,2),.FALRVET)
+12 NEW DONTKNOW
SET DONTKNOW=$$GETDKNW^VPSOBJ(OREF)
+13 NEW FDONTKNW
+14 IF DONTKNOW]""
SET DONTKNOW(1)=" ;"_DONTKNOW
DO FCOMM^VPSPUTL1(.DONTKNOW,$PIECE(COL("ADDALLERGY-VET"),U,2),.FDONTKNW)
+15 NEW TEMP
MERGE TEMP=FALRVET,TEMP=FDONTKNW
+16 SET ^TMP("VPSPUTL1",$JOB)=0
+17 NEW ADDCOMM
DO FCOMM^VPSPUTL1(.TEMP,$PIECE(COL("ADDALLERGY-VET"),U,2),.ADDCOMM)
+18 DO SETADDFV^VPSOBJ(OREF,.ADDCOMM)
+19 KILL FALRVET,FDONTKNOW,ALRVET,ADDCOMM
End DoDot:1
+20 ;
+21 ; prepare additional comment by provider
IF STAFF
Begin DoDot:1
+22 NEW ALRPR
DO GETADDPR^VPSOBJ(OREF,.ALRPR)
+23 IF $GET(ALRPR)]""
Begin DoDot:2
+24 SET ^TMP("VPSPUTL1",$JOB)=0
+25 NEW FALRPR
DO FCOMM^VPSPUTL1(.ALRPR,$PIECE(COL("ALLERNM"),U,2),.FALRPR)
+26 DO SETADDFP^VPSOBJ(OREF,.FALRPR)
+27 KILL FALRPR
End DoDot:2
+28 ;
+29 NEW ADDREACT
SET ADDREACT=$$GETADRCT^VPSOBJ(OREF)
+30 IF ADDREACT]""
Begin DoDot:2
+31 SET ADDREACT(1)=ADDREACT
+32 SET ^TMP("VPSPUTL1",$JOB)=0
+33 NEW FADDRCT
DO FCOMM^VPSPUTL1(.ADDREACT,$PIECE(COL("REACTION"),U,2),.FADDRCT)
+34 DO SETADDFR^VPSOBJ(OREF,.FADDRCT)
+35 KILL FADDRCT
End DoDot:2
End DoDot:1
+36 QUIT
+37 ;
ADDADHDR(OREF) ; build additional allergy header
+1 ; INPUT
+2 ; OREF : Object Reference for the VPS PDO object
+3 ;
+4 NEW COL
DO GETFORMT^VPSOBJ(OREF,.COL)
+5 NEW VPSX
SET VPSX=""
+6 SET VPSX=$$SETFLD^VPSPUTL1("Name",VPSX,COL("ALLERNM"))
+7 SET VPSX=$$SETFLD^VPSPUTL1("Reaction",VPSX,COL("REACTION"))
+8 DO ADDPDO^VPSOBJ(OREF,VPSX)
+9 QUIT
+10 ;
ADDADALR(OREF) ; build additional allergy items
+1 ; INPUT
+2 ; OREF : Object Reference for the VPS PDO object
+3 ;
+4 NEW COL
DO GETFORMT^VPSOBJ(OREF,.COL)
+5 NEW STAFF
SET STAFF=$$GETSTAFF^VPSOBJ(OREF)
+6 ;
+7 IF 'STAFF
Begin DoDot:1
+8 NEW ADDCOMM
DO GETADDFV^VPSOBJ(OREF,.ADDCOMM)
+9 NEW VPSX
SET VPSX=""
+10 NEW RSS
SET RSS=0
+11 FOR
SET RSS=$ORDER(ADDCOMM(RSS))
if 'RSS
QUIT
Begin DoDot:2
+12 SET VPSX=$$SETFLD^VPSPUTL1(ADDCOMM(RSS),VPSX,COL("ADDALLERGY-VET"))
+13 DO ADDPDO^VPSOBJ(OREF,VPSX)
End DoDot:2
End DoDot:1
+14 ;
+15 IF STAFF
Begin DoDot:1
+16 NEW ADDCOMM
DO GETADDFP^VPSOBJ(OREF,.ADDCOMM)
+17 NEW REACT
DO GETADDFR^VPSOBJ(OREF,.REACT)
+18 NEW MARKFOL
SET MARKFOL=0
+19 NEW VPSX
SET VPSX=""
+20 NEW RSS
SET RSS=0
+21 FOR
SET RSS=$ORDER(ADDCOMM(RSS))
if 'RSS
QUIT
Begin DoDot:2
+22 IF RSS=1
Begin DoDot:3
+23 SET MARKFOL=$$GETADDMF^VPSOBJ(OREF)
+24 SET VPSX=$$SETFLD^VPSPUTL1(MARKFOL,VPSX,COL("FOLLOWUP"))
End DoDot:3
+25 SET VPSX=$$SETFLD^VPSPUTL1(ADDCOMM(RSS),VPSX,COL("ALLERNM"))
+26 SET VPSX=$$SETFLD^VPSPUTL1($GET(REACT(RSS)),VPSX,COL("REACTION"))
+27 DO ADDPDO^VPSOBJ(OREF,VPSX)
End DoDot:2
+28 ;build the rest of reaction incase reaction lines are longer than allergy lines
+29 SET RSS=$ORDER(ADDCOMM(""),-1)
+30 SET VPSX=""
+31 FOR
SET RSS=$ORDER(REACT(RSS))
if 'RSS
QUIT
Begin DoDot:2
+32 SET VPSX=$$SETFLD^VPSPUTL1(MARKFOL,VPSX,COL("FOLLOWUP"))
+33 SET VPSX=$$SETFLD^VPSPUTL1($GET(REACT(RSS)),VPSX,COL("REACTION"))
+34 DO ADDPDO^VPSOBJ(OREF,VPSX)
End DoDot:2
End DoDot:1
+35 QUIT
+36 ;
GETCH(OREF) ;retrieve any changes to allergy profile since last MRAR
+1 ; ICR 5843 - Controlled Subscription for read of PATIENT ALLERGIES file (120.8)
+2 ; INPUT
+3 ; OREF : Object Reference for the VPS PDO object
+4 ;
+5 NEW PTIEN
SET PTIEN=$$GETDFN^VPSOBJ(OREF)
+6 NEW LASTMRAR
SET LASTMRAR=$$GETLSTMR^VPSOBJ(OREF)
+7 NEW ALLITMS
DO GETALLR^VPSOBJ(OREF,.ALLITMS)
+8 ;
+9 NEW HDR
SET HDR=0
+10 NEW VPSX
SET VPSX=""
+11 NEW VDA
SET VDA=0
+12 ;
+13 FOR
SET VDA=$ORDER(^GMR(120.8,"B",PTIEN,VDA))
if 'VDA
QUIT
Begin DoDot:1
+14 ; if VPS trxn date/time is greater than what is stored in patient allergy profile then not a changed or added allergy so skip this allergy entry
if LASTMRAR>+$$GET1^DIQ(120.8,VDA_",",20,"I")
QUIT
+15 ; if VERIFIED BY is not populated do not display the allergy
if +$$GET1^DIQ(120.8,VDA_",",21,"I")=0
QUIT
+16 ;
+17 ; -- get the newly entered allergy
+18 NEW ANAME
SET ANAME=$$GET1^DIQ(120.8,VDA_",",.02)
+19 ;
+20 ; -- set action
+21 ;entered in error
NEW ENTERR
SET ENTERR=+$$GET1^DIQ(120.8,VDA_",",22,"I")
+22 NEW ACTION
+23 IF '$DATA(ALLITMS(ANAME))
SET ACTION=$SELECT(ENTERR:"Deleted",1:"Added")
+24 IF $DATA(ALLITMS(ANAME))
SET ACTION=$SELECT(ENTERR:"Deleted",1:"Changed")
+25 ;
+26 ; -- get reactions
+27 NEW REACTION
+28 NEW VIEN
SET VIEN=0
+29 NEW SEQ
SET SEQ=0
+30 FOR
SET VIEN=$ORDER(^GMR(120.8,VDA,10,VIEN))
if 'VIEN
QUIT
Begin DoDot:2
+31 NEW VIENS
SET VIENS=VIEN_","_VDA_","
+32 SET SEQ=SEQ+1
SET REACTION(SEQ)=$$GET1^DIQ(120.81,VIENS,".01")
End DoDot:2
+33 ;
+34 ; build allergies changes
+35 IF 'HDR
SET HDR=1
DO ADDCHGHD(OREF)
+36 DO ADDCHG(OREF,ANAME,.REACTION,ACTION)
+37 ; add a blank line between allergy sets with multiple reactions
DO ADDBLANK^VPSOBJ(OREF)
End DoDot:1
+38 QUIT
+39 ;
ADDCHGHD(OREF) ; build allergies changes header
+1 DO ADDCJ^VPSOBJ(OREF,"*** CHANGES TO ALLERGIES SINCE MRAR LAST COMPLETED ***")
+2 NEW COL
DO GETFORMT^VPSOBJ(OREF,.COL)
+3 NEW VPSX
SET VPSX=""
+4 SET VPSX=$$SETFLD^VPSPUTL1("Name",VPSX,COL("ALLERNM"))
+5 SET VPSX=$$SETFLD^VPSPUTL1("Reaction",VPSX,COL("REACTION"))
+6 SET VPSX=$$SETFLD^VPSPUTL1("Action",VPSX,COL("ACTION"))
+7 DO ADDPDO^VPSOBJ(OREF,VPSX)
+8 QUIT
+9 ;
ADDCHG(OREF,ANAME,REACTION,ACTION) ; build allergies changes
+1 ; INPUT
+2 ; OREF : Object Reference for the VPS PDO object
+3 ; ANAME : newly entered Allergy name
+4 ; REACTION : array of reactions of the allergy
+5 ; ACTION : what to do with the reaction review
+6 ;
+7 NEW COL
DO GETFORMT^VPSOBJ(OREF,.COL)
+8 NEW VPSX
SET VPSX=""
+9 SET VPSX=$$SETFLD^VPSPUTL1(ANAME,VPSX,COL("ALLERNM"))
+10 SET VPSX=$$SETFLD^VPSPUTL1(REACTION(1),VPSX,COL("REACTION"))
+11 SET VPSX=$$SETFLD^VPSPUTL1(ACTION,VPSX,COL("ACTION"))
+12 DO ADDPDO^VPSOBJ(OREF,VPSX)
+13 ;
+14 NEW RSS
SET RSS=1
+15 SET VPSX=""
+16 FOR
SET RSS=$ORDER(REACTION(RSS))
if 'RSS
QUIT
Begin DoDot:1
+17 SET VPSX=$$SETFLD^VPSPUTL1(REACTION(RSS),VPSX,COL("REACTION"))
+18 DO ADDPDO^VPSOBJ(OREF,VPSX)
End DoDot:1
+19 QUIT
