VPSMRAR2 ;DALOI/KML,WOIFO/BT - Cont. Update of VPS MRAR PDO file ;1/15/15 15:30
;;1.0;VA POINT OF SERVICE (KIOSKS);**3**;Jan 15, 2015;Build 64
;;Per VHA Directive 2004-038, this routine should not be modified.
;
Q
;
SUB52(PTIEN,DTIEN,FLD,DIEFLAG,DATA,REQFLDS) ; file the ALLERGY multiple (853.52)
; INPUTS
; PTIEN : D0 - Patient DFN for 853.5 entry1
; DTIEN : D1 - transaction date/time ien for 853.51 sub-entry
; FLD : Field # where the data will be filed
; DIEFLAG : Filing Type (I = Internal, E = External)
; DATA : Field Name^IENS^Field Value
; REQFLDS : Array of required fields by fieldname and entry number
;
; OUTPUT
; success : RESULT = Field Name^IENS^Field Value^1
; failed : RESULT = Field Name^IENS^Field Value^99^error text describing why data did not get filed
;
N RESULT S RESULT=""
;
; -- Check required Allergy fields
S RESULT=$$CHKALR(.REQFLDS,DATA)
Q:RESULT'="" RESULT
;
; -- Add Allergy sub entry if it doesn't exist
;N ALLERID S ALLERID=$P(DATA,U,3) ;Allergy Entry #
N ALLERID S ALLERID=$P($P(DATA,U,2),",",2) ;Allergy Entry #
I '$D(^VPS(853.5,PTIEN,"MRAR",DTIEN,"ALLERGY","B",ALLERID)) D
. N ADDOK S ADDOK=$$ADDMRAR^VPSMRAR0(853.52,DTIEN_","_PTIEN,ALLERID,DIEFLAG)
. I 'ADDOK S RESULT=$$RESULT^VPSMRAR0(DATA,99,"Data was not filed into MRAR PDO. Failed to add Allergy entry")
Q:RESULT'="" RESULT
;
; -- Get Allergy IEN
N ALLERIEN S ALLERIEN=$O(^VPS(853.5,PTIEN,"MRAR",DTIEN,"ALLERGY","B",ALLERID,""))
I ALLERIEN="" S RESULT=$$RESULT^VPSMRAR0(DATA,99,"Data was not filed into MRAR PDO")
Q:RESULT'="" RESULT
I FLD=.02,$$GET1^DIQ(120.8,$P(DATA,U,3)_",",.01,"I")'=PTIEN S RESULT=$$RESULT^VPSMRAR0(DATA,99,"DFN does not match DFN associated with PATIENT ALLERGIES")
Q:RESULT'="" RESULT
;
; -- Store 853.52 field entries
N WP S WP=FLD="1"!(FLD=2)!(FLD=3)
N IENS S IENS=ALLERIEN_","_DTIEN_","_PTIEN_","
S RESULT=$$FILE^VPSMRAR0(853.52,WP,IENS,FLD,DIEFLAG,DATA)
;
Q RESULT
;
SUB52X(SUBFIL,SUBS,PTIEN,DTIEN,DATA,REQFLDS,DIEFLAG) ; file the ALLERGY CHANGED INDICATORS (853.525)
; INPUTS
; SUBFIL : Sub File# : 853.525, 853.526, or 853.527
; SUBS : Subscript associated with the Sub File : ACHG, ACNFR, ADISCR
; PTIEN : D0 - Patient DFN for 853.5 entry1
; DTIEN : D1 - transaction date/time ien for 853.51 sub-entry
; DATA : Field Name^IENS^Field Value
; REQFLDS : Array of required fields by fieldname and entry number
; DIEFLAG : Filing Type (I = Internal, E = External)
;
; OUTPUT
; success : RESULT = Field Name^IENS^Field Value^1
; failed : RESULT = Field Name^IENS^Field Value^99^error text describing why data did not get filed
;
N RESULT S RESULT=""
;
; -- Check required Allergy fields
S RESULT=$$CHKALC(.REQFLDS,DATA)
Q:RESULT'="" RESULT
;
; -- Add Allergy changed/confirmed/discrepancy sub entry if it doesn't exist
N ALLERID S ALLERID=$P($P(DATA,U,2),",",2)
N AIEN S AIEN=$O(^VPS(853.5,PTIEN,"MRAR",DTIEN,"ALLERGY","B",ALLERID,0))
I 'AIEN S RESULT=$$RESULT^VPSMRAR0(DATA,99,"Corrupted Allergy entry")
Q:RESULT'="" RESULT
;
N ALLCHGID S ALLCHGID=$P($P(DATA,U,2),",",3)
;I $P(DATA,U,3)'=ALLCHGID S RESULT=$$RESULT^VPSMRAR0(DATA,99,"Value does not match third index")
;Q:RESULT'="" RESULT
N EXIST S EXIST=$D(^VPS(853.5,PTIEN,"MRAR",DTIEN,"ALLERGY",AIEN,SUBS,"B",ALLCHGID))
I EXIST S RESULT=$$RESULT^VPSMRAR0(DATA,99,"Duplicate Allergy Changed/Confirmed/Discrepancy entry")
Q:RESULT'="" RESULT
;
N OK S OK=$$ADDMRAR^VPSMRAR0(SUBFIL,AIEN_","_DTIEN_","_PTIEN,ALLCHGID)
I 'OK S RESULT=$$RESULT^VPSMRAR0(DATA,99,"Unable to file Allergy Changed/Confirmed/Discrepancy entry")
I OK S RESULT=$$RESULT^VPSMRAR0(DATA,1,"") ; data for specific field was filed successfully into PDO record
;
Q RESULT
;
CHKALR(REQFLDS,DATA) ;Check required Allergy fields
; INPUTS
; REQFLDS : Array of required fields by fieldname and entry number
; DATA : Field Name^IENS^Field Value
;
; OUTPUT
; success : RESULT = Field Name^IENS^Field Value^1
; failed : RESULT = Field Name^IENS^Field Value^99^error text describing why data did not get filed
;
N RESULT S RESULT=""
; -- Allergy Entry # is required field
N ALLERID S ALLERID=$P($P(DATA,U,2),",",2)
I 'ALLERID S RESULT=$$RESULT^VPSMRAR0(DATA,99,"Allergy Entry # is required")
Q:RESULT'="" RESULT
;
; -- For Local VistA, Local Allergy ID is required
; -- For Remote (CDW), Remote Allergy ID and Remote Allergy Name are required
N ISLOCAL S ISLOCAL=$D(REQFLDS("LOCAL ALLERGY ID",ALLERID))
N ISREMOTE S ISREMOTE=$D(REQFLDS("REMOTE ALLERGY ID",ALLERID))&$D(REQFLDS("REMOTE ALLERGY NAME",ALLERID))
I 'ISLOCAL&'ISREMOTE S RESULT=$$RESULT^VPSMRAR0(DATA,99,"Local Allergy ID or Remote Allergy ID and Remote Allergy Name are required")
Q RESULT
;
CHKALC(REQFLDS,DATA) ;Check required Allergy Changed/confirmed/discrepancy fields
; INPUTS
; REQFLDS : Array of required fields by fieldname and entry number
; DATA : Field Name^IENS^Field Value
;
; OUTPUT
; success : RESULT = Field Name^IENS^Field Value^1
; failed : RESULT = Field Name^IENS^Field Value^99^error text describing why data did not get filed
;
N RESULT S RESULT=""
; -- Allergy Entry # is required field
N ALLERID S ALLERID=$P($P(DATA,U,2),",",2)
I 'ALLERID S RESULT=$$RESULT^VPSMRAR0(DATA,99,"Allergy Entry # is required")
Q:RESULT'="" RESULT
;
N ALLCHGID S ALLCHGID=$P($P(DATA,U,2),",",3)
I 'ALLCHGID S RESULT=$$RESULT^VPSMRAR0(DATA,99,"Allergy Changed/Confirmed/Discrepancy is required")
Q:RESULT'="" RESULT
;
I '$D(^VPS(853.3,ALLCHGID)) S RESULT=$$RESULT^VPSMRAR0(DATA,99,"Invalid Allergy Changed/Confirmed/Discrepancy")
Q RESULT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVPSMRAR2 5776 printed Nov 22, 2024@17:53 Page 2
VPSMRAR2 ;DALOI/KML,WOIFO/BT - Cont. Update of VPS MRAR PDO file ;1/15/15 15:30
+1 ;;1.0;VA POINT OF SERVICE (KIOSKS);**3**;Jan 15, 2015;Build 64
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 QUIT
+5 ;
SUB52(PTIEN,DTIEN,FLD,DIEFLAG,DATA,REQFLDS) ; file the ALLERGY multiple (853.52)
+1 ; INPUTS
+2 ; PTIEN : D0 - Patient DFN for 853.5 entry1
+3 ; DTIEN : D1 - transaction date/time ien for 853.51 sub-entry
+4 ; FLD : Field # where the data will be filed
+5 ; DIEFLAG : Filing Type (I = Internal, E = External)
+6 ; DATA : Field Name^IENS^Field Value
+7 ; REQFLDS : Array of required fields by fieldname and entry number
+8 ;
+9 ; OUTPUT
+10 ; success : RESULT = Field Name^IENS^Field Value^1
+11 ; failed : RESULT = Field Name^IENS^Field Value^99^error text describing why data did not get filed
+12 ;
+13 NEW RESULT
SET RESULT=""
+14 ;
+15 ; -- Check required Allergy fields
+16 SET RESULT=$$CHKALR(.REQFLDS,DATA)
+17 if RESULT'=""
QUIT RESULT
+18 ;
+19 ; -- Add Allergy sub entry if it doesn't exist
+20 ;N ALLERID S ALLERID=$P(DATA,U,3) ;Allergy Entry #
+21 ;Allergy Entry #
NEW ALLERID
SET ALLERID=$PIECE($PIECE(DATA,U,2),",",2)
+22 IF '$DATA(^VPS(853.5,PTIEN,"MRAR",DTIEN,"ALLERGY","B",ALLERID))
Begin DoDot:1
+23 NEW ADDOK
SET ADDOK=$$ADDMRAR^VPSMRAR0(853.52,DTIEN_","_PTIEN,ALLERID,DIEFLAG)
+24 IF 'ADDOK
SET RESULT=$$RESULT^VPSMRAR0(DATA,99,"Data was not filed into MRAR PDO. Failed to add Allergy entry")
End DoDot:1
+25 if RESULT'=""
QUIT RESULT
+26 ;
+27 ; -- Get Allergy IEN
+28 NEW ALLERIEN
SET ALLERIEN=$ORDER(^VPS(853.5,PTIEN,"MRAR",DTIEN,"ALLERGY","B",ALLERID,""))
+29 IF ALLERIEN=""
SET RESULT=$$RESULT^VPSMRAR0(DATA,99,"Data was not filed into MRAR PDO")
+30 if RESULT'=""
QUIT RESULT
+31 IF FLD=.02
IF $$GET1^DIQ(120.8,$PIECE(DATA,U,3)_",",.01,"I")'=PTIEN
SET RESULT=$$RESULT^VPSMRAR0(DATA,99,"DFN does not match DFN associated with PATIENT ALLERGIES")
+32 if RESULT'=""
QUIT RESULT
+33 ;
+34 ; -- Store 853.52 field entries
+35 NEW WP
SET WP=FLD="1"!(FLD=2)!(FLD=3)
+36 NEW IENS
SET IENS=ALLERIEN_","_DTIEN_","_PTIEN_","
+37 SET RESULT=$$FILE^VPSMRAR0(853.52,WP,IENS,FLD,DIEFLAG,DATA)
+38 ;
+39 QUIT RESULT
+40 ;
SUB52X(SUBFIL,SUBS,PTIEN,DTIEN,DATA,REQFLDS,DIEFLAG) ; file the ALLERGY CHANGED INDICATORS (853.525)
+1 ; INPUTS
+2 ; SUBFIL : Sub File# : 853.525, 853.526, or 853.527
+3 ; SUBS : Subscript associated with the Sub File : ACHG, ACNFR, ADISCR
+4 ; PTIEN : D0 - Patient DFN for 853.5 entry1
+5 ; DTIEN : D1 - transaction date/time ien for 853.51 sub-entry
+6 ; DATA : Field Name^IENS^Field Value
+7 ; REQFLDS : Array of required fields by fieldname and entry number
+8 ; DIEFLAG : Filing Type (I = Internal, E = External)
+9 ;
+10 ; OUTPUT
+11 ; success : RESULT = Field Name^IENS^Field Value^1
+12 ; failed : RESULT = Field Name^IENS^Field Value^99^error text describing why data did not get filed
+13 ;
+14 NEW RESULT
SET RESULT=""
+15 ;
+16 ; -- Check required Allergy fields
+17 SET RESULT=$$CHKALC(.REQFLDS,DATA)
+18 if RESULT'=""
QUIT RESULT
+19 ;
+20 ; -- Add Allergy changed/confirmed/discrepancy sub entry if it doesn't exist
+21 NEW ALLERID
SET ALLERID=$PIECE($PIECE(DATA,U,2),",",2)
+22 NEW AIEN
SET AIEN=$ORDER(^VPS(853.5,PTIEN,"MRAR",DTIEN,"ALLERGY","B",ALLERID,0))
+23 IF 'AIEN
SET RESULT=$$RESULT^VPSMRAR0(DATA,99,"Corrupted Allergy entry")
+24 if RESULT'=""
QUIT RESULT
+25 ;
+26 NEW ALLCHGID
SET ALLCHGID=$PIECE($PIECE(DATA,U,2),",",3)
+27 ;I $P(DATA,U,3)'=ALLCHGID S RESULT=$$RESULT^VPSMRAR0(DATA,99,"Value does not match third index")
+28 ;Q:RESULT'="" RESULT
+29 NEW EXIST
SET EXIST=$DATA(^VPS(853.5,PTIEN,"MRAR",DTIEN,"ALLERGY",AIEN,SUBS,"B",ALLCHGID))
+30 IF EXIST
SET RESULT=$$RESULT^VPSMRAR0(DATA,99,"Duplicate Allergy Changed/Confirmed/Discrepancy entry")
+31 if RESULT'=""
QUIT RESULT
+32 ;
+33 NEW OK
SET OK=$$ADDMRAR^VPSMRAR0(SUBFIL,AIEN_","_DTIEN_","_PTIEN,ALLCHGID)
+34 IF 'OK
SET RESULT=$$RESULT^VPSMRAR0(DATA,99,"Unable to file Allergy Changed/Confirmed/Discrepancy entry")
+35 ; data for specific field was filed successfully into PDO record
IF OK
SET RESULT=$$RESULT^VPSMRAR0(DATA,1,"")
+36 ;
+37 QUIT RESULT
+38 ;
CHKALR(REQFLDS,DATA) ;Check required Allergy fields
+1 ; INPUTS
+2 ; REQFLDS : Array of required fields by fieldname and entry number
+3 ; DATA : Field Name^IENS^Field Value
+4 ;
+5 ; OUTPUT
+6 ; success : RESULT = Field Name^IENS^Field Value^1
+7 ; failed : RESULT = Field Name^IENS^Field Value^99^error text describing why data did not get filed
+8 ;
+9 NEW RESULT
SET RESULT=""
+10 ; -- Allergy Entry # is required field
+11 NEW ALLERID
SET ALLERID=$PIECE($PIECE(DATA,U,2),",",2)
+12 IF 'ALLERID
SET RESULT=$$RESULT^VPSMRAR0(DATA,99,"Allergy Entry # is required")
+13 if RESULT'=""
QUIT RESULT
+14 ;
+15 ; -- For Local VistA, Local Allergy ID is required
+16 ; -- For Remote (CDW), Remote Allergy ID and Remote Allergy Name are required
+17 NEW ISLOCAL
SET ISLOCAL=$DATA(REQFLDS("LOCAL ALLERGY ID",ALLERID))
+18 NEW ISREMOTE
SET ISREMOTE=$DATA(REQFLDS("REMOTE ALLERGY ID",ALLERID))&$DATA(REQFLDS("REMOTE ALLERGY NAME",ALLERID))
+19 IF 'ISLOCAL&'ISREMOTE
SET RESULT=$$RESULT^VPSMRAR0(DATA,99,"Local Allergy ID or Remote Allergy ID and Remote Allergy Name are required")
+20 QUIT RESULT
+21 ;
CHKALC(REQFLDS,DATA) ;Check required Allergy Changed/confirmed/discrepancy fields
+1 ; INPUTS
+2 ; REQFLDS : Array of required fields by fieldname and entry number
+3 ; DATA : Field Name^IENS^Field Value
+4 ;
+5 ; OUTPUT
+6 ; success : RESULT = Field Name^IENS^Field Value^1
+7 ; failed : RESULT = Field Name^IENS^Field Value^99^error text describing why data did not get filed
+8 ;
+9 NEW RESULT
SET RESULT=""
+10 ; -- Allergy Entry # is required field
+11 NEW ALLERID
SET ALLERID=$PIECE($PIECE(DATA,U,2),",",2)
+12 IF 'ALLERID
SET RESULT=$$RESULT^VPSMRAR0(DATA,99,"Allergy Entry # is required")
+13 if RESULT'=""
QUIT RESULT
+14 ;
+15 NEW ALLCHGID
SET ALLCHGID=$PIECE($PIECE(DATA,U,2),",",3)
+16 IF 'ALLCHGID
SET RESULT=$$RESULT^VPSMRAR0(DATA,99,"Allergy Changed/Confirmed/Discrepancy is required")
+17 if RESULT'=""
QUIT RESULT
+18 ;
+19 IF '$DATA(^VPS(853.3,ALLCHGID))
SET RESULT=$$RESULT^VPSMRAR0(DATA,99,"Invalid Allergy Changed/Confirmed/Discrepancy")
+20 QUIT RESULT
