VPSPARAM ;WOIFO/BT - Update VPS PARAMETER file ;11/14/12 15:30
;;1.0;VA POINT OF SERVICE (KIOSKS);**3**;Nov 14, 2012;Build 64
;;Per VHA Directive 2004-038, this routine should not be modified.
;;
Q
;
WRITE(RESULT,PARAMTYP,PARAMNAM,PARAM) ; RPC: VPS WRITE KIOSK PARAMETERS
; Many facets of MRAR behavior are dictated by a set of business parameters defined and
; entered by the healthcare facility administrator.
; For statistical purposes, VetLink will call this RPC to store these configuration changes.
; There are two ways to store the configuration changes, by KioskGroup and by Clinic.
;
; INPUT
; RESULT : the results of processing and passed in by reference (required by RPC Broker)
; PARAMTYP : type of configuration changes, By KIOSK GROUP (K) or by Clinic (C).
; PARAMNAM : KIOSK GROUP or CLINIC IEN depend on the PARMTYP.
; PARAM : array representing the configuration parameters changed made in Vetlinks passed in by reference
; PARAM(0..n) = FIELD NAME^FIELD VALUE
; n is an incremental number;
; FIELD NAME represents the field that was changed in VetLink
; FIELD VALUE is the actual data that was updated in VetLink and to be stored in File 853.
;
; OUTPUT
; RESULT : array that returns the results of each updated field per array data element.
; SUCCESS RESULT:
; RESULT(n) = FIELD NAME^FIELD VALUE^1
; '1' at the end of the result string indicates successful update to the database of the specific field declared at field label.
;
; FAILED RESULT :
; RESULT(n)="FIELD NAME^FIELD VALUE^99^exception message"
; '99^exception message' at the end of the result string indicates an exception and no update was made to the database for that specific field and exception message describes the error.
;
K RESULT
S RESULT(0)=$$ISVALID($G(PARAMTYP),$G(PARAMNAM),.PARAM)
Q:RESULT(0)'=""
;
; -- Lock File 853 before adding/updating
N XREF S XREF=$S(PARAMTYP="C":"C",1:"D")
L +^VPS(853,XREF,PARAMNAM):5 E S RESULT(0)=$$RESULT(99,"VPS PARAMETER",PARAMTYP_","_PARAMNAM,"VPS PARAMETER cannot be locked for this Parameter Name. Update cannot occur at this time.") Q
;
; -- Create PARAM TOP Level if doesn't exist
I '$D(^VPS(853,XREF,PARAMNAM)) S RESULT(0)=$$CRPARAM(PARAMTYP,PARAMNAM)
;
; -- Store parameters
I RESULT(0)="" D UPDPARAM(PARAMTYP,PARAMNAM,.PARAM,.RESULT)
;
L -^VPS(853,XREF,PARAMNAM)
Q
;
UPDPARAM(PARAMTYP,PARAMNAM,PARAM,RESULT) ;Store input parameters
; INPUT
; PARAMTYP : type of configuration changes, By KIOSK GROUP (K) or by Clinic (C).
; PARAMNAM : KIOSK GROUP or CLINIC IEN depend on the PARMTYP.
; PARAM : array representing the configuration parameters changed made in Vetlinks passed in by reference
; PARAM(0..n) = FIELD NAME^FIELD VALUE
; n is an incremental number;
; FIELD NAME represents the field that was changed in VetLink
; FIELD VALUE is the actual data that was updated in VetLink and to be stored in File 853.
;
; INPUT/OUTPUT
; RESULT : array that returns the results of each updated field per array data element.
; SUCCESS RESULT:
; RESULT(n) = FIELD NAME^FIELD VALUE^1
; '1' at the end of the result string indicates successful update to the database of the specific field declared at field label.
;
; FAILED RESULT :
; RESULT(n)="FIELD NAME^FIELD VALUE^99^exception message"
; '99^exception message' at the end of the result string indicates an exception and no update was made to the database for that specific field and exception message describes the error.
;
; -- Get VPS PARAM IEN
N PARAMIEN S PARAMIEN=$$GPARMIEN(PARAMTYP,PARAMNAM)
I 'PARAMIEN S RESULT(0)=$$RESULT(99,"VPS PARAMETER",PARAMTYP_","_PARAMNAM,"Unable to retrieve record for this Parameter Name. Update cannot occur at this time.") Q
;
; -- Store parameters
K RESULT
N MULT,RSNTYP
N TRNDT S TRNDT=$$NOW^XLFDT() ; IA #10103 - supported use of XLFDT function
N FLDDEF D TABLE(.FLDDEF) ;get array of valid fields defined to VPS PARAMETER (#853)
N SUB S SUB=""
;
F S SUB=$O(PARAM(SUB)) Q:SUB="" D
. N FLDNAM S FLDNAM=$P(PARAM(SUB),U,1)
. N FLDVAL S FLDVAL=$P(PARAM(SUB),U,2)
. S:FLDNAM="" RESULT(SUB)=$$RESULT(99,FLDNAM,FLDVAL,"Missing Field. Data not written.")
. Q:FLDNAM=""
. S:'$D(FLDDEF(FLDNAM)) RESULT(SUB)=$$RESULT(99,FLDNAM,FLDVAL,FLDNAM_" does not exist in VPS CONFIG HISTORY file. Data not written.")
. Q:'$D(FLDDEF(FLDNAM))
. N FLDVAL S FLDVAL=$P(PARAM(SUB),U,2)
. N ISMULT S ISMULT=($P(FLDDEF(FLDNAM),U,4)'="")
. I 'ISMULT S RESULT(SUB)=$$STRFIL(TRNDT,PARAMIEN,FLDDEF(FLDNAM),FLDNAM,FLDVAL) ;file the data to 853.01 sub-entry
. I ISMULT D ; save multiple in a MULT array and store later, want to make sure .01 field is valid
. . N FIL S FIL=$P(FLDDEF(FLDNAM),U,1)
. . N FLD S FLD=$P(FLDDEF(FLDNAM),U,2)
. . N RSNTYP S RSNTYP=$P(FLDVAL,",")
. . N VALID S VALID=RSNTYP>0&(RSNTYP<6)
. . S:VALID MULT(FIL,FLDNAM,RSNTYP)=SUB_U_FLDVAL
. . S:'VALID RESULT(SUB)=$$RESULT(99,FLDNAM,FLDVAL,"Invalid Incomplete Reason Type")
;
; - Store multiple fields
I $D(MULT) D STRMULT(.RESULT,PARAMIEN,TRNDT,.FLDDEF,.MULT)
Q
;
STRMULT(RESULT,PARAMIEN,TRNDT,FLDDEF,MULT) ; Store multiple fields
; INPUT/OUTPUT
; RESULT : array that returns the results of each updated field per array data element.
; INPUT
; TRNDT : Transaction Date/Time - this field is also used as SUB IEN for this Transaction Level
; PARAMIEN : PARAMETER IEN for file 853
; FLDDEF : array of field name definition
; MULT : array of multiple field entries
; RSNTYP : array of Incomplete Reason Types
;
N FIL S FIL=""
F S FIL=$O(MULT(FIL)) Q:FIL="" D
. N FLDNAM S FLDNAM=""
. F S FLDNAM=$O(MULT(FIL,FLDNAM)) Q:FLDNAM="" D
. . N RSNTYP S RSNTYP=""
. . F S RSNTYP=$O(MULT(FIL,FLDNAM,RSNTYP)) Q:RSNTYP="" D
. . . N REC S REC=MULT(FIL,FLDNAM,RSNTYP)
. . . N SUB S SUB=$P(REC,U)
. . . N FLDVAL S FLDVAL=$P(REC,U,2)
. . . S RESULT(SUB)=$$STRFIL(TRNDT,PARAMIEN,FLDDEF(FLDNAM),FLDNAM,FLDVAL) ;file the data to 853.01 sub-entry
Q
;
ISVALID(PARAMTYP,PARAMNAM,PARAM) ;validate RPC input parameters
; INPUT
; PARAMTYP : type of configuration changes, (eg, By KIOSK GROUP (K) or by Clinic (C)).
; PARAMNAM : Value of Parameter, (eg, KIOSK GROUP or CLINIC IEN depend on the PARMTYP.)
; PARAM : local array representing the configuration parameters changed made in Vetlinks passed in by reference
; OUTPUT
; SUCCESS : Empty String
; FAILED : FIELD NAME^FIELD VALUE^99^exception
;
N PARAMVAL S PARAMVAL=PARAMTYP_","_PARAMNAM
S PARAMTYP=$$STRIP^XLFSTR(PARAMTYP," ") ;Parameter Type can't be empty - IA #10104
I PARAMTYP="" Q $$RESULT(99,"VPS PARAMETER",PARAMVAL,"Invalid Parameter Type")
I '$F(",K,C,",","_PARAMTYP_",") Q $$RESULT(99,"VPS PARAMETER",PARAMVAL,"Parameter Type must be 'K' for KIOSK GROUP or 'C' for CLINIC")
;
S PARAMNAM=$$STRIP^XLFSTR(PARAMNAM," ") ;Parameter name can't be empty - IA #10104
I PARAMNAM="" Q $$RESULT(99,"VPS PARAMETER",PARAMVAL,"Invalid Parameter Name")
I PARAMNAM'?1.ANP Q $$RESULT(99,"VPS PARAMETER",PARAMVAL,"Parameter name can't have Non-printable characters")
I PARAMTYP="C",PARAMNAM'?1.N Q $$RESULT(99,"VPS PARAMETER",PARAMVAL,"CLINIC IEN must be a numeric value")
;
I $D(PARAM)<10 Q $$RESULT(99,"VPS PARAMETER",PARAMVAL,"No Configuration Parameters")
Q ""
;
CRPARAM(PARAMTYP,PARAMNAM) ; Create PARAM entry in root level of file #853
; INPUT
; PARAMTYP : type of configuration changes, (eg, By KIOSK GROUP (K) or by Clinic (C)).
; PARAMNAM : Value of Parameter, (eg, KIOSK GROUP or CLINIC IEN depend on the PARMTYP.)
; OUTPUT
; SUCCESS : Empty String
; FAILED : FIELD NAME^FIELD VALUE^99^exception
;
N IENS,UPDERR,FDA
N FLD S FLD=$S(PARAMTYP="C":.02,1:.03)
S FDA(853,"+1,",.01)=PARAMTYP
S FDA(853,"+1,",FLD)=PARAMNAM
D UPDATE^DIE("","FDA",,"UPDERR")
;
N ERR S ERR=""
I $D(UPDERR) S ERR=$$ERROR(.UPDERR,"VPS PARAMETER",PARAMTYP_","_PARAMNAM)
I $P(ERR,U,3)=1 S ERR=""
Q ERR
;
GPARMIEN(PARAMTYP,PARAMNAM) ; Get PARAM IEN for FILE 853
; INPUT
; PARAMTYP : type of configuration changes, (eg, By KIOSK GROUP (K) or by Clinic (C)).
; PARAMNAM : Value of Parameter name, (eg, KIOSK GROUP or CLINIC name depend on the PARMTYP.)
; OUTPUT
; SUCCESS : PARAMETER IEN for FILE 843
; FAILED : Empty string
;
N PARAMIEN S PARAMIEN=0
I PARAMTYP="C" S PARAMIEN=$O(^VPS(853,"C",PARAMNAM,""))
I PARAMTYP="K" S PARAMIEN=$O(^VPS(853,"D",PARAMNAM,""))
Q PARAMIEN
;
STRFIL(TRNDT,PARAMIEN,UPDFLD,FLDNAM,FLDVAL) ; Store the modified field value
; INPUT
; TRNDT : Transaction Date/Time - this field is also used as SUB IEN for this Transaction Level
; PARAMIEN : PARAMETER IEN for file 853
; UPDFLD : field info (File Number^Field Number^input type)
; FLDNAM : field name to update
; FLDVAL : field value to update
; OUTPUT
; SUCCESS : FIELD NAME^FIELD VALUE^1
; FAILED : FIELD NAME^FIELD VALUE^99^exception message
;
; create entry in Transaction Date/Time level
N EXIST S EXIST=$D(^VPS(853,PARAMIEN,"PARAM",TRNDT))
I 'EXIST S ERR=$$ADDTRXN(TRNDT,PARAMIEN)
Q:ERR'="" ERR
;
; update the parameter value on the Transaction Date/Time level
N RESULT S RESULT=$$UPDTRXN(PARAMIEN,TRNDT,UPDFLD,FLDNAM,FLDVAL)
Q RESULT
;
ADDTRXN(TRNDT,PARAMIEN) ; create an entry in Transaction Date/Time level
; INPUT
; TRNDT : Transaction Date/Time - this field is also used as SUB IEN for this Transaction Level
; PARAMIEN : PARAMETER IEN for file 853
; RETURN
; SUCCESS : empty string
; FAILED : FIELD NAME^FIELD VALUE^99^exception message
N IENS S IENS(1)=TRNDT
N FDA,UPDERR
S FDA(853.01,"+1,"_PARAMIEN_",",.01)=TRNDT
D UPDATE^DIE("","FDA","IENS","UPDERR")
;
N ERR S ERR=""
I $D(UPDERR) S ERR=$$ERROR(.UPDERR,"TRXN DATE/TIME",TRNDT)
Q ERR
;
UPDTRXN(PARAMIEN,TRNDT,UPDFLD,FLDNAM,FLDVAL) ; update fields in transaction level
; INPUT
; PARAMIEN : PARAMETER IEN for file 853
; TRNDT : Transaction Date/Time - this field is also used as SUB IEN for this Transaction Level
; UPDFLD : field info (File Number^Field Number^input type^Admin level Field Number^Admin level Field name)
; FLDNAM : field name to update
; FLDVAL : field value to update
; OUTPUT
; SUCCESS : FIELD NAME^FIELD VALUE^1
; FAILED : FIELD NAME^FIELD VALUE^99^exception message
;
N FIL S FIL=$P(UPDFLD,U,1) ;File Number to update
N FLD S FLD=$P(UPDFLD,U,2) ;Field Number to update
N TYP S TYP=$P(UPDFLD,U,3) ;input type (I(nternal) or E(xternal)
N RSNSUB S RSNSUB=$P(UPDFLD,U,4) ;Reason Subscript (ARREASON, MRREASON, AMRREASON)
N RSNTYP S RSNTYP=$P(FLDVAL,",")
S:TYP="" TYP="E"
N MULT S MULT=(RSNSUB'="")
N SUBS S SUBS=TRNDT_","_PARAMIEN
;
; -- Store fields for file 853.01 and multiple 853.011, 853.012, 853.013
N ERR
S:MULT SUBS=$$ADDMULT(FIL,PARAMIEN,TRNDT,RSNSUB,RSNTYP,.ERR)
Q:$D(ERR) $$ERROR(.ERR,FLDNAM,FLDVAL)
;
N FDA S FDA(FIL,SUBS_",",FLD)=$S(MULT:$P(FLDVAL,",",2),1:FLDVAL)
D FILE^DIE(TYP,"FDA","ERR")
Q:$D(ERR) $$ERROR(.ERR,FLDNAM,FLDVAL)
Q $$RESULT(1,FLDNAM,FLDVAL,"") ; data for specific field was filed successfully
;
ADDMULT(FIL,PARAMIEN,TRNDT,RSNSUB,RSNTYP,ERR) ; Add field .01 for Multiple fields if doesn't exist
; INPUT
; FIL : File number (853.011, 853.012, 853.013)
; PARAMIEN : PARAMETER IEN for file 853
; TRNDT : Transaction Date/Time - this field is also used as SUB IEN for this Transaction Level
; RSNSUB : This is the literal subscript for the sub file (eq: ARREASON, MRREASON, AMRREASON)
; RSNTYP : field value of Incomplete Reason Type
; OUTPUT
; ERR : FileMan Error array
; RETURN
; Multiple SUBS IEN
;
K ERR
N EXIST S EXIST=$D(^VPS(853,PARAMIEN,"PARAM",TRNDT,RSNSUB,RSNTYP,0))
I 'EXIST D
. N IENS S IENS(1)=RSNTYP
. N FDA S FDA(FIL,"+1,"_TRNDT_","_PARAMIEN_",",.01)=RSNTYP
. D UPDATE^DIE("","FDA","IENS","ERR")
Q RSNTYP_","_TRNDT_","_PARAMIEN
;
ERROR(FDAERR,FLDNAME,FLDVAL) ; Return error string that VetLink can recognize
; INPUT
; FDAERR : error array that was created when attempting to file the changes
; FLDNAME: the field that has invalid value
; FLDVAL : the invalid value
; RETURN
; Field Name^Field Value^99^error
;
N RESULT
N ERRNUM S ERRNUM=0
S ERRNUM=$O(FDAERR("DIERR",ERRNUM))
N ERRTXT S ERRTXT=FDAERR("DIERR",ERRNUM,"TEXT",1)
N EXIST S EXIST=ERRTXT["already exists"
S:EXIST RESULT=$$RESULT(1,FLDNAME,FLDVAL,"") ; not an exception as far as Vecna is concerned.
S:'EXIST RESULT=$$RESULT(99,FLDNAME,FLDVAL,ERRTXT)
Q RESULT
;
RESULT(STATCODE,FLDNAME,FLDVAL,ERRMSG) ;return result in the structure that VetLink expects
; INPUT
; STATCODE : status code (1 = successfull, 99 = error)
; FLDNAME : field name
; FLDVAL : field value
; ERRMSG : (OPTIONAL) error message to send back to RPC caller
; RETURN
; FLDNAME^FLDVAL^STATCODE^ERMSG
;
S:ERRMSG'="" ERRMSG=U_ERRMSG
Q FLDNAME_U_FLDVAL_U_STATCODE_ERRMSG
;
TABLE(FLDDEF) ;build array of valid fields defined to VPS PARAMETER (#853)
; INPUT/OUTPUT
; FLDDEF : array by field names
; FLDDEF(field name)=file number^field number^input type^root field number
; type : I(nternal) or E(xternal)
; root field number : optional field. this field contains the current field value of the field being updated
; ex: FLDDEF("PDO INVOCABLE PDO")="853.01^1^I^.02"
K FLDDEF
N LN,LINE,STRING
F LN=2:1 S LINE=$T(PARMFLDS+LN),STRING=$P(LINE,";;",2) Q:STRING="" D
. S FLDDEF($P(STRING,U,3))=$P(STRING,U,1,2)_U_$P(STRING,U,4,6)
Q
;
PARMFLDS ; list of Configuration Parameter Statistics fields defined in VPS PARAMETER file (#853)
;;FILE NUMBER^FIELD NUMBER^FIELD NAME^INPUT TYPE^
;;853.01^1^PDO INVOCABLE PERIOD^E^^
;;853.01^2^AR ENABLED/DISABLED DT^E^^
;;853.01^3^MR ENABLED/DISABLED DT^E^^
;;853.01^4^AUDIT ENABLED DT^E^^
;;853.01^5^AR FREE TEXT ENABLED^E^^
;;853.01^6^MR FREE TEXT ENABLED^E^^
;;853.01^7^TIME LIMIT TOO LATE ARRIVAL^E^^
;;853.01^8^TIME LIMIT TOO EARLY ARRIVAL^E^^
;;853.01^9^TIME LIMIT NOT EARLY ENOUGH^E^^
;;853.01^10^DESIRED AMR SESSION COMPLETED^E^^
;;853.01^11^DESIRED AMR TIME COMPLETED^E^^
;;853.01^12^DESIRED AR SESSION COMPLETED^E^^
;;853.01^13^DESIRED AR TIME COMPLETED^E^^
;;853.01^14^DESIRED MR SESSION COMPLETED^E^^
;;853.01^15^DESIRED MR TIME COMPLETED^E^^
;;853.01^16^TIME LIMIT AR COMPLETE^E^^
;;853.01^17^TIME LIMIT MR COMPLETE^E^^
;;853.01^18^TIME LIMIT AMR COMPLETE^E^^
;;853.01^19^LOW USE THRESHOLD PDO^E^^
;;853.01^20^AMR ENABLED/DISABLED DT^E^^
;;853.01^21^AR ENABLED^E^^
;;853.01^22^ALLERGY DISCREP UCL NO AR^E^^
;;853.01^23^ALLERGY DISCREP UCL POST AR^E^^
;;853.01^24^MED DISCREP UCL NO MR^E^^
;;853.01^25^MED DISCREP UCL POST MR^E^^
;;853.01^26^MR ENABLED^E^^
;;853.01^27^AMR ENABLED^E^^
;;853.011^1^LOW USE THRESHOLD AMR^E^AMRREASON^
;;853.012^1^LOW USE THRESHOLD AR^E^ARREASON^
;;853.013^1^LOW USE THRESHOLD MR^E^MRREASON^
;;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVPSPARAM 15478 printed Apr 09, 2024@21:45:27 Page 2
VPSPARAM ;WOIFO/BT - Update VPS PARAMETER file ;11/14/12 15:30
+1 ;;1.0;VA POINT OF SERVICE (KIOSKS);**3**;Nov 14, 2012;Build 64
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;;
+4 QUIT
+5 ;
WRITE(RESULT,PARAMTYP,PARAMNAM,PARAM) ; RPC: VPS WRITE KIOSK PARAMETERS
+1 ; Many facets of MRAR behavior are dictated by a set of business parameters defined and
+2 ; entered by the healthcare facility administrator.
+3 ; For statistical purposes, VetLink will call this RPC to store these configuration changes.
+4 ; There are two ways to store the configuration changes, by KioskGroup and by Clinic.
+5 ;
+6 ; INPUT
+7 ; RESULT : the results of processing and passed in by reference (required by RPC Broker)
+8 ; PARAMTYP : type of configuration changes, By KIOSK GROUP (K) or by Clinic (C).
+9 ; PARAMNAM : KIOSK GROUP or CLINIC IEN depend on the PARMTYP.
+10 ; PARAM : array representing the configuration parameters changed made in Vetlinks passed in by reference
+11 ; PARAM(0..n) = FIELD NAME^FIELD VALUE
+12 ; n is an incremental number;
+13 ; FIELD NAME represents the field that was changed in VetLink
+14 ; FIELD VALUE is the actual data that was updated in VetLink and to be stored in File 853.
+15 ;
+16 ; OUTPUT
+17 ; RESULT : array that returns the results of each updated field per array data element.
+18 ; SUCCESS RESULT:
+19 ; RESULT(n) = FIELD NAME^FIELD VALUE^1
+20 ; '1' at the end of the result string indicates successful update to the database of the specific field declared at field label.
+21 ;
+22 ; FAILED RESULT :
+23 ; RESULT(n)="FIELD NAME^FIELD VALUE^99^exception message"
+24 ; '99^exception message' at the end of the result string indicates an exception and no update was made to the database for that specific field and exception message describes the error.
+25 ;
+26 KILL RESULT
+27 SET RESULT(0)=$$ISVALID($GET(PARAMTYP),$GET(PARAMNAM),.PARAM)
+28 if RESULT(0)'=""
QUIT
+29 ;
+30 ; -- Lock File 853 before adding/updating
+31 NEW XREF
SET XREF=$SELECT(PARAMTYP="C":"C",1:"D")
+32 LOCK +^VPS(853,XREF,PARAMNAM):5
IF '$TEST
SET RESULT(0)=$$RESULT(99,"VPS PARAMETER",PARAMTYP_","_PARAMNAM,"VPS PARAMETER cannot be locked for this Parameter Name. Update cannot occur at this time.")
QUIT
+33 ;
+34 ; -- Create PARAM TOP Level if doesn't exist
+35 IF '$DATA(^VPS(853,XREF,PARAMNAM))
SET RESULT(0)=$$CRPARAM(PARAMTYP,PARAMNAM)
+36 ;
+37 ; -- Store parameters
+38 IF RESULT(0)=""
DO UPDPARAM(PARAMTYP,PARAMNAM,.PARAM,.RESULT)
+39 ;
+40 LOCK -^VPS(853,XREF,PARAMNAM)
+41 QUIT
+42 ;
UPDPARAM(PARAMTYP,PARAMNAM,PARAM,RESULT) ;Store input parameters
+1 ; INPUT
+2 ; PARAMTYP : type of configuration changes, By KIOSK GROUP (K) or by Clinic (C).
+3 ; PARAMNAM : KIOSK GROUP or CLINIC IEN depend on the PARMTYP.
+4 ; PARAM : array representing the configuration parameters changed made in Vetlinks passed in by reference
+5 ; PARAM(0..n) = FIELD NAME^FIELD VALUE
+6 ; n is an incremental number;
+7 ; FIELD NAME represents the field that was changed in VetLink
+8 ; FIELD VALUE is the actual data that was updated in VetLink and to be stored in File 853.
+9 ;
+10 ; INPUT/OUTPUT
+11 ; RESULT : array that returns the results of each updated field per array data element.
+12 ; SUCCESS RESULT:
+13 ; RESULT(n) = FIELD NAME^FIELD VALUE^1
+14 ; '1' at the end of the result string indicates successful update to the database of the specific field declared at field label.
+15 ;
+16 ; FAILED RESULT :
+17 ; RESULT(n)="FIELD NAME^FIELD VALUE^99^exception message"
+18 ; '99^exception message' at the end of the result string indicates an exception and no update was made to the database for that specific field and exception message describes the error.
+19 ;
+20 ; -- Get VPS PARAM IEN
+21 NEW PARAMIEN
SET PARAMIEN=$$GPARMIEN(PARAMTYP,PARAMNAM)
+22 IF 'PARAMIEN
SET RESULT(0)=$$RESULT(99,"VPS PARAMETER",PARAMTYP_","_PARAMNAM,"Unable to retrieve record for this Parameter Name. Update cannot occur at this time.")
QUIT
+23 ;
+24 ; -- Store parameters
+25 KILL RESULT
+26 NEW MULT,RSNTYP
+27 ; IA #10103 - supported use of XLFDT function
NEW TRNDT
SET TRNDT=$$NOW^XLFDT()
+28 ;get array of valid fields defined to VPS PARAMETER (#853)
NEW FLDDEF
DO TABLE(.FLDDEF)
+29 NEW SUB
SET SUB=""
+30 ;
+31 FOR
SET SUB=$ORDER(PARAM(SUB))
if SUB=""
QUIT
Begin DoDot:1
+32 NEW FLDNAM
SET FLDNAM=$PIECE(PARAM(SUB),U,1)
+33 NEW FLDVAL
SET FLDVAL=$PIECE(PARAM(SUB),U,2)
+34 if FLDNAM=""
SET RESULT(SUB)=$$RESULT(99,FLDNAM,FLDVAL,"Missing Field. Data not written.")
+35 if FLDNAM=""
QUIT
+36 if '$DATA(FLDDEF(FLDNAM))
SET RESULT(SUB)=$$RESULT(99,FLDNAM,FLDVAL,FLDNAM_" does not exist in VPS CONFIG HISTORY file. Data not written.")
+37 if '$DATA(FLDDEF(FLDNAM))
QUIT
+38 NEW FLDVAL
SET FLDVAL=$PIECE(PARAM(SUB),U,2)
+39 NEW ISMULT
SET ISMULT=($PIECE(FLDDEF(FLDNAM),U,4)'="")
+40 ;file the data to 853.01 sub-entry
IF 'ISMULT
SET RESULT(SUB)=$$STRFIL(TRNDT,PARAMIEN,FLDDEF(FLDNAM),FLDNAM,FLDVAL)
+41 ; save multiple in a MULT array and store later, want to make sure .01 field is valid
IF ISMULT
Begin DoDot:2
+42 NEW FIL
SET FIL=$PIECE(FLDDEF(FLDNAM),U,1)
+43 NEW FLD
SET FLD=$PIECE(FLDDEF(FLDNAM),U,2)
+44 NEW RSNTYP
SET RSNTYP=$PIECE(FLDVAL,",")
+45 NEW VALID
SET VALID=RSNTYP>0&(RSNTYP<6)
+46 if VALID
SET MULT(FIL,FLDNAM,RSNTYP)=SUB_U_FLDVAL
+47 if 'VALID
SET RESULT(SUB)=$$RESULT(99,FLDNAM,FLDVAL,"Invalid Incomplete Reason Type")
End DoDot:2
End DoDot:1
+48 ;
+49 ; - Store multiple fields
+50 IF $DATA(MULT)
DO STRMULT(.RESULT,PARAMIEN,TRNDT,.FLDDEF,.MULT)
+51 QUIT
+52 ;
STRMULT(RESULT,PARAMIEN,TRNDT,FLDDEF,MULT) ; Store multiple fields
+1 ; INPUT/OUTPUT
+2 ; RESULT : array that returns the results of each updated field per array data element.
+3 ; INPUT
+4 ; TRNDT : Transaction Date/Time - this field is also used as SUB IEN for this Transaction Level
+5 ; PARAMIEN : PARAMETER IEN for file 853
+6 ; FLDDEF : array of field name definition
+7 ; MULT : array of multiple field entries
+8 ; RSNTYP : array of Incomplete Reason Types
+9 ;
+10 NEW FIL
SET FIL=""
+11 FOR
SET FIL=$ORDER(MULT(FIL))
if FIL=""
QUIT
Begin DoDot:1
+12 NEW FLDNAM
SET FLDNAM=""
+13 FOR
SET FLDNAM=$ORDER(MULT(FIL,FLDNAM))
if FLDNAM=""
QUIT
Begin DoDot:2
+14 NEW RSNTYP
SET RSNTYP=""
+15 FOR
SET RSNTYP=$ORDER(MULT(FIL,FLDNAM,RSNTYP))
if RSNTYP=""
QUIT
Begin DoDot:3
+16 NEW REC
SET REC=MULT(FIL,FLDNAM,RSNTYP)
+17 NEW SUB
SET SUB=$PIECE(REC,U)
+18 NEW FLDVAL
SET FLDVAL=$PIECE(REC,U,2)
+19 ;file the data to 853.01 sub-entry
SET RESULT(SUB)=$$STRFIL(TRNDT,PARAMIEN,FLDDEF(FLDNAM),FLDNAM,FLDVAL)
End DoDot:3
End DoDot:2
End DoDot:1
+20 QUIT
+21 ;
ISVALID(PARAMTYP,PARAMNAM,PARAM) ;validate RPC input parameters
+1 ; INPUT
+2 ; PARAMTYP : type of configuration changes, (eg, By KIOSK GROUP (K) or by Clinic (C)).
+3 ; PARAMNAM : Value of Parameter, (eg, KIOSK GROUP or CLINIC IEN depend on the PARMTYP.)
+4 ; PARAM : local array representing the configuration parameters changed made in Vetlinks passed in by reference
+5 ; OUTPUT
+6 ; SUCCESS : Empty String
+7 ; FAILED : FIELD NAME^FIELD VALUE^99^exception
+8 ;
+9 NEW PARAMVAL
SET PARAMVAL=PARAMTYP_","_PARAMNAM
+10 ;Parameter Type can't be empty - IA #10104
SET PARAMTYP=$$STRIP^XLFSTR(PARAMTYP," ")
+11 IF PARAMTYP=""
QUIT $$RESULT(99,"VPS PARAMETER",PARAMVAL,"Invalid Parameter Type")
+12 IF '$FIND(",K,C,",","_PARAMTYP_",")
QUIT $$RESULT(99,"VPS PARAMETER",PARAMVAL,"Parameter Type must be 'K' for KIOSK GROUP or 'C' for CLINIC")
+13 ;
+14 ;Parameter name can't be empty - IA #10104
SET PARAMNAM=$$STRIP^XLFSTR(PARAMNAM," ")
+15 IF PARAMNAM=""
QUIT $$RESULT(99,"VPS PARAMETER",PARAMVAL,"Invalid Parameter Name")
+16 IF PARAMNAM'?1.ANP
QUIT $$RESULT(99,"VPS PARAMETER",PARAMVAL,"Parameter name can't have Non-printable characters")
+17 IF PARAMTYP="C"
IF PARAMNAM'?1.N
QUIT $$RESULT(99,"VPS PARAMETER",PARAMVAL,"CLINIC IEN must be a numeric value")
+18 ;
+19 IF $DATA(PARAM)<10
QUIT $$RESULT(99,"VPS PARAMETER",PARAMVAL,"No Configuration Parameters")
+20 QUIT ""
+21 ;
CRPARAM(PARAMTYP,PARAMNAM) ; Create PARAM entry in root level of file #853
+1 ; INPUT
+2 ; PARAMTYP : type of configuration changes, (eg, By KIOSK GROUP (K) or by Clinic (C)).
+3 ; PARAMNAM : Value of Parameter, (eg, KIOSK GROUP or CLINIC IEN depend on the PARMTYP.)
+4 ; OUTPUT
+5 ; SUCCESS : Empty String
+6 ; FAILED : FIELD NAME^FIELD VALUE^99^exception
+7 ;
+8 NEW IENS,UPDERR,FDA
+9 NEW FLD
SET FLD=$SELECT(PARAMTYP="C":.02,1:.03)
+10 SET FDA(853,"+1,",.01)=PARAMTYP
+11 SET FDA(853,"+1,",FLD)=PARAMNAM
+12 DO UPDATE^DIE("","FDA",,"UPDERR")
+13 ;
+14 NEW ERR
SET ERR=""
+15 IF $DATA(UPDERR)
SET ERR=$$ERROR(.UPDERR,"VPS PARAMETER",PARAMTYP_","_PARAMNAM)
+16 IF $PIECE(ERR,U,3)=1
SET ERR=""
+17 QUIT ERR
+18 ;
GPARMIEN(PARAMTYP,PARAMNAM) ; Get PARAM IEN for FILE 853
+1 ; INPUT
+2 ; PARAMTYP : type of configuration changes, (eg, By KIOSK GROUP (K) or by Clinic (C)).
+3 ; PARAMNAM : Value of Parameter name, (eg, KIOSK GROUP or CLINIC name depend on the PARMTYP.)
+4 ; OUTPUT
+5 ; SUCCESS : PARAMETER IEN for FILE 843
+6 ; FAILED : Empty string
+7 ;
+8 NEW PARAMIEN
SET PARAMIEN=0
+9 IF PARAMTYP="C"
SET PARAMIEN=$ORDER(^VPS(853,"C",PARAMNAM,""))
+10 IF PARAMTYP="K"
SET PARAMIEN=$ORDER(^VPS(853,"D",PARAMNAM,""))
+11 QUIT PARAMIEN
+12 ;
STRFIL(TRNDT,PARAMIEN,UPDFLD,FLDNAM,FLDVAL) ; Store the modified field value
+1 ; INPUT
+2 ; TRNDT : Transaction Date/Time - this field is also used as SUB IEN for this Transaction Level
+3 ; PARAMIEN : PARAMETER IEN for file 853
+4 ; UPDFLD : field info (File Number^Field Number^input type)
+5 ; FLDNAM : field name to update
+6 ; FLDVAL : field value to update
+7 ; OUTPUT
+8 ; SUCCESS : FIELD NAME^FIELD VALUE^1
+9 ; FAILED : FIELD NAME^FIELD VALUE^99^exception message
+10 ;
+11 ; create entry in Transaction Date/Time level
+12 NEW EXIST
SET EXIST=$DATA(^VPS(853,PARAMIEN,"PARAM",TRNDT))
+13 IF 'EXIST
SET ERR=$$ADDTRXN(TRNDT,PARAMIEN)
+14 if ERR'=""
QUIT ERR
+15 ;
+16 ; update the parameter value on the Transaction Date/Time level
+17 NEW RESULT
SET RESULT=$$UPDTRXN(PARAMIEN,TRNDT,UPDFLD,FLDNAM,FLDVAL)
+18 QUIT RESULT
+19 ;
ADDTRXN(TRNDT,PARAMIEN) ; create an entry in Transaction Date/Time level
+1 ; INPUT
+2 ; TRNDT : Transaction Date/Time - this field is also used as SUB IEN for this Transaction Level
+3 ; PARAMIEN : PARAMETER IEN for file 853
+4 ; RETURN
+5 ; SUCCESS : empty string
+6 ; FAILED : FIELD NAME^FIELD VALUE^99^exception message
+7 NEW IENS
SET IENS(1)=TRNDT
+8 NEW FDA,UPDERR
+9 SET FDA(853.01,"+1,"_PARAMIEN_",",.01)=TRNDT
+10 DO UPDATE^DIE("","FDA","IENS","UPDERR")
+11 ;
+12 NEW ERR
SET ERR=""
+13 IF $DATA(UPDERR)
SET ERR=$$ERROR(.UPDERR,"TRXN DATE/TIME",TRNDT)
+14 QUIT ERR
+15 ;
UPDTRXN(PARAMIEN,TRNDT,UPDFLD,FLDNAM,FLDVAL) ; update fields in transaction level
+1 ; INPUT
+2 ; PARAMIEN : PARAMETER IEN for file 853
+3 ; TRNDT : Transaction Date/Time - this field is also used as SUB IEN for this Transaction Level
+4 ; UPDFLD : field info (File Number^Field Number^input type^Admin level Field Number^Admin level Field name)
+5 ; FLDNAM : field name to update
+6 ; FLDVAL : field value to update
+7 ; OUTPUT
+8 ; SUCCESS : FIELD NAME^FIELD VALUE^1
+9 ; FAILED : FIELD NAME^FIELD VALUE^99^exception message
+10 ;
+11 ;File Number to update
NEW FIL
SET FIL=$PIECE(UPDFLD,U,1)
+12 ;Field Number to update
NEW FLD
SET FLD=$PIECE(UPDFLD,U,2)
+13 ;input type (I(nternal) or E(xternal)
NEW TYP
SET TYP=$PIECE(UPDFLD,U,3)
+14 ;Reason Subscript (ARREASON, MRREASON, AMRREASON)
NEW RSNSUB
SET RSNSUB=$PIECE(UPDFLD,U,4)
+15 NEW RSNTYP
SET RSNTYP=$PIECE(FLDVAL,",")
+16 if TYP=""
SET TYP="E"
+17 NEW MULT
SET MULT=(RSNSUB'="")
+18 NEW SUBS
SET SUBS=TRNDT_","_PARAMIEN
+19 ;
+20 ; -- Store fields for file 853.01 and multiple 853.011, 853.012, 853.013
+21 NEW ERR
+22 if MULT
SET SUBS=$$ADDMULT(FIL,PARAMIEN,TRNDT,RSNSUB,RSNTYP,.ERR)
+23 if $DATA(ERR)
QUIT $$ERROR(.ERR,FLDNAM,FLDVAL)
+24 ;
+25 NEW FDA
SET FDA(FIL,SUBS_",",FLD)=$SELECT(MULT:$PIECE(FLDVAL,",",2),1:FLDVAL)
+26 DO FILE^DIE(TYP,"FDA","ERR")
+27 if $DATA(ERR)
QUIT $$ERROR(.ERR,FLDNAM,FLDVAL)
+28 ; data for specific field was filed successfully
QUIT $$RESULT(1,FLDNAM,FLDVAL,"")
+29 ;
ADDMULT(FIL,PARAMIEN,TRNDT,RSNSUB,RSNTYP,ERR) ; Add field .01 for Multiple fields if doesn't exist
+1 ; INPUT
+2 ; FIL : File number (853.011, 853.012, 853.013)
+3 ; PARAMIEN : PARAMETER IEN for file 853
+4 ; TRNDT : Transaction Date/Time - this field is also used as SUB IEN for this Transaction Level
+5 ; RSNSUB : This is the literal subscript for the sub file (eq: ARREASON, MRREASON, AMRREASON)
+6 ; RSNTYP : field value of Incomplete Reason Type
+7 ; OUTPUT
+8 ; ERR : FileMan Error array
+9 ; RETURN
+10 ; Multiple SUBS IEN
+11 ;
+12 KILL ERR
+13 NEW EXIST
SET EXIST=$DATA(^VPS(853,PARAMIEN,"PARAM",TRNDT,RSNSUB,RSNTYP,0))
+14 IF 'EXIST
Begin DoDot:1
+15 NEW IENS
SET IENS(1)=RSNTYP
+16 NEW FDA
SET FDA(FIL,"+1,"_TRNDT_","_PARAMIEN_",",.01)=RSNTYP
+17 DO UPDATE^DIE("","FDA","IENS","ERR")
End DoDot:1
+18 QUIT RSNTYP_","_TRNDT_","_PARAMIEN
+19 ;
ERROR(FDAERR,FLDNAME,FLDVAL) ; Return error string that VetLink can recognize
+1 ; INPUT
+2 ; FDAERR : error array that was created when attempting to file the changes
+3 ; FLDNAME: the field that has invalid value
+4 ; FLDVAL : the invalid value
+5 ; RETURN
+6 ; Field Name^Field Value^99^error
+7 ;
+8 NEW RESULT
+9 NEW ERRNUM
SET ERRNUM=0
+10 SET ERRNUM=$ORDER(FDAERR("DIERR",ERRNUM))
+11 NEW ERRTXT
SET ERRTXT=FDAERR("DIERR",ERRNUM,"TEXT",1)
+12 NEW EXIST
SET EXIST=ERRTXT["already exists"
+13 ; not an exception as far as Vecna is concerned.
if EXIST
SET RESULT=$$RESULT(1,FLDNAME,FLDVAL,"")
+14 if 'EXIST
SET RESULT=$$RESULT(99,FLDNAME,FLDVAL,ERRTXT)
+15 QUIT RESULT
+16 ;
RESULT(STATCODE,FLDNAME,FLDVAL,ERRMSG) ;return result in the structure that VetLink expects
+1 ; INPUT
+2 ; STATCODE : status code (1 = successfull, 99 = error)
+3 ; FLDNAME : field name
+4 ; FLDVAL : field value
+5 ; ERRMSG : (OPTIONAL) error message to send back to RPC caller
+6 ; RETURN
+7 ; FLDNAME^FLDVAL^STATCODE^ERMSG
+8 ;
+9 if ERRMSG'=""
SET ERRMSG=U_ERRMSG
+10 QUIT FLDNAME_U_FLDVAL_U_STATCODE_ERRMSG
+11 ;
TABLE(FLDDEF) ;build array of valid fields defined to VPS PARAMETER (#853)
+1 ; INPUT/OUTPUT
+2 ; FLDDEF : array by field names
+3 ; FLDDEF(field name)=file number^field number^input type^root field number
+4 ; type : I(nternal) or E(xternal)
+5 ; root field number : optional field. this field contains the current field value of the field being updated
+6 ; ex: FLDDEF("PDO INVOCABLE PDO")="853.01^1^I^.02"
+7 KILL FLDDEF
+8 NEW LN,LINE,STRING
+9 FOR LN=2:1
SET LINE=$TEXT(PARMFLDS+LN)
SET STRING=$PIECE(LINE,";;",2)
if STRING=""
QUIT
Begin DoDot:1
+10 SET FLDDEF($PIECE(STRING,U,3))=$PIECE(STRING,U,1,2)_U_$PIECE(STRING,U,4,6)
End DoDot:1
+11 QUIT
+12 ;
PARMFLDS ; list of Configuration Parameter Statistics fields defined in VPS PARAMETER file (#853)
+1 ;;FILE NUMBER^FIELD NUMBER^FIELD NAME^INPUT TYPE^
+2 ;;853.01^1^PDO INVOCABLE PERIOD^E^^
+3 ;;853.01^2^AR ENABLED/DISABLED DT^E^^
+4 ;;853.01^3^MR ENABLED/DISABLED DT^E^^
+5 ;;853.01^4^AUDIT ENABLED DT^E^^
+6 ;;853.01^5^AR FREE TEXT ENABLED^E^^
+7 ;;853.01^6^MR FREE TEXT ENABLED^E^^
+8 ;;853.01^7^TIME LIMIT TOO LATE ARRIVAL^E^^
+9 ;;853.01^8^TIME LIMIT TOO EARLY ARRIVAL^E^^
+10 ;;853.01^9^TIME LIMIT NOT EARLY ENOUGH^E^^
+11 ;;853.01^10^DESIRED AMR SESSION COMPLETED^E^^
+12 ;;853.01^11^DESIRED AMR TIME COMPLETED^E^^
+13 ;;853.01^12^DESIRED AR SESSION COMPLETED^E^^
+14 ;;853.01^13^DESIRED AR TIME COMPLETED^E^^
+15 ;;853.01^14^DESIRED MR SESSION COMPLETED^E^^
+16 ;;853.01^15^DESIRED MR TIME COMPLETED^E^^
+17 ;;853.01^16^TIME LIMIT AR COMPLETE^E^^
+18 ;;853.01^17^TIME LIMIT MR COMPLETE^E^^
+19 ;;853.01^18^TIME LIMIT AMR COMPLETE^E^^
+20 ;;853.01^19^LOW USE THRESHOLD PDO^E^^
+21 ;;853.01^20^AMR ENABLED/DISABLED DT^E^^
+22 ;;853.01^21^AR ENABLED^E^^
+23 ;;853.01^22^ALLERGY DISCREP UCL NO AR^E^^
+24 ;;853.01^23^ALLERGY DISCREP UCL POST AR^E^^
+25 ;;853.01^24^MED DISCREP UCL NO MR^E^^
+26 ;;853.01^25^MED DISCREP UCL POST MR^E^^
+27 ;;853.01^26^MR ENABLED^E^^
+28 ;;853.01^27^AMR ENABLED^E^^
+29 ;;853.011^1^LOW USE THRESHOLD AMR^E^AMRREASON^
+30 ;;853.012^1^LOW USE THRESHOLD AR^E^ARREASON^
+31 ;;853.013^1^LOW USE THRESHOLD MR^E^MRREASON^
+32 ;;
