VPSSRVY1 ;WOIFO/BT - VPS CLINICAL SURVEY QUESTIONNAIRE;01/16/2015 11:23
;;1.0;VA POINT OF SERVICE (KIOSKS);**5,14**;Jan 16, 2015;Build 26
;;Per VHA Directive 2004-038, this routine should not be modified.
;
; External Reference DBIA#
; ------------------------
; IA #10103 - supported use of XLFDT function
;
QUIT
;
SAVE(VPSRES,VPSDFN,VPSDATA,MODFLG) ;RPC: VPS SAVE CLINICAL SURVEY
;INPUT
; VPSDFN : Patient IEN
; VPSDATA : Array of field-value pair to store
; Format : VPSDATA(1..n)=FIELD-NAME^SEQ#^Answer Sequence#^FIELD-VALUE
; Example:
;
; VPSDATA(1)="NAME^^^RAMDOM QUESTIONS" <-- Survey Name
; VPSDATA(2)="INTERNAL^^^RANDOM Checklist" <-- Survey Internal Name
; VPSDATA(3)="TEMPLATE ID^^^RANDOM001" <-- Questionnaire Template ID
; VPSDATA(4)="VERSION^^^10" <-- Survey Version
; VPSDATA(5)="DATE/TIME TAKEN^^^3150910.1234" <-- Date/Time Survey was taken
; VPSDATA(6)="DATE/TIME MODIFIED^^^3150911.093001" <-- Date/Time Survey was modified
; VPSDATA(7)="COMPLETION STATUS^^^2" <-- Completion STATUS
; VPSDATA(9)="PATIENT SAFETY^^^2" <-- Patient Safety
; VPSDATA(10)="IMMEDIATE ACTION^^^2" <-- Immediate Action
; VPSDATA(11)="RESPONSE IDENTIFIER^^^RESP 0910"
; VPSDATA(12)="SURVEY CALCULATED VALUE^^^Ebola Survey#223"
; VPSDATA(13)="APPOINTMENT CHECK-IN ID^1^^CHECK-IN FREE TEXT"
; VPSDATA(14)="ADDITIONAL CALC VALUE NAME^1^^CALC NAME"
; VPSDATA(15)="ADDITIONAL CALC VALUE SCORE^1^^CALC SCORE"
; Multiple Questions
; VPSDATA(16)="QUESTION NUMBER^1^^Q1"
; VPSDATA(17)="QUESTION CALCULATED VALUE^1^^QCV 40"
; VPSDATA(18)="QUESTION PRESENTED^1^^Have you travelled outside the U.S. in the last 5 TO 10 days?"
; Multiple Answers
; VPSDATA(19)="ANSWER IDENTIFIER^1^1^AN1-A"
; VPSDATA(20)="INTERFACE USED^1^1^2"
; VPSDATA(21)="RESPONDENT^1^1^1"
; VPSDATA(22)="RESPONDENT NAME^1^1^"
; VPSDATA(23)="ANSWER DATE/TIME^1^1^3150903.1211"
; VPSDATA(24)="INTERVIEWER NAME^1^1^JOE JOE"
; VPSDATA(25)="KIOSK IDENTIFIER^1^1^KIOSK ID 12"
; VPSDATA(26)="KIOSK SESSION IDENTIFIER^1^1^KIOSK SESS 100"
; VPSDATA(27)="KIOSK GROUP IDENTIFIER^1^1^KIOSK GRP ID 009"
; VPSDATA(28)="ANSWER TEXT^1^1^Absolutely"
; VPSDATA(29)="QUESTION NUMBER^2^^Q2"
; VPSDATA(30)="QUESTION CALCULATED VALUE^2^^QCV 400"
; VPSDATA(31)="QUESTION PRESENTED^2^^Have you travelled outside the U.S. in the last 5 TO 10 days?"
; VPSDATA(32)="ANSWER IDENTIFIER^2^1^AN2-A"
; VPSDATA(33)="INTERFACE USED^2^1^2"
; VPSDATA(34)="RESPONDENT^2^1^3"
; VPSDATA(35)="RESPONDENT NAME^2^1^LAST, FIRST"
; VPSDATA(36)="ANSWER DATE/TIME^2^1^3150903.1211"
; VPSDATA(37)="INTERVIEWER NAME^2^1^JOE JOE"
; VPSDATA(38)="KIOSK IDENTIFIER^2^1^KIOSK ID 12"
; VPSDATA(39)="KIOSK SESSION IDENTIFIER^2^1^KIOSK SESS 100"
; VPSDATA(40)="KIOSK GROUP IDENTIFIER^2^1^KIOSK GRP ID 009"
; VPSDATA(41)="ANSWER TEXT^2^1^I already answered this question."
;
; MODFLG = A flag to indicate that an existing response is being modified
; 0 not an edit
; 1 edit existing data, but add new responses while keeping previous response
; 2 edit existing data, but over write previous response
;
;OUTPUT
; VPSRES = 1 (Survey is stored successully)
; -1^Error Message (Survey is not stored because an Error)
;
S VPSRES=""
I +$G(VPSDFN)=0 S VPSRES="-1^Patient IEN not sent" Q
I '$D(^DPT(VPSDFN)) S VPSRES="-1^Patient not on File" Q
I '$D(VPSDATA) S VPSRES="-1^Survey Data not sent" Q
I $P($G(VPSDATA(3)),U,4)="" S VPSRES="-1^Template ID is required" Q
I $P($G(VPSDATA(1)),U,4)="" S VPSRES="-1^Survey Name is required" Q
I $P($G(VPSDATA(4)),U,4)="" S VPSRES="-1^Version is required" Q
N TRNDT S TRNDT=$$NOW^XLFDT()
S VPSDATA(1)=$$UPCASE^VPSSRVY2(VPSDATA(1))
I '$$OKID Q
Q:$G(VPSRES)'=""
;
; -- Prepare Survey Data to file
N SURVEY,SURVEYM,ID,TID,APDATA,ACDATA,QSTDATA,ANSDATA,WPDATA
N ER S ER=""
S ER=$$PREP(.VPSDATA,.SURVEY,.APDATA,.ACDATA,.QSTDATA,.ANSDATA,.WPDATA)
;
S MODFLG=+$G(MODFLG)
;
; -- Lock patient survey
I ER="" S ER=$$LOCK(VPSDFN)
;
; If flag set to update an existing questionnaire do update and skip add
I MODFLG>0 S ER=$$UPDATE(VPSDFN,.VPSDATA,.SURVEY,.APDATA,.ACDATA,.QSTDATA,.ANSDATA,.WPDATA,MODFLG)
G:MODFLG>0 EX1
;
; Add survey identifiers to file # 853.85
I ER="" S ER=$$ADSRVYKY()
;
;========================================================================================================
;========================================================================================================
I ER="" S ER=$$ADDDFN(VPSDFN)
I ER="" D
. S ID=$P(VPSDATA(3),U,4)
. S TID=$O(^VPS(853.85,"B",ID,""))
. I TID="" S ER="Error with Template "_$P(VPSDATA(3),U,4) G EX1
I ER="" S ER=$$ADDQST(VPSDFN,TID)
I ER="" S ER=$$ADDSRVY^VPSSRVY4(VPSDFN,TID,TRNDT)
I ER="" S ER=$$ADDRES^VPSSRVY4(VPSDFN,TID,TRNDT,.SURVEY,0)
I ER="" S ER=$$ADDAPPT^VPSSRVY4(VPSDFN,TID,TRNDT,.APDATA,0)
I ER="" S ER=$$ADDCALC^VPSSRVY4(VPSDFN,TID,TRNDT,.ACDATA,0)
I ER="" S ER=$$ADDQUEST^VPSSRVY4(VPSDFN,TID,TRNDT,.QSTDATA,.ANSDATA,.WPDATA,0)
;I ER="" S ER=$$ADDANS(VPSDFN,TID,TRNDT,.ANSDATA,.WPDATA)
;========================================================================================================
;========================================================================================================
; -- Result
EX1 ;
I ER="" S VPSRES=1
I ER'="" D
. S ID=$P(VPSDATA(3),U,4)
. S TID=$O(^VPS(853.85,"B",ID,""))
. S VPSRES=-1_U_ER D CLNSRVY(VPSDFN,TID,TRNDT) ;delete unstorable survey
;
; -- unlock patient survey
D STOREQNM
D UNLOCK(VPSDFN)
;
QUIT
;
OKID() ;
N QNAME,VER,ID,IEN
S QNAME=$P(VPSDATA(1),U,4)
S VER=+$P(VPSDATA(4),U,4)
S ID=$P(VPSDATA(3),U,4)
S IEN=$O(^VPS(853.85,"B",ID,""))
Q:IEN="" 1
I VER'=$$GET1^DIQ(853.85,IEN_",",2) S VPSRES="-1^Template ID and version do not match existing information" Q 0
I $L(QNAME)<3 S VPSRES=-1_U_"Survey name length too short: "_QNAME Q 0
I $L(QNAME)>240 S VPSRES=-1_U_"SURVEY NAME length violation: "_QNAME Q 0
I QNAME'=$$GET1^DIQ(853.85,IEN_",",1) D
. ; If name changed remove old name
. N NM,ER
. S ER=""
. ;S NM=$$GET1(853.85,IEN_",",1)
. ;D CLRNM(VER,NM)
. S ER=$$UPDATENM(IEN,QNAME)
. I ER]"" S VPSRES=-1_U_ER
Q 1
STOREQNM ;
;
N QNAME,VER
S QNAME=$P(VPSDATA(1),U,4)
S VER=$P(VPSDATA(4),U,4)
I '$D(^VPS(853.875,"B",QNAME)) D STOREQN(QNAME)
I '$D(^VPS(853.875,"B",QNAME_":::V "_VER)) D STOREQN(QNAME_":::V "_VER)
Q
;
STOREQN(X) ;
N DIC
L +^VPS(853.875):5 E Q
S DIC="^VPS(853.875,"
S DIC(0)=""
D FILE^DICN
L -^VPS(853.875)
Q
;
CLRNM(VER,NM) ; Survey Name changed so remove previous name
N FIL S FIL=853.875
N IE
S IE=$O(^VPS(853.875,"B",NM,""))
N FDA S FDA(FIL,IE_",",.01)="@"
N FDAERR D FILE^DIE("","FDA","FDAERR")
QUIT $$ERROR(.FDAERR)
S IE=$O(^VPS(853.875,"B",NM_":::V "_VER,""))
N FDA S FDA(FIL,IE_",",.01)="@"
N FDAERR D FILE^DIE("","FDA","FDAERR")
QUIT $$ERROR(.FDAERR)
;
UPDATENM(IEN,NM) ; Update Survey Name
N FIL S FIL=853.85
N FDA S FDA(FIL,IEN_",",1)=NM
N FDAERR D FILE^DIE("","FDA","FDAERR")
QUIT $$ERROR(.FDAERR)
;
;
ADSRVYKY() ;add survey Identifiers
N FIL S FIL=853.85
N SUBS S SUBS="+1,"
N FDA,FDAERR
N FLD S FLD=0
N QNAME,VER,ID,IEN,INM
S QNAME=$P(VPSDATA(1),U,4)
S VER=$P(VPSDATA(4),U,4)
S ID=$P(VPSDATA(3),U,4)
S INM=$P(VPSDATA(2),U,4)
Q:$O(^VPS(FIL,"B",ID,""))'="" ""
I $L(QNAME)<3 Q "Survey name length too short "_QNAME
I $L(QNAME)>240 Q "SURVEY NAME length violation "_QNAME
I $L(INM)<3 Q "QUESTIONNAIRE INTERNAL NAME length violation "_INM
;
; -- fill in FDA with the survey data
S FDA(FIL,SUBS,.01)=ID
S FDA(FIL,SUBS,1)=QNAME
S FDA(FIL,SUBS,2)=VER
;S FDA(853.85,SUBS,3)=INM
;
; -- store the survey data
D UPDATE^DIE("E","FDA","","FDAERR")
I '$D(FDAERR) D
. K ^TMP("CSQ ARRAY",$J)
. S ^TMP("CSQ ARRAY",$J,1,0)=INM
. S SUBS=$O(^VPS(FIL,"B",ID,""))_","
. D WP^DIE(FIL,SUBS,3,"","^TMP(""CSQ ARRAY"",$J)","FDAERR")
QUIT $$ERROR(.FDAERR)
;
ADDDFN(VPSDFN) ;Add Survey (patient level)
QUIT:$D(^VPS(853.8,VPSDFN,0)) ""
N FIL S FIL=853.8
N IENS S IENS(1)=VPSDFN
N FDA S FDA(FIL,"+1,",.01)=VPSDFN
N FDAERR D UPDATE^DIE("","FDA","IENS","FDAERR")
QUIT $$ERROR(.FDAERR)
;
ADDQST(VPSDFN,TMPIEN) ;add (QUESTIONNAIRE IDENTIFIER level)
Q:$D(^VPS(853.8,VPSDFN,1,TID)) ""
N FIL S FIL=853.805
N IENS S IENS(1)=TMPIEN
N SUBS S SUBS="+1,"_VPSDFN_","
N FDA,FDAERR
N FLD S FLD=0
;
S FDA(FIL,SUBS,.01)=TMPIEN
;
; -- store the survey data
D UPDATE^DIE("","FDA","IENS","FDAERR")
QUIT $$ERROR(.FDAERR)
;
UPDATE(VPSDFN,VPSDATA,SURVEY,APDATA,ACDATA,QSTDATA,ANSDATA,WPDATA,MODFLG) ;
N ER,ID,TID,TRNDT
S ER=""
S ID=$P(VPSDATA(3),U,4)
S TID=$O(^VPS(853.85,"B",ID,""))
I TID="" S ER="No record for this questionnaire "_ID
I ER="",'$D(^VPS(853.8,VPSDFN,1,TID)) S ER="Cannot update, no record of patient "_VPSDFN_" ever submitting this questionnaire "_$P(VPSDATA(3),U,4)
I ER="" D
. I $G(SURVEY(.01))=""!($G(SURVEY(.02))="") S ER="Key information missing: Response ID: "_$G(SURVEY(.01))_" date/time questionnaire taken "_$G(SURVEY(.02))
. Q:ER]""
. S TRNDT=$O(^VPS(853.8,"D",SURVEY(.01),SURVEY(.02),VPSDFN,TID,""),-1)
. I TRNDT="" S ER="No questionnaire for patient "_VPSDFN_" matches information Questionnaire :"_ID_" Response ID: "_SURVEY(.01)_" date/time questionnaire taken "_SURVEY(.02)
I ER="" S ER=$$ADDRES^VPSSRVY4(VPSDFN,TID,TRNDT,.SURVEY,MODFLG)
I ER="" S ER=$$ADDAPPT^VPSSRVY4(VPSDFN,TID,TRNDT,.APDATA,MODFLG)
I ER="" S ER=$$ADDCALC^VPSSRVY4(VPSDFN,TID,TRNDT,.ACDATA,MODFLG)
I ER="" S ER=$$ADDQUEST^VPSSRVY4(VPSDFN,TID,TRNDT,.QSTDATA,.ANSDATA,.WPDATA,MODFLG)
Q ER
CLNSRVY(VPSDFN,TID,TRNDT) ; delete Questionnaire
N FIL S FIL=853.81
N FDA S FDA(FIL,TRNDT_","_TID_","_VPSDFN_",",.01)="@"
N ERR D FILE^DIE("","FDA")
QUIT
;
GETFLD(SVYLST,APSVYLST,ACSVYLST,QSVYLST,ANSVYLST,WPLST,FLDLEN,REQFLD) ;get field maps
N LN,LINE,STRING
F LN=1:1 S LINE=$T(LST+LN),STRING=$P(LINE,";;",2) Q:STRING="" S SVYLST($P(STRING,U,2))=$P(STRING,U),FLDLEN(853.811,$P(STRING,U,2))=$P(STRING,U,4,5),REQFLD(853.811,$P(STRING,U,2))=$P(STRING,U,6)
F LN=1:1 S LINE=$T(APLST+LN),STRING=$P(LINE,";;",2) Q:STRING="" S APSVYLST($P(STRING,U,2))=$P(STRING,U),FLDLEN(853.8111,$P(STRING,U,2))=$P(STRING,U,4,5),REQFLD(853.8111,$P(STRING,U,2))=$P(STRING,U,6)
F LN=1:1 S LINE=$T(ACLST+LN),STRING=$P(LINE,";;",2) Q:STRING="" S ACSVYLST($P(STRING,U,2))=$P(STRING,U),FLDLEN(853.8112,$P(STRING,U,2))=$P(STRING,U,4,5),REQFLD(853.8112,$P(STRING,U,2))=$P(STRING,U,6)
F LN=1:1 S LINE=$T(QSTLST+LN),STRING=$P(LINE,";;",2) Q:STRING="" D
. S QSVYLST($P(STRING,U,2))=$P(STRING,U)
. S FLDLEN(853.8113,$P(STRING,U,2))=$P(STRING,U,4,5)
. S REQFLD(853.8113,$P(STRING,U,2))=$P(STRING,U,6)
. I $P(STRING,U,3)=1 S WPLST(853.8113,$P(STRING,U))=1
F LN=1:1 S LINE=$T(ANSLST+LN),STRING=$P(LINE,";;",2) Q:STRING="" D
. S ANSVYLST($P(STRING,U,2))=$P(STRING,U)
. S FLDLEN(853.81133,$P(STRING,U,2))=$P(STRING,U,4,5)
. S REQFLD(853.81133,$P(STRING,U,2))=$P(STRING,U,6)
. I $P(STRING,U,3)=1 S WPLST(853.81133,$P(STRING,U))=1
QUIT
;
PREP(INDATA,SURVEY,APDAT,ACDAT,QDAT,ANSDAT,WPFLD) ;Based on Vetlink input data, prepare survey data to file
N SVYFLD,MSVYFLD,FLDLEN,APFLD,ACFLD,QSTFLD,ANFLD,FLDLEN,REQFLD
D GETFLD(.SVYFLD,.APFLD,.ACFLD,.QSTFLD,.ANFLD,.WPFLD,.FLDLEN,.REQFLD)
;
N FLD,FLDNO,FLDVAL,MULTSEQ
N ER S ER=""
N SEQ S SEQ=0
N QLC
N ALC
N SQN
N QLEN
;
F S SEQ=$O(INDATA(SEQ)) Q:'SEQ D QUIT:ER'=""
. S MULTSEQ=$P(INDATA(SEQ),U,2) ;multiple sequence # for multiple field such as Questions, responses, and calculated values
. S FLD=$P(INDATA(SEQ),U) I FLD="" S ER="Field Name is required" QUIT ;Input Field Name
. S SQN=$P(INDATA(SEQ),U,3)
. S FLDVAL=$P(INDATA(SEQ),U,4)
. S FLDNO=$S($D(APFLD(FLD)):APFLD(FLD),$D(ACFLD(FLD)):ACFLD(FLD),$D(QSTFLD(FLD)):QSTFLD(FLD),$D(ANFLD(FLD)):ANFLD(FLD),1:$G(SVYFLD(FLD))) ;Field #
. I FLDNO="" S ER="Invalid Field - "_FLD QUIT
. I $D(SVYFLD(FLD)) S SURVEY(FLDNO)=FLDVAL,ER=$$LENCHK($G(FLDLEN(853.811,FLDNO)),FLDVAL,FLDNO) I ER="" S ER=$$REQ($G(REQFLD(853.811,FLD)),FLDVAL,FLD)
. I $D(APFLD(FLD)) S APDAT(MULTSEQ,FLDNO)=FLDVAL,ER=$$LENCHK($G(FLDLEN(853.8111,FLDNO)),FLDVAL,FLDNO) I ER="" S ER=$$REQ($G(REQFLD(853.8111,FLD)),FLDVAL,FLD)
. I $D(ACFLD(FLD)) S ACDAT(MULTSEQ,FLDNO)=FLDVAL,ER=$$LENCHK($G(FLDLEN(853.8112,FLDNO)),FLDVAL,FLDNO) I ER="" S ER=$$REQ($G(REQFLD(853.8112,FLD)),FLDVAL,FLD)
. I $D(QSTFLD(FLD)) D
.. I $D(WPFLD(853.8113,FLDNO)) S QLC(MULTSEQ)=$G(QLC(MULTSEQ))+1,QDAT(MULTSEQ,FLDNO,QLC(MULTSEQ))=FLDVAL
.. E S QDAT(MULTSEQ,FLDNO)=FLDVAL,ER=$$LENCHK($G(FLDLEN(853.8113,FLDNO)),FLDVAL,FLDNO) I ER="" S ER=$$REQ($G(REQFLD(853.8113,FLD)),FLDVAL,FLD)
. I $D(ANFLD(FLD)) D
.. I $D(WPFLD(853.81133,FLDNO)) D
... S ALC(MULTSEQ)=$G(ALC(MULTSEQ))+1,ANSDAT(MULTSEQ,+SQN,FLDNO,ALC(MULTSEQ))=FLDVAL
.. E D
... S ANSDAT(MULTSEQ,+SQN,FLDNO)=FLDVAL,ER=$$LENCHK($G(FLDLEN(853.81133,FLDNO)),FLDVAL,FLDNO) I ER="" S ER=$$REQ($G(REQFLD(853.81133,FLD)),FLDVAL,FLD)
... I FLDNO=1,FLDVAL="" N %,%I,%H,X D NOW^%DTC S ANSDAT(MULTSEQ,+SQN,FLDNO)=%
N I,J
S I=0
F S I=$O(QDAT(I)) Q:'I S J=0,QLEN(I)=0 F S J=$O(QDAT(I,2,J)) Q:'J S QLEN(I)=QLEN(I)+$L(QDAT(I,2,J))
S I=0
F S I=$O(QLEN(I)) Q:'I I QLEN(I)<1 S ER="Data incorrect length for field QUESTION PRESENTED"
;
QUIT ER
;
;
LENCHK(LENSTR,STRING,FLD) ;
;
N MIN,MAX
S MIN=+$P(LENSTR,U)
S MAX=+$P(LENSTR,U,2)
I MIN=0,MAX=0 Q ""
I MIN>0,MIN>$L(STRING) Q "Data incorrect length for field "_FLD
I MAX>0,MAX<$L(STRING) Q "Data incorrect length for field "_FLD
Q ""
;
REQ(REQFLG,STR,FLD) ;
I '+REQFLG Q ""
I STR="" Q "Data required for field "_FLD
Q ""
;
ERROR(FDAERR) ;return error text
QUIT:'$D(FDAERR) ""
N ERRNUM S ERRNUM=0
S ERRNUM=$O(FDAERR("DIERR",ERRNUM))
N ERRTXT S ERRTXT=""
S:ERRNUM ERRTXT=FDAERR("DIERR",ERRNUM,"TEXT",1)
QUIT ERRTXT
;
LOCK(VPSDFN) ;Lock this process
L +^TMP("VPSSRVY1",VPSDFN):3 E QUIT "Another process updating survey for this patient"
QUIT ""
;
UNLOCK(VPSDFN) ;Unlock this process
L -^TMP("VPSSRVY1",VPSDFN)
QUIT
;
;
; Field # ^ Field Name ^ Word process field flag ^ Min length ^ Max lenght ^ Required
;
LST ; list of 853.811 fields (Questionnaire response)
;;.01^RESPONSE IDENTIFIER^^3^250^1
;;.02^DATE/TIME TAKEN
;;.03^DATE/TIME MODIFIED
;;.04^COMPLETION STATUS^^^^1
;;.05^PATIENT SAFETY^^^^1
;;.06^IMMEDIATE ACTION^^^^1
;;4^SURVEY CALCULATED VALUE^^^^1
;;1^NAME^^3^255^1
;;9^INTERNAL
;;10^VERSION^^^^1
;;11^TEMPLATE ID^^3^60^1
;;
APLST ; list of 853.8111 fields (Appointment check-in)
;;.01^APPOINTMENT CHECK-IN ID
;;
ACLST ; list of 853.8112 fields (ADDITIONAL CALCULATED VALUE)
;;.01^ADDITIONAL CALC VALUE NAME^^1^20^1
;;.02^ADDITIONAL CALC VALUE SCORE^^1^20^1
;;
QSTLST ; list of 853.8113 fields (QUESTIONS)
;;.01^QUESTION NUMBER^^1^4^1
;;1^QUESTION CALCULATED VALUE^^3^250^1
;;2^QUESTION PRESENTED^1^1^^1
;;
ANSLST ; list of 853.81133 fields (ANSWER)
;;.01^ANSWER IDENTIFIER^^3^250^1
;;.02^INTERFACE USED^^^^1
;;.03^RESPONDENT^^^^1
;;.04^RESPONDENT NAME^^0^60
;;1^ANSWER DATE/TIME
;;2^INTERVIEWER NAME^^0^60
;;3^KIOSK IDENTIFIER^^3^250
;;4^KIOSK SESSION IDENTIFIER^^3^250
;;5^KIOSK GROUP IDENTIFIER^^3^250
;;6^ANSWER TEXT^1
;;
QUIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVPSSRVY1 16105 printed Apr 09, 2024@21:45:57 Page 2
VPSSRVY1 ;WOIFO/BT - VPS CLINICAL SURVEY QUESTIONNAIRE;01/16/2015 11:23
+1 ;;1.0;VA POINT OF SERVICE (KIOSKS);**5,14**;Jan 16, 2015;Build 26
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ; External Reference DBIA#
+5 ; ------------------------
+6 ; IA #10103 - supported use of XLFDT function
+7 ;
+8 QUIT
+9 ;
SAVE(VPSRES,VPSDFN,VPSDATA,MODFLG) ;RPC: VPS SAVE CLINICAL SURVEY
+1 ;INPUT
+2 ; VPSDFN : Patient IEN
+3 ; VPSDATA : Array of field-value pair to store
+4 ; Format : VPSDATA(1..n)=FIELD-NAME^SEQ#^Answer Sequence#^FIELD-VALUE
+5 ; Example:
+6 ;
+7 ; VPSDATA(1)="NAME^^^RAMDOM QUESTIONS" <-- Survey Name
+8 ; VPSDATA(2)="INTERNAL^^^RANDOM Checklist" <-- Survey Internal Name
+9 ; VPSDATA(3)="TEMPLATE ID^^^RANDOM001" <-- Questionnaire Template ID
+10 ; VPSDATA(4)="VERSION^^^10" <-- Survey Version
+11 ; VPSDATA(5)="DATE/TIME TAKEN^^^3150910.1234" <-- Date/Time Survey was taken
+12 ; VPSDATA(6)="DATE/TIME MODIFIED^^^3150911.093001" <-- Date/Time Survey was modified
+13 ; VPSDATA(7)="COMPLETION STATUS^^^2" <-- Completion STATUS
+14 ; VPSDATA(9)="PATIENT SAFETY^^^2" <-- Patient Safety
+15 ; VPSDATA(10)="IMMEDIATE ACTION^^^2" <-- Immediate Action
+16 ; VPSDATA(11)="RESPONSE IDENTIFIER^^^RESP 0910"
+17 ; VPSDATA(12)="SURVEY CALCULATED VALUE^^^Ebola Survey#223"
+18 ; VPSDATA(13)="APPOINTMENT CHECK-IN ID^1^^CHECK-IN FREE TEXT"
+19 ; VPSDATA(14)="ADDITIONAL CALC VALUE NAME^1^^CALC NAME"
+20 ; VPSDATA(15)="ADDITIONAL CALC VALUE SCORE^1^^CALC SCORE"
+21 ; Multiple Questions
+22 ; VPSDATA(16)="QUESTION NUMBER^1^^Q1"
+23 ; VPSDATA(17)="QUESTION CALCULATED VALUE^1^^QCV 40"
+24 ; VPSDATA(18)="QUESTION PRESENTED^1^^Have you travelled outside the U.S. in the last 5 TO 10 days?"
+25 ; Multiple Answers
+26 ; VPSDATA(19)="ANSWER IDENTIFIER^1^1^AN1-A"
+27 ; VPSDATA(20)="INTERFACE USED^1^1^2"
+28 ; VPSDATA(21)="RESPONDENT^1^1^1"
+29 ; VPSDATA(22)="RESPONDENT NAME^1^1^"
+30 ; VPSDATA(23)="ANSWER DATE/TIME^1^1^3150903.1211"
+31 ; VPSDATA(24)="INTERVIEWER NAME^1^1^JOE JOE"
+32 ; VPSDATA(25)="KIOSK IDENTIFIER^1^1^KIOSK ID 12"
+33 ; VPSDATA(26)="KIOSK SESSION IDENTIFIER^1^1^KIOSK SESS 100"
+34 ; VPSDATA(27)="KIOSK GROUP IDENTIFIER^1^1^KIOSK GRP ID 009"
+35 ; VPSDATA(28)="ANSWER TEXT^1^1^Absolutely"
+36 ; VPSDATA(29)="QUESTION NUMBER^2^^Q2"
+37 ; VPSDATA(30)="QUESTION CALCULATED VALUE^2^^QCV 400"
+38 ; VPSDATA(31)="QUESTION PRESENTED^2^^Have you travelled outside the U.S. in the last 5 TO 10 days?"
+39 ; VPSDATA(32)="ANSWER IDENTIFIER^2^1^AN2-A"
+40 ; VPSDATA(33)="INTERFACE USED^2^1^2"
+41 ; VPSDATA(34)="RESPONDENT^2^1^3"
+42 ; VPSDATA(35)="RESPONDENT NAME^2^1^LAST, FIRST"
+43 ; VPSDATA(36)="ANSWER DATE/TIME^2^1^3150903.1211"
+44 ; VPSDATA(37)="INTERVIEWER NAME^2^1^JOE JOE"
+45 ; VPSDATA(38)="KIOSK IDENTIFIER^2^1^KIOSK ID 12"
+46 ; VPSDATA(39)="KIOSK SESSION IDENTIFIER^2^1^KIOSK SESS 100"
+47 ; VPSDATA(40)="KIOSK GROUP IDENTIFIER^2^1^KIOSK GRP ID 009"
+48 ; VPSDATA(41)="ANSWER TEXT^2^1^I already answered this question."
+49 ;
+50 ; MODFLG = A flag to indicate that an existing response is being modified
+51 ; 0 not an edit
+52 ; 1 edit existing data, but add new responses while keeping previous response
+53 ; 2 edit existing data, but over write previous response
+54 ;
+55 ;OUTPUT
+56 ; VPSRES = 1 (Survey is stored successully)
+57 ; -1^Error Message (Survey is not stored because an Error)
+58 ;
+59 SET VPSRES=""
+60 IF +$GET(VPSDFN)=0
SET VPSRES="-1^Patient IEN not sent"
QUIT
+61 IF '$DATA(^DPT(VPSDFN))
SET VPSRES="-1^Patient not on File"
QUIT
+62 IF '$DATA(VPSDATA)
SET VPSRES="-1^Survey Data not sent"
QUIT
+63 IF $PIECE($GET(VPSDATA(3)),U,4)=""
SET VPSRES="-1^Template ID is required"
QUIT
+64 IF $PIECE($GET(VPSDATA(1)),U,4)=""
SET VPSRES="-1^Survey Name is required"
QUIT
+65 IF $PIECE($GET(VPSDATA(4)),U,4)=""
SET VPSRES="-1^Version is required"
QUIT
+66 NEW TRNDT
SET TRNDT=$$NOW^XLFDT()
+67 SET VPSDATA(1)=$$UPCASE^VPSSRVY2(VPSDATA(1))
+68 IF '$$OKID
QUIT
+69 if $GET(VPSRES)'=""
QUIT
+70 ;
+71 ; -- Prepare Survey Data to file
+72 NEW SURVEY,SURVEYM,ID,TID,APDATA,ACDATA,QSTDATA,ANSDATA,WPDATA
+73 NEW ER
SET ER=""
+74 SET ER=$$PREP(.VPSDATA,.SURVEY,.APDATA,.ACDATA,.QSTDATA,.ANSDATA,.WPDATA)
+75 ;
+76 SET MODFLG=+$GET(MODFLG)
+77 ;
+78 ; -- Lock patient survey
+79 IF ER=""
SET ER=$$LOCK(VPSDFN)
+80 ;
+81 ; If flag set to update an existing questionnaire do update and skip add
+82 IF MODFLG>0
SET ER=$$UPDATE(VPSDFN,.VPSDATA,.SURVEY,.APDATA,.ACDATA,.QSTDATA,.ANSDATA,.WPDATA,MODFLG)
+83 if MODFLG>0
GOTO EX1
+84 ;
+85 ; Add survey identifiers to file # 853.85
+86 IF ER=""
SET ER=$$ADSRVYKY()
+87 ;
+88 ;========================================================================================================
+89 ;========================================================================================================
+90 IF ER=""
SET ER=$$ADDDFN(VPSDFN)
+91 IF ER=""
Begin DoDot:1
+92 SET ID=$PIECE(VPSDATA(3),U,4)
+93 SET TID=$ORDER(^VPS(853.85,"B",ID,""))
+94 IF TID=""
SET ER="Error with Template "_$PIECE(VPSDATA(3),U,4)
GOTO EX1
End DoDot:1
+95 IF ER=""
SET ER=$$ADDQST(VPSDFN,TID)
+96 IF ER=""
SET ER=$$ADDSRVY^VPSSRVY4(VPSDFN,TID,TRNDT)
+97 IF ER=""
SET ER=$$ADDRES^VPSSRVY4(VPSDFN,TID,TRNDT,.SURVEY,0)
+98 IF ER=""
SET ER=$$ADDAPPT^VPSSRVY4(VPSDFN,TID,TRNDT,.APDATA,0)
+99 IF ER=""
SET ER=$$ADDCALC^VPSSRVY4(VPSDFN,TID,TRNDT,.ACDATA,0)
+100 IF ER=""
SET ER=$$ADDQUEST^VPSSRVY4(VPSDFN,TID,TRNDT,.QSTDATA,.ANSDATA,.WPDATA,0)
+101 ;I ER="" S ER=$$ADDANS(VPSDFN,TID,TRNDT,.ANSDATA,.WPDATA)
+102 ;========================================================================================================
+103 ;========================================================================================================
+104 ; -- Result
EX1 ;
+1 IF ER=""
SET VPSRES=1
+2 IF ER'=""
Begin DoDot:1
+3 SET ID=$PIECE(VPSDATA(3),U,4)
+4 SET TID=$ORDER(^VPS(853.85,"B",ID,""))
+5 ;delete unstorable survey
SET VPSRES=-1_U_ER
DO CLNSRVY(VPSDFN,TID,TRNDT)
End DoDot:1
+6 ;
+7 ; -- unlock patient survey
+8 DO STOREQNM
+9 DO UNLOCK(VPSDFN)
+10 ;
+11 QUIT
+12 ;
OKID() ;
+1 NEW QNAME,VER,ID,IEN
+2 SET QNAME=$PIECE(VPSDATA(1),U,4)
+3 SET VER=+$PIECE(VPSDATA(4),U,4)
+4 SET ID=$PIECE(VPSDATA(3),U,4)
+5 SET IEN=$ORDER(^VPS(853.85,"B",ID,""))
+6 if IEN=""
QUIT 1
+7 IF VER'=$$GET1^DIQ(853.85,IEN_",",2)
SET VPSRES="-1^Template ID and version do not match existing information"
QUIT 0
+8 IF $LENGTH(QNAME)<3
SET VPSRES=-1_U_"Survey name length too short: "_QNAME
QUIT 0
+9 IF $LENGTH(QNAME)>240
SET VPSRES=-1_U_"SURVEY NAME length violation: "_QNAME
QUIT 0
+10 IF QNAME'=$$GET1^DIQ(853.85,IEN_",",1)
Begin DoDot:1
+11 ; If name changed remove old name
+12 NEW NM,ER
+13 SET ER=""
+14 ;S NM=$$GET1(853.85,IEN_",",1)
+15 ;D CLRNM(VER,NM)
+16 SET ER=$$UPDATENM(IEN,QNAME)
+17 IF ER]""
SET VPSRES=-1_U_ER
End DoDot:1
+18 QUIT 1
STOREQNM ;
+1 ;
+2 NEW QNAME,VER
+3 SET QNAME=$PIECE(VPSDATA(1),U,4)
+4 SET VER=$PIECE(VPSDATA(4),U,4)
+5 IF '$DATA(^VPS(853.875,"B",QNAME))
DO STOREQN(QNAME)
+6 IF '$DATA(^VPS(853.875,"B",QNAME_":::V "_VER))
DO STOREQN(QNAME_":::V "_VER)
+7 QUIT
+8 ;
STOREQN(X) ;
+1 NEW DIC
+2 LOCK +^VPS(853.875):5
IF '$TEST
QUIT
+3 SET DIC="^VPS(853.875,"
+4 SET DIC(0)=""
+5 DO FILE^DICN
+6 LOCK -^VPS(853.875)
+7 QUIT
+8 ;
CLRNM(VER,NM) ; Survey Name changed so remove previous name
+1 NEW FIL
SET FIL=853.875
+2 NEW IE
+3 SET IE=$ORDER(^VPS(853.875,"B",NM,""))
+4 NEW FDA
SET FDA(FIL,IE_",",.01)="@"
+5 NEW FDAERR
DO FILE^DIE("","FDA","FDAERR")
+6 QUIT $$ERROR(.FDAERR)
+7 SET IE=$ORDER(^VPS(853.875,"B",NM_":::V "_VER,""))
+8 NEW FDA
SET FDA(FIL,IE_",",.01)="@"
+9 NEW FDAERR
DO FILE^DIE("","FDA","FDAERR")
+10 QUIT $$ERROR(.FDAERR)
+11 ;
UPDATENM(IEN,NM) ; Update Survey Name
+1 NEW FIL
SET FIL=853.85
+2 NEW FDA
SET FDA(FIL,IEN_",",1)=NM
+3 NEW FDAERR
DO FILE^DIE("","FDA","FDAERR")
+4 QUIT $$ERROR(.FDAERR)
+5 ;
+6 ;
ADSRVYKY() ;add survey Identifiers
+1 NEW FIL
SET FIL=853.85
+2 NEW SUBS
SET SUBS="+1,"
+3 NEW FDA,FDAERR
+4 NEW FLD
SET FLD=0
+5 NEW QNAME,VER,ID,IEN,INM
+6 SET QNAME=$PIECE(VPSDATA(1),U,4)
+7 SET VER=$PIECE(VPSDATA(4),U,4)
+8 SET ID=$PIECE(VPSDATA(3),U,4)
+9 SET INM=$PIECE(VPSDATA(2),U,4)
+10 if $ORDER(^VPS(FIL,"B",ID,""))'=""
QUIT ""
+11 IF $LENGTH(QNAME)<3
QUIT "Survey name length too short "_QNAME
+12 IF $LENGTH(QNAME)>240
QUIT "SURVEY NAME length violation "_QNAME
+13 IF $LENGTH(INM)<3
QUIT "QUESTIONNAIRE INTERNAL NAME length violation "_INM
+14 ;
+15 ; -- fill in FDA with the survey data
+16 SET FDA(FIL,SUBS,.01)=ID
+17 SET FDA(FIL,SUBS,1)=QNAME
+18 SET FDA(FIL,SUBS,2)=VER
+19 ;S FDA(853.85,SUBS,3)=INM
+20 ;
+21 ; -- store the survey data
+22 DO UPDATE^DIE("E","FDA","","FDAERR")
+23 IF '$DATA(FDAERR)
Begin DoDot:1
+24 KILL ^TMP("CSQ ARRAY",$JOB)
+25 SET ^TMP("CSQ ARRAY",$JOB,1,0)=INM
+26 SET SUBS=$ORDER(^VPS(FIL,"B",ID,""))_","
+27 DO WP^DIE(FIL,SUBS,3,"","^TMP(""CSQ ARRAY"",$J)","FDAERR")
End DoDot:1
+28 QUIT $$ERROR(.FDAERR)
+29 ;
ADDDFN(VPSDFN) ;Add Survey (patient level)
+1 if $DATA(^VPS(853.8,VPSDFN,0))
QUIT ""
+2 NEW FIL
SET FIL=853.8
+3 NEW IENS
SET IENS(1)=VPSDFN
+4 NEW FDA
SET FDA(FIL,"+1,",.01)=VPSDFN
+5 NEW FDAERR
DO UPDATE^DIE("","FDA","IENS","FDAERR")
+6 QUIT $$ERROR(.FDAERR)
+7 ;
ADDQST(VPSDFN,TMPIEN) ;add (QUESTIONNAIRE IDENTIFIER level)
+1 if $DATA(^VPS(853.8,VPSDFN,1,TID))
QUIT ""
+2 NEW FIL
SET FIL=853.805
+3 NEW IENS
SET IENS(1)=TMPIEN
+4 NEW SUBS
SET SUBS="+1,"_VPSDFN_","
+5 NEW FDA,FDAERR
+6 NEW FLD
SET FLD=0
+7 ;
+8 SET FDA(FIL,SUBS,.01)=TMPIEN
+9 ;
+10 ; -- store the survey data
+11 DO UPDATE^DIE("","FDA","IENS","FDAERR")
+12 QUIT $$ERROR(.FDAERR)
+13 ;
UPDATE(VPSDFN,VPSDATA,SURVEY,APDATA,ACDATA,QSTDATA,ANSDATA,WPDATA,MODFLG) ;
+1 NEW ER,ID,TID,TRNDT
+2 SET ER=""
+3 SET ID=$PIECE(VPSDATA(3),U,4)
+4 SET TID=$ORDER(^VPS(853.85,"B",ID,""))
+5 IF TID=""
SET ER="No record for this questionnaire "_ID
+6 IF ER=""
IF '$DATA(^VPS(853.8,VPSDFN,1,TID))
SET ER="Cannot update, no record of patient "_VPSDFN_" ever submitting this questionnaire "_$PIECE(VPSDATA(3),U,4)
+7 IF ER=""
Begin DoDot:1
+8 IF $GET(SURVEY(.01))=""!($GET(SURVEY(.02))="")
SET ER="Key information missing: Response ID: "_$GET(SURVEY(.01))_" date/time questionnaire taken "_$GET(SURVEY(.02))
+9 if ER]""
QUIT
+10 SET TRNDT=$ORDER(^VPS(853.8,"D",SURVEY(.01),SURVEY(.02),VPSDFN,TID,""),-1)
+11 IF TRNDT=""
SET ER="No questionnaire for patient "_VPSDFN_" matches information Questionnaire :"_ID_" Response ID: "_SURVEY(.01)_" date/time questionnaire taken "_SURVEY(.02)
End DoDot:1
+12 IF ER=""
SET ER=$$ADDRES^VPSSRVY4(VPSDFN,TID,TRNDT,.SURVEY,MODFLG)
+13 IF ER=""
SET ER=$$ADDAPPT^VPSSRVY4(VPSDFN,TID,TRNDT,.APDATA,MODFLG)
+14 IF ER=""
SET ER=$$ADDCALC^VPSSRVY4(VPSDFN,TID,TRNDT,.ACDATA,MODFLG)
+15 IF ER=""
SET ER=$$ADDQUEST^VPSSRVY4(VPSDFN,TID,TRNDT,.QSTDATA,.ANSDATA,.WPDATA,MODFLG)
+16 QUIT ER
CLNSRVY(VPSDFN,TID,TRNDT) ; delete Questionnaire
+1 NEW FIL
SET FIL=853.81
+2 NEW FDA
SET FDA(FIL,TRNDT_","_TID_","_VPSDFN_",",.01)="@"
+3 NEW ERR
DO FILE^DIE("","FDA")
+4 QUIT
+5 ;
GETFLD(SVYLST,APSVYLST,ACSVYLST,QSVYLST,ANSVYLST,WPLST,FLDLEN,REQFLD) ;get field maps
+1 NEW LN,LINE,STRING
+2 FOR LN=1:1
SET LINE=$TEXT(LST+LN)
SET STRING=$PIECE(LINE,";;",2)
if STRING=""
QUIT
SET SVYLST($PIECE(STRING,U,2))=$PIECE(STRING,U)
SET FLDLEN(853.811,$PIECE(STRING,U,2))=$PIECE(STRING,U,4,5)
SET REQFLD(853.811,$PIECE(STRING,U,2))=$PIECE(STRING,U,6)
+3 FOR LN=1:1
SET LINE=$TEXT(APLST+LN)
SET STRING=$PIECE(LINE,";;",2)
if STRING=""
QUIT
SET APSVYLST($PIECE(STRING,U,2))=$PIECE(STRING,U)
SET FLDLEN(853.8111,$PIECE(STRING,U,2))=$PIECE(STRING,U,4,5)
SET REQFLD(853.8111,$PIECE(STRING,U,2))=$PIECE(STRING,U,6)
+4 FOR LN=1:1
SET LINE=$TEXT(ACLST+LN)
SET STRING=$PIECE(LINE,";;",2)
if STRING=""
QUIT
SET ACSVYLST($PIECE(STRING,U,2))=$PIECE(STRING,U)
SET FLDLEN(853.8112,$PIECE(STRING,U,2))=$PIECE(STRING,U,4,5)
SET REQFLD(853.8112,$PIECE(STRING,U,2))=$PIECE(STRING,U,6)
+5 FOR LN=1:1
SET LINE=$TEXT(QSTLST+LN)
SET STRING=$PIECE(LINE,";;",2)
if STRING=""
QUIT
Begin DoDot:1
+6 SET QSVYLST($PIECE(STRING,U,2))=$PIECE(STRING,U)
+7 SET FLDLEN(853.8113,$PIECE(STRING,U,2))=$PIECE(STRING,U,4,5)
+8 SET REQFLD(853.8113,$PIECE(STRING,U,2))=$PIECE(STRING,U,6)
+9 IF $PIECE(STRING,U,3)=1
SET WPLST(853.8113,$PIECE(STRING,U))=1
End DoDot:1
+10 FOR LN=1:1
SET LINE=$TEXT(ANSLST+LN)
SET STRING=$PIECE(LINE,";;",2)
if STRING=""
QUIT
Begin DoDot:1
+11 SET ANSVYLST($PIECE(STRING,U,2))=$PIECE(STRING,U)
+12 SET FLDLEN(853.81133,$PIECE(STRING,U,2))=$PIECE(STRING,U,4,5)
+13 SET REQFLD(853.81133,$PIECE(STRING,U,2))=$PIECE(STRING,U,6)
+14 IF $PIECE(STRING,U,3)=1
SET WPLST(853.81133,$PIECE(STRING,U))=1
End DoDot:1
+15 QUIT
+16 ;
PREP(INDATA,SURVEY,APDAT,ACDAT,QDAT,ANSDAT,WPFLD) ;Based on Vetlink input data, prepare survey data to file
+1 NEW SVYFLD,MSVYFLD,FLDLEN,APFLD,ACFLD,QSTFLD,ANFLD,FLDLEN,REQFLD
+2 DO GETFLD(.SVYFLD,.APFLD,.ACFLD,.QSTFLD,.ANFLD,.WPFLD,.FLDLEN,.REQFLD)
+3 ;
+4 NEW FLD,FLDNO,FLDVAL,MULTSEQ
+5 NEW ER
SET ER=""
+6 NEW SEQ
SET SEQ=0
+7 NEW QLC
+8 NEW ALC
+9 NEW SQN
+10 NEW QLEN
+11 ;
+12 FOR
SET SEQ=$ORDER(INDATA(SEQ))
if 'SEQ
QUIT
Begin DoDot:1
+13 ;multiple sequence # for multiple field such as Questions, responses, and calculated values
SET MULTSEQ=$PIECE(INDATA(SEQ),U,2)
+14 ;Input Field Name
SET FLD=$PIECE(INDATA(SEQ),U)
IF FLD=""
SET ER="Field Name is required"
QUIT
+15 SET SQN=$PIECE(INDATA(SEQ),U,3)
+16 SET FLDVAL=$PIECE(INDATA(SEQ),U,4)
+17 ;Field #
SET FLDNO=$SELECT($DATA(APFLD(FLD)):APFLD(FLD),$DATA(ACFLD(FLD)):ACFLD(FLD),$DATA(QSTFLD(FLD)):QSTFLD(FLD),$DATA(ANFLD(FLD)):ANFLD(FLD),1:$GET(SVYFLD(FLD)))
+18 IF FLDNO=""
SET ER="Invalid Field - "_FLD
QUIT
+19 IF $DATA(SVYFLD(FLD))
SET SURVEY(FLDNO)=FLDVAL
SET ER=$$LENCHK($GET(FLDLEN(853.811,FLDNO)),FLDVAL,FLDNO)
IF ER=""
SET ER=$$REQ($GET(REQFLD(853.811,FLD)),FLDVAL,FLD)
+20 IF $DATA(APFLD(FLD))
SET APDAT(MULTSEQ,FLDNO)=FLDVAL
SET ER=$$LENCHK($GET(FLDLEN(853.8111,FLDNO)),FLDVAL,FLDNO)
IF ER=""
SET ER=$$REQ($GET(REQFLD(853.8111,FLD)),FLDVAL,FLD)
+21 IF $DATA(ACFLD(FLD))
SET ACDAT(MULTSEQ,FLDNO)=FLDVAL
SET ER=$$LENCHK($GET(FLDLEN(853.8112,FLDNO)),FLDVAL,FLDNO)
IF ER=""
SET ER=$$REQ($GET(REQFLD(853.8112,FLD)),FLDVAL,FLD)
+22 IF $DATA(QSTFLD(FLD))
Begin DoDot:2
+23 IF $DATA(WPFLD(853.8113,FLDNO))
SET QLC(MULTSEQ)=$GET(QLC(MULTSEQ))+1
SET QDAT(MULTSEQ,FLDNO,QLC(MULTSEQ))=FLDVAL
+24 IF '$TEST
SET QDAT(MULTSEQ,FLDNO)=FLDVAL
SET ER=$$LENCHK($GET(FLDLEN(853.8113,FLDNO)),FLDVAL,FLDNO)
IF ER=""
SET ER=$$REQ($GET(REQFLD(853.8113,FLD)),FLDVAL,FLD)
End DoDot:2
+25 IF $DATA(ANFLD(FLD))
Begin DoDot:2
+26 IF $DATA(WPFLD(853.81133,FLDNO))
Begin DoDot:3
+27 SET ALC(MULTSEQ)=$GET(ALC(MULTSEQ))+1
SET ANSDAT(MULTSEQ,+SQN,FLDNO,ALC(MULTSEQ))=FLDVAL
End DoDot:3
+28 IF '$TEST
Begin DoDot:3
+29 SET ANSDAT(MULTSEQ,+SQN,FLDNO)=FLDVAL
SET ER=$$LENCHK($GET(FLDLEN(853.81133,FLDNO)),FLDVAL,FLDNO)
IF ER=""
SET ER=$$REQ($GET(REQFLD(853.81133,FLD)),FLDVAL,FLD)
+30 IF FLDNO=1
IF FLDVAL=""
NEW %,%I,%H,X
DO NOW^%DTC
SET ANSDAT(MULTSEQ,+SQN,FLDNO)=%
End DoDot:3
End DoDot:2
End DoDot:1
if ER'=""
QUIT
+31 NEW I,J
+32 SET I=0
+33 FOR
SET I=$ORDER(QDAT(I))
if 'I
QUIT
SET J=0
SET QLEN(I)=0
FOR
SET J=$ORDER(QDAT(I,2,J))
if 'J
QUIT
SET QLEN(I)=QLEN(I)+$LENGTH(QDAT(I,2,J))
+34 SET I=0
+35 FOR
SET I=$ORDER(QLEN(I))
if 'I
QUIT
IF QLEN(I)<1
SET ER="Data incorrect length for field QUESTION PRESENTED"
+36 ;
+37 QUIT ER
+38 ;
+39 ;
LENCHK(LENSTR,STRING,FLD) ;
+1 ;
+2 NEW MIN,MAX
+3 SET MIN=+$PIECE(LENSTR,U)
+4 SET MAX=+$PIECE(LENSTR,U,2)
+5 IF MIN=0
IF MAX=0
QUIT ""
+6 IF MIN>0
IF MIN>$LENGTH(STRING)
QUIT "Data incorrect length for field "_FLD
+7 IF MAX>0
IF MAX<$LENGTH(STRING)
QUIT "Data incorrect length for field "_FLD
+8 QUIT ""
+9 ;
REQ(REQFLG,STR,FLD) ;
+1 IF '+REQFLG
QUIT ""
+2 IF STR=""
QUIT "Data required for field "_FLD
+3 QUIT ""
+4 ;
ERROR(FDAERR) ;return error text
+1 if '$DATA(FDAERR)
QUIT ""
+2 NEW ERRNUM
SET ERRNUM=0
+3 SET ERRNUM=$ORDER(FDAERR("DIERR",ERRNUM))
+4 NEW ERRTXT
SET ERRTXT=""
+5 if ERRNUM
SET ERRTXT=FDAERR("DIERR",ERRNUM,"TEXT",1)
+6 QUIT ERRTXT
+7 ;
LOCK(VPSDFN) ;Lock this process
+1 LOCK +^TMP("VPSSRVY1",VPSDFN):3
IF '$TEST
QUIT "Another process updating survey for this patient"
+2 QUIT ""
+3 ;
UNLOCK(VPSDFN) ;Unlock this process
+1 LOCK -^TMP("VPSSRVY1",VPSDFN)
+2 QUIT
+3 ;
+4 ;
+5 ; Field # ^ Field Name ^ Word process field flag ^ Min length ^ Max lenght ^ Required
+6 ;
LST ; list of 853.811 fields (Questionnaire response)
+1 ;;.01^RESPONSE IDENTIFIER^^3^250^1
+2 ;;.02^DATE/TIME TAKEN
+3 ;;.03^DATE/TIME MODIFIED
+4 ;;.04^COMPLETION STATUS^^^^1
+5 ;;.05^PATIENT SAFETY^^^^1
+6 ;;.06^IMMEDIATE ACTION^^^^1
+7 ;;4^SURVEY CALCULATED VALUE^^^^1
+8 ;;1^NAME^^3^255^1
+9 ;;9^INTERNAL
+10 ;;10^VERSION^^^^1
+11 ;;11^TEMPLATE ID^^3^60^1
+12 ;;
APLST ; list of 853.8111 fields (Appointment check-in)
+1 ;;.01^APPOINTMENT CHECK-IN ID
+2 ;;
ACLST ; list of 853.8112 fields (ADDITIONAL CALCULATED VALUE)
+1 ;;.01^ADDITIONAL CALC VALUE NAME^^1^20^1
+2 ;;.02^ADDITIONAL CALC VALUE SCORE^^1^20^1
+3 ;;
QSTLST ; list of 853.8113 fields (QUESTIONS)
+1 ;;.01^QUESTION NUMBER^^1^4^1
+2 ;;1^QUESTION CALCULATED VALUE^^3^250^1
+3 ;;2^QUESTION PRESENTED^1^1^^1
+4 ;;
ANSLST ; list of 853.81133 fields (ANSWER)
+1 ;;.01^ANSWER IDENTIFIER^^3^250^1
+2 ;;.02^INTERFACE USED^^^^1
+3 ;;.03^RESPONDENT^^^^1
+4 ;;.04^RESPONDENT NAME^^0^60
+5 ;;1^ANSWER DATE/TIME
+6 ;;2^INTERVIEWER NAME^^0^60
+7 ;;3^KIOSK IDENTIFIER^^3^250
+8 ;;4^KIOSK SESSION IDENTIFIER^^3^250
+9 ;;5^KIOSK GROUP IDENTIFIER^^3^250
+10 ;;6^ANSWER TEXT^1
+11 ;;
+12 QUIT
