VPSCSQ1.m

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 ---VPSCSQ1   8159     printed  Mar 13, 2025@21:48:02                                                                                                                                                                                                     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