VPSCSQ1 ;KC - preinstall routine to save off data and remove existing DD stucture;08/20/14 09:28
;;1.0;VA POINT OF SERVICE (KIOSKS);**14**;Aug 20, 2015;Build 26
;;Per VHA Directive 2004-038, this routine should not be modified.
;
QUIT
;
;
EN ; Entry point for calling both tags to save off existing VPS information
I $D(^DD(853.81133)) S ^TMP("VPS 1*14",$J,"DNC")=1 Q
D EN0,EN1
Q
EN0 ; entry point for saving off existing VPS QUESTIONNAIRE INTERNAL NAME (File: 853.85, Field 3)
N A,VPSARR
S A=0
S VPSARR="^TMP(""VPS QIN"",$J)"
K @VPSARR
F S A=$O(^VPS(853.85,A)) Q:'A S @VPSARR@(A,1,0)=$$GET1^DIQ(853.85,A_",",3)
;K ^TMP("VPS 853.85 HOLD")
;M ^TMP("VPS 853.85 HOLD",853.85)=^VPS(853.85)
Q
EN1 ; entry point for saving off existing VPS CSQ data
;
; Save off existing VPS CSQ data into TMP global
N CSQARR,DFN
S CSQARR="^TMP(""VPS CSQ"",$J)"
K @CSQARR
S DFN=0
F S DFN=$O(^VPS(853.8,DFN)) Q:'DFN D GETS^DIQ(853.8,DFN_",","**","I",.CSQARR)
;K ^TMP("VPS 853.8 HOLD")
;M ^TMP("VPS 853.8 HOLD",853.8)=^VPS(853.8)
H 2
;
; Remove existing VPS CSQ DD and data
S DIU="^VPS(853.8,",DIU(0)="DS" D EN^DIU2
; now evironment is prepared for the installation of VPS*1.0*14
; which has a totally new data structure for VPS CSQ information
Q
;
; Entry point for moving saved off information into new structure
UPDATE ;
I $G(^TMP("VPS 1*14",$J,"DNC"))=1 Q
D EN2,EN3
Q
;
EN2 ; Entry point for moving VPS QUESTIONNAIRE INTERNAL NAME into its word processing field
N A,VPSARR,FDAERR,QIN,DIK
S A=0
S VPSARR="^TMP(""VPS QIN"",$J)"
F S A=$O(@VPSARR@(A)) Q:'A!$D(FDAERR) D WP^DIE(853.85,A_",",3,"","^TMP(""VPS QIN"",$J,"_A_")","FDAERR")
;
; Add leading space to Template ID field to prevent it from being evaluated as a number
;S A=0
;F S A=$O(^VPS(853.85,A)) Q:'A S QIN=$P(^VPS(853.85,A,0),U),QIN="VPS_"_QIN,$P(^VPS(853.85,A,0),U)=QIN
K ^VPS(853.85,"B")
S DIK="^VPS(853.85," D IXALL^DIK
Q
EN3 ; Entry point for moving previous CSQ information into the new CSQ data structure
;
N CSQARR,DFN,SUB8,SUB81,SUB811
N DTS,DTT,DTLM,DAT,INV,SCV,CS,PS,IA,TID,CREATOR
N CNT,QNUM,QUEST,ANS,QCV
;
S CSQARR="^TMP(""VPS CSQ"",$J)"
;
S SUB8=""
CSQ8 ;Obtain DFN
S SUB8=$O(@CSQARR@(853.8,SUB8))
G:SUB8="" DONE
S DFN=@CSQARR@(853.8,SUB8,.01,"I") ; PATIENT
;
S SUB81=""
; Obtain data from the 853.81 sub-file for given DFN
CSQ81 ;
S SUB81=$O(@CSQARR@(853.81,SUB81))
G:SUB81="" CSQ8
I $P(SUB81,",",2)'=DFN G CSQ81
S DTS=@CSQARR@(853.81,SUB81,.01,"I") ; DATE/TIME STORED
S DTT=@CSQARR@(853.81,SUB81,2,"I") ; DATE/TIME TAKEN
S DTLM=@CSQARR@(853.81,SUB81,3,"I") ; DATE/TIME LAST MODIFIED
S DAT=@CSQARR@(853.81,SUB81,4,"I")
S INV=$$GET1^DIQ(200,DAT_",",.01) ; INTERVIEWER STAFF
S SCV=@CSQARR@(853.81,SUB81,5,"I") ; SURVEY CALCULATED VALUE
S CS=@CSQARR@(853.81,SUB81,6,"I") ; COMPLETION STATUS
; Convert completion status into new set values
I CS="C" S CS=1
E S CS=2
S PS=@CSQARR@(853.81,SUB81,7,"I") ; PATIENT SAFETY
; Convert patient safety into new set values
I PS="Y" S PS=1
E S PS=2
;
S IA=@CSQARR@(853.81,SUB81,8,"I") ; IMMEDIATE ACTION
; Convert immediate action into new set values
I IA="Y" S IA=1
E S IA=2
;
S TID=@CSQARR@(853.81,SUB81,11,"I") ; QUESTIONNAIRE TEMPLATE ID
S CREATOR=@CSQARR@(853.81,SUB81,12,"I") ; SURVEY CREATOR
;
S SUB811=""
S CNT=0
K QNUM,QUEST,ANS,QCV
; Obtain data from the 853.811 sub-file for given DFN
CSQ811 ;
S SUB811=$O(@CSQARR@(853.811,SUB811))
G:SUB811="" STORE
I $P(SUB811,",",3)'=DFN G CSQ811 ; making sure dealing wiht same paitent
I $P(SUB811,",",2)'=DTS G CSQ811 ; making sure information is for same date/time stored
S CNT=CNT+1
S QNUM(CNT)=@CSQARR@(853.811,SUB811,.01,"I") ; QUESTION NUMBER
S QUEST(CNT)=@CSQARR@(853.811,SUB811,1,"I") ; QUESTION PRESENTED
S ANS(CNT)=@CSQARR@(853.811,SUB811,2,"I") ; ANSWER RESPONSE PROVIDED
S QCV(CNT)=@CSQARR@(853.811,SUB811,3,"I") ; QUESTION CALCULATED VALUE
G CSQ811
;
; Create CSQ record for the information
STORE ;
;
; STORE DATA
D ADDDFN(DFN)
D ADDQST(DFN,TID)
D ADDSRVY(DFN,TID,DTS,CREATOR)
D ADDRES(DFN,TID,DTS,DTT,DTLM,CS,PS,IA)
D ADDQUEST(DFN,TID,DTS,DTLM,.QNUM,.QCV,.QUEST,.ANS)
G CSQ81
;
;
;
DONE ;
QUIT
;
;================================================================================================================
; THE BELOW CODE COULD BE MODIFIED TO STORE INFOMATION IN THE NEW CSQ DATA STRUCTURE
;
;================================================================================================================
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,SURVEY) ;add (QUESTIONNAIRE IDENTIFIER level)
N FIL S FIL=853.805
N IENS S IENS(1)=SURVEY
N SUBS S SUBS="+1,"_VPSDFN_","
N FDA,FDAERR
N FLD S FLD=0
;
S FDA(FIL,SUBS,.01)=SURVEY
;
; -- store the survey data
D UPDATE^DIE("","FDA","IENS","FDAERR")
QUIT $$ERROR(.FDAERR)
ADDSRVY(VPSDFN,TID,TRNDT,SURVEY) ;add survey (questionnaire level)
N FIL S FIL=853.81
N IENS S IENS(1)=TRNDT
N SUBS S SUBS="+1,"_TID_","_VPSDFN_","
N FDA,FDAERR
N FLD S FLD=0
;
; -- fill in FDA with the survey data
S FDA(853.81,SUBS,.01)=TRNDT
;S FDA(853.81,SUBS,.02)=.5
;
; -- store the survey data
D UPDATE^DIE("","FDA","IENS","FDAERR")
QUIT $$ERROR(.FDAERR)
ADDRES(VPSDFN,TID,TRNDT,DTT,DTLM,CS,PS,IA) ;add questionnaire response
N FIL S FIL=853.811
N IENS S IENS(1)=1
N SUBS S SUBS="+1,"_TRNDT_","_TID_","_VPSDFN_","
N FDA,FDAERR
; -- fill in FDA with the survey data
S FDA(853.811,SUBS,.01)="CONVERTED"
S FDA(853.811,SUBS,.02)=DTT
S FDA(853.811,SUBS,.03)=DTLM
S FDA(853.811,SUBS,.04)=CS
S FDA(853.811,SUBS,.05)=PS
S FDA(853.811,SUBS,.06)=IA
D UPDATE^DIE("","FDA","IENS","FDAERR")
;
QUIT $$ERROR(.FDAERR)
;
ADDQUEST(VPSDFN,TID,TRNDT,DTLM,QNUM,QCV,QUEST,ANS) ;add question
N FIL S FIL=853.8113
N SUBS,SUBWP
N IENS
N FDA,FDAERR
N WPERR,I,MULT
; -- fill in FDA with the survey data
S I=0
F S I=$O(QNUM(I)) Q:'I D
. S IENS(1)=I
. S SUBS="+1,"_1_","_TRNDT_","_TID_","_VPSDFN_","
. S FDA(853.8113,SUBS,.01)=QNUM(I)
. S FDA(853.8113,SUBS,1)=QCV(I)
. D UPDATE^DIE("E","FDA","IENS","FDAERR")
. K ^TMP("CSQ CON",$J)
. S ^TMP("CSQ CON",$J,1,0)=QUEST(I)
. S SUBWP=I_",1,"_TRNDT_","_TID_","_VPSDFN_","
. K WPERR
. D WP^DIE(FIL,SUBWP,2,"","^TMP(""CSQ CON"",$J)","WPERR")
. S MULT=0
. I ANS(I)["~"!(ANS(I)["^") S MULT=1
. I MULT=0 D ADDANS(SUBWP,I,VPSDFN,TID,TRNDT,.ANS,DTLM)
. I MULT=1 D
.. N ARR,J
.. I ANS(I)["~" F J=1:1:$L(ANS(I),"~") S ARR(I)=$P(ANS(I),"~",J) D ADDANS(SUBWP,I,VPSDFN,TID,TRNDT,.ARR,DTLM)
.. I ANS(I)["^" F J=1:1:$L(ANS(I),"^") S ARR(I)=$P(ANS(I),"^",J) D ADDANS(SUBWP,I,VPSDFN,TID,TRNDT,.ARR,DTLM)
;
;
QUIT $$ERROR(.FDAERR)
;
ADDANS(SUBS,I,VPSDFN,TID,TRNDT,ANS,DTLM) ;add ANSWER
N FIL S FIL=853.81133
N IENS
N FDA,FDAERR
N SUBWP,WPERR
; -- fill in FDA with the survey data
;
Q:'$D(ANS(I))
S IENS(1)=I
S SUBS="+1,"_SUBS
S FDA(853.81133,SUBS,.01)="ANSWER "_I
S FDA(853.81133,SUBS,.02)=2
S FDA(853.81133,SUBS,.03)=1
S FDA(853.81133,SUBS,1)=DTLM
S FDA(853.81133,SUBS,3)="CONVERTED"
S FDA(853.81133,SUBS,4)="CONVERTED"
S FDA(853.81133,SUBS,5)="CONVERTED"
D UPDATE^DIE("","FDA","IENS","FDAERR")
K ^TMP("CSQ CON",$J)
S ^TMP("CSQ CON",$J,1,0)=ANS(I)
S SUBWP=I_","_I_",1,"_TRNDT_","_TID_","_VPSDFN_","
K WPERR
D WP^DIE(FIL,SUBWP,6,"","^TMP(""CSQ CON"",$J)","WPERR")
;
QUIT $$ERROR(.FDAERR)
;
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVPSCSQ1 8159 printed Dec 13, 2024@02:43 Page 2
VPSCSQ1 ;KC - preinstall routine to save off data and remove existing DD stucture;08/20/14 09:28
+1 ;;1.0;VA POINT OF SERVICE (KIOSKS);**14**;Aug 20, 2015;Build 26
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 QUIT
+5 ;
+6 ;
EN ; Entry point for calling both tags to save off existing VPS information
+1 IF $DATA(^DD(853.81133))
SET ^TMP("VPS 1*14",$JOB,"DNC")=1
QUIT
+2 DO EN0
DO EN1
+3 QUIT
EN0 ; entry point for saving off existing VPS QUESTIONNAIRE INTERNAL NAME (File: 853.85, Field 3)
+1 NEW A,VPSARR
+2 SET A=0
+3 SET VPSARR="^TMP(""VPS QIN"",$J)"
+4 KILL @VPSARR
+5 FOR
SET A=$ORDER(^VPS(853.85,A))
if 'A
QUIT
SET @VPSARR@(A,1,0)=$$GET1^DIQ(853.85,A_",",3)
+6 ;K ^TMP("VPS 853.85 HOLD")
+7 ;M ^TMP("VPS 853.85 HOLD",853.85)=^VPS(853.85)
+8 QUIT
EN1 ; entry point for saving off existing VPS CSQ data
+1 ;
+2 ; Save off existing VPS CSQ data into TMP global
+3 NEW CSQARR,DFN
+4 SET CSQARR="^TMP(""VPS CSQ"",$J)"
+5 KILL @CSQARR
+6 SET DFN=0
+7 FOR
SET DFN=$ORDER(^VPS(853.8,DFN))
if 'DFN
QUIT
DO GETS^DIQ(853.8,DFN_",","**","I",.CSQARR)
+8 ;K ^TMP("VPS 853.8 HOLD")
+9 ;M ^TMP("VPS 853.8 HOLD",853.8)=^VPS(853.8)
+10 HANG 2
+11 ;
+12 ; Remove existing VPS CSQ DD and data
+13 SET DIU="^VPS(853.8,"
SET DIU(0)="DS"
DO EN^DIU2
+14 ; now evironment is prepared for the installation of VPS*1.0*14
+15 ; which has a totally new data structure for VPS CSQ information
+16 QUIT
+17 ;
+18 ; Entry point for moving saved off information into new structure
UPDATE ;
+1 IF $GET(^TMP("VPS 1*14",$JOB,"DNC"))=1
QUIT
+2 DO EN2
DO EN3
+3 QUIT
+4 ;
EN2 ; Entry point for moving VPS QUESTIONNAIRE INTERNAL NAME into its word processing field
+1 NEW A,VPSARR,FDAERR,QIN,DIK
+2 SET A=0
+3 SET VPSARR="^TMP(""VPS QIN"",$J)"
+4 FOR
SET A=$ORDER(@VPSARR@(A))
if 'A!$DATA(FDAERR)
QUIT
DO WP^DIE(853.85,A_",",3,"","^TMP(""VPS QIN"",$J,"_A_")","FDAERR")
+5 ;
+6 ; Add leading space to Template ID field to prevent it from being evaluated as a number
+7 ;S A=0
+8 ;F S A=$O(^VPS(853.85,A)) Q:'A S QIN=$P(^VPS(853.85,A,0),U),QIN="VPS_"_QIN,$P(^VPS(853.85,A,0),U)=QIN
+9 KILL ^VPS(853.85,"B")
+10 SET DIK="^VPS(853.85,"
DO IXALL^DIK
+11 QUIT
EN3 ; Entry point for moving previous CSQ information into the new CSQ data structure
+1 ;
+2 NEW CSQARR,DFN,SUB8,SUB81,SUB811
+3 NEW DTS,DTT,DTLM,DAT,INV,SCV,CS,PS,IA,TID,CREATOR
+4 NEW CNT,QNUM,QUEST,ANS,QCV
+5 ;
+6 SET CSQARR="^TMP(""VPS CSQ"",$J)"
+7 ;
+8 SET SUB8=""
CSQ8 ;Obtain DFN
+1 SET SUB8=$ORDER(@CSQARR@(853.8,SUB8))
+2 if SUB8=""
GOTO DONE
+3 ; PATIENT
SET DFN=@CSQARR@(853.8,SUB8,.01,"I")
+4 ;
+5 SET SUB81=""
+6 ; Obtain data from the 853.81 sub-file for given DFN
CSQ81 ;
+1 SET SUB81=$ORDER(@CSQARR@(853.81,SUB81))
+2 if SUB81=""
GOTO CSQ8
+3 IF $PIECE(SUB81,",",2)'=DFN
GOTO CSQ81
+4 ; DATE/TIME STORED
SET DTS=@CSQARR@(853.81,SUB81,.01,"I")
+5 ; DATE/TIME TAKEN
SET DTT=@CSQARR@(853.81,SUB81,2,"I")
+6 ; DATE/TIME LAST MODIFIED
SET DTLM=@CSQARR@(853.81,SUB81,3,"I")
+7 SET DAT=@CSQARR@(853.81,SUB81,4,"I")
+8 ; INTERVIEWER STAFF
SET INV=$$GET1^DIQ(200,DAT_",",.01)
+9 ; SURVEY CALCULATED VALUE
SET SCV=@CSQARR@(853.81,SUB81,5,"I")
+10 ; COMPLETION STATUS
SET CS=@CSQARR@(853.81,SUB81,6,"I")
+11 ; Convert completion status into new set values
+12 IF CS="C"
SET CS=1
+13 IF '$TEST
SET CS=2
+14 ; PATIENT SAFETY
SET PS=@CSQARR@(853.81,SUB81,7,"I")
+15 ; Convert patient safety into new set values
+16 IF PS="Y"
SET PS=1
+17 IF '$TEST
SET PS=2
+18 ;
+19 ; IMMEDIATE ACTION
SET IA=@CSQARR@(853.81,SUB81,8,"I")
+20 ; Convert immediate action into new set values
+21 IF IA="Y"
SET IA=1
+22 IF '$TEST
SET IA=2
+23 ;
+24 ; QUESTIONNAIRE TEMPLATE ID
SET TID=@CSQARR@(853.81,SUB81,11,"I")
+25 ; SURVEY CREATOR
SET CREATOR=@CSQARR@(853.81,SUB81,12,"I")
+26 ;
+27 SET SUB811=""
+28 SET CNT=0
+29 KILL QNUM,QUEST,ANS,QCV
+30 ; Obtain data from the 853.811 sub-file for given DFN
CSQ811 ;
+1 SET SUB811=$ORDER(@CSQARR@(853.811,SUB811))
+2 if SUB811=""
GOTO STORE
+3 ; making sure dealing wiht same paitent
IF $PIECE(SUB811,",",3)'=DFN
GOTO CSQ811
+4 ; making sure information is for same date/time stored
IF $PIECE(SUB811,",",2)'=DTS
GOTO CSQ811
+5 SET CNT=CNT+1
+6 ; QUESTION NUMBER
SET QNUM(CNT)=@CSQARR@(853.811,SUB811,.01,"I")
+7 ; QUESTION PRESENTED
SET QUEST(CNT)=@CSQARR@(853.811,SUB811,1,"I")
+8 ; ANSWER RESPONSE PROVIDED
SET ANS(CNT)=@CSQARR@(853.811,SUB811,2,"I")
+9 ; QUESTION CALCULATED VALUE
SET QCV(CNT)=@CSQARR@(853.811,SUB811,3,"I")
+10 GOTO CSQ811
+11 ;
+12 ; Create CSQ record for the information
STORE ;
+1 ;
+2 ; STORE DATA
+3 DO ADDDFN(DFN)
+4 DO ADDQST(DFN,TID)
+5 DO ADDSRVY(DFN,TID,DTS,CREATOR)
+6 DO ADDRES(DFN,TID,DTS,DTT,DTLM,CS,PS,IA)
+7 DO ADDQUEST(DFN,TID,DTS,DTLM,.QNUM,.QCV,.QUEST,.ANS)
+8 GOTO CSQ81
+9 ;
+10 ;
+11 ;
DONE ;
+1 QUIT
+2 ;
+3 ;================================================================================================================
+4 ; THE BELOW CODE COULD BE MODIFIED TO STORE INFOMATION IN THE NEW CSQ DATA STRUCTURE
+5 ;
+6 ;================================================================================================================
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,SURVEY) ;add (QUESTIONNAIRE IDENTIFIER level)
+1 NEW FIL
SET FIL=853.805
+2 NEW IENS
SET IENS(1)=SURVEY
+3 NEW SUBS
SET SUBS="+1,"_VPSDFN_","
+4 NEW FDA,FDAERR
+5 NEW FLD
SET FLD=0
+6 ;
+7 SET FDA(FIL,SUBS,.01)=SURVEY
+8 ;
+9 ; -- store the survey data
+10 DO UPDATE^DIE("","FDA","IENS","FDAERR")
+11 QUIT $$ERROR(.FDAERR)
ADDSRVY(VPSDFN,TID,TRNDT,SURVEY) ;add survey (questionnaire level)
+1 NEW FIL
SET FIL=853.81
+2 NEW IENS
SET IENS(1)=TRNDT
+3 NEW SUBS
SET SUBS="+1,"_TID_","_VPSDFN_","
+4 NEW FDA,FDAERR
+5 NEW FLD
SET FLD=0
+6 ;
+7 ; -- fill in FDA with the survey data
+8 SET FDA(853.81,SUBS,.01)=TRNDT
+9 ;S FDA(853.81,SUBS,.02)=.5
+10 ;
+11 ; -- store the survey data
+12 DO UPDATE^DIE("","FDA","IENS","FDAERR")
+13 QUIT $$ERROR(.FDAERR)
ADDRES(VPSDFN,TID,TRNDT,DTT,DTLM,CS,PS,IA) ;add questionnaire response
+1 NEW FIL
SET FIL=853.811
+2 NEW IENS
SET IENS(1)=1
+3 NEW SUBS
SET SUBS="+1,"_TRNDT_","_TID_","_VPSDFN_","
+4 NEW FDA,FDAERR
+5 ; -- fill in FDA with the survey data
+6 SET FDA(853.811,SUBS,.01)="CONVERTED"
+7 SET FDA(853.811,SUBS,.02)=DTT
+8 SET FDA(853.811,SUBS,.03)=DTLM
+9 SET FDA(853.811,SUBS,.04)=CS
+10 SET FDA(853.811,SUBS,.05)=PS
+11 SET FDA(853.811,SUBS,.06)=IA
+12 DO UPDATE^DIE("","FDA","IENS","FDAERR")
+13 ;
+14 QUIT $$ERROR(.FDAERR)
+15 ;
ADDQUEST(VPSDFN,TID,TRNDT,DTLM,QNUM,QCV,QUEST,ANS) ;add question
+1 NEW FIL
SET FIL=853.8113
+2 NEW SUBS,SUBWP
+3 NEW IENS
+4 NEW FDA,FDAERR
+5 NEW WPERR,I,MULT
+6 ; -- fill in FDA with the survey data
+7 SET I=0
+8 FOR
SET I=$ORDER(QNUM(I))
if 'I
QUIT
Begin DoDot:1
+9 SET IENS(1)=I
+10 SET SUBS="+1,"_1_","_TRNDT_","_TID_","_VPSDFN_","
+11 SET FDA(853.8113,SUBS,.01)=QNUM(I)
+12 SET FDA(853.8113,SUBS,1)=QCV(I)
+13 DO UPDATE^DIE("E","FDA","IENS","FDAERR")
+14 KILL ^TMP("CSQ CON",$JOB)
+15 SET ^TMP("CSQ CON",$JOB,1,0)=QUEST(I)
+16 SET SUBWP=I_",1,"_TRNDT_","_TID_","_VPSDFN_","
+17 KILL WPERR
+18 DO WP^DIE(FIL,SUBWP,2,"","^TMP(""CSQ CON"",$J)","WPERR")
+19 SET MULT=0
+20 IF ANS(I)["~"!(ANS(I)["^")
SET MULT=1
+21 IF MULT=0
DO ADDANS(SUBWP,I,VPSDFN,TID,TRNDT,.ANS,DTLM)
+22 IF MULT=1
Begin DoDot:2
+23 NEW ARR,J
+24 IF ANS(I)["~"
FOR J=1:1:$LENGTH(ANS(I),"~")
SET ARR(I)=$PIECE(ANS(I),"~",J)
DO ADDANS(SUBWP,I,VPSDFN,TID,TRNDT,.ARR,DTLM)
+25 IF ANS(I)["^"
FOR J=1:1:$LENGTH(ANS(I),"^")
SET ARR(I)=$PIECE(ANS(I),"^",J)
DO ADDANS(SUBWP,I,VPSDFN,TID,TRNDT,.ARR,DTLM)
End DoDot:2
End DoDot:1
+26 ;
+27 ;
+28 QUIT $$ERROR(.FDAERR)
+29 ;
ADDANS(SUBS,I,VPSDFN,TID,TRNDT,ANS,DTLM) ;add ANSWER
+1 NEW FIL
SET FIL=853.81133
+2 NEW IENS
+3 NEW FDA,FDAERR
+4 NEW SUBWP,WPERR
+5 ; -- fill in FDA with the survey data
+6 ;
+7 if '$DATA(ANS(I))
QUIT
+8 SET IENS(1)=I
+9 SET SUBS="+1,"_SUBS
+10 SET FDA(853.81133,SUBS,.01)="ANSWER "_I
+11 SET FDA(853.81133,SUBS,.02)=2
+12 SET FDA(853.81133,SUBS,.03)=1
+13 SET FDA(853.81133,SUBS,1)=DTLM
+14 SET FDA(853.81133,SUBS,3)="CONVERTED"
+15 SET FDA(853.81133,SUBS,4)="CONVERTED"
+16 SET FDA(853.81133,SUBS,5)="CONVERTED"
+17 DO UPDATE^DIE("","FDA","IENS","FDAERR")
+18 KILL ^TMP("CSQ CON",$JOB)
+19 SET ^TMP("CSQ CON",$JOB,1,0)=ANS(I)
+20 SET SUBWP=I_","_I_",1,"_TRNDT_","_TID_","_VPSDFN_","
+21 KILL WPERR
+22 DO WP^DIE(FIL,SUBWP,6,"","^TMP(""CSQ CON"",$J)","WPERR")
+23 ;
+24 QUIT $$ERROR(.FDAERR)
+25 ;
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
