VPSSRVY4 ;WOIFO/KC - VPS CLINICAL SURVEY QUESTIONNAIRE;11/06/2015 11:23
;;1.0;VA POINT OF SERVICE (KIOSKS);**14**;Nov 6, 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
;
ADDSRVY(VPSDFN,TID,TRNDT) ;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
;
; -- store the survey data
D UPDATE^DIE("","FDA","IENS","FDAERR")
QUIT $$ERROR(.FDAERR)
;
ADDRES(VPSDFN,TID,TRNDT,MSURVEY,MODFLG) ;add questionnaire response
N FIL S FIL=853.811
N SUBS
I MODFLG=0 S SUBS="+1,"_TRNDT_","_TID_","_VPSDFN_","
E S SUBS="1,"_TRNDT_","_TID_","_VPSDFN_","
N FDA,FDAERR
N SEQ,FLD S SEQ=0
;
F S SEQ=$O(MSURVEY(SEQ)) Q:'SEQ I ",1,9,10,11,"'[(","_SEQ_",") D QUIT:$D(FDAERR)
. S FDA(FIL,SUBS,SEQ)=MSURVEY(SEQ)
I $D(FDA) D UPDATE^DIE("E","FDA",,"FDAERR")
;
QUIT $$ERROR(.FDAERR)
;
ADDAPPT(VPSDFN,TID,TRNDT,MSURVEY,MODFLG) ;add survey (questionnaire level)
N FIL S FIL=853.8111
N SUBS
I MODFLG=0 S SUBS="+1,1,"_TRNDT_","_TID_","_VPSDFN_","
E S SUBS="1,1,"_TRNDT_","_TID_","_VPSDFN_","
N FDA,FDAERR
N FLD S FLD=0
N SEQ S SEQ=0
;
; -- fill in FDA with the survey data
F S SEQ=$O(MSURVEY(SEQ)) Q:'SEQ D QUIT:$D(FDAERR)
. K FDA S FLD=0
. F S FLD=$O(MSURVEY(SEQ,FLD)) QUIT:'FLD S FDA(FIL,SUBS,FLD)=MSURVEY(SEQ,FLD)
. D UPDATE^DIE("E","FDA",,"FDAERR")
; ;
; -- store the survey data
QUIT $$ERROR(.FDAERR)
;
ADDCALC(VPSDFN,TID,TRNDT,MSURVEY,MODFLG) ;add additional calcualted information
N FIL S FIL=853.8112
N SUBS
I MODFLG=0 S SUBS="+1,1,"_TRNDT_","_TID_","_VPSDFN_","
E S SUBS="1,1,"_TRNDT_","_TID_","_VPSDFN_","
N FDA,FDAERR
N FLD S FLD=0
N SEQ S SEQ=0
;
; -- fill in FDA with the survey data
F S SEQ=$O(MSURVEY(SEQ)) Q:'SEQ D QUIT:$D(FDAERR)
. K FDA S FLD=0
. F S FLD=$O(MSURVEY(SEQ,FLD)) QUIT:'FLD S FDA(FIL,SUBS,FLD)=MSURVEY(SEQ,FLD)
. D UPDATE^DIE("E","FDA",,"FDAERR")
; ;
; -- store the survey data
QUIT $$ERROR(.FDAERR)
;
ADDQUEST(VPSDFN,TID,TRNDT,MSURVEY,ANSSUR,WPFLD,MODFLG) ;add question
N FIL S FIL=853.8113
N SUBS,SUBWP
N ER
;N FDA,FDAERR
N WPERR,I
; -- fill in FDA with the survey data
S SEQ=0
F S SEQ=$O(MSURVEY(SEQ)) Q:'SEQ D QUIT:($D(FDAERR)!$D(WPERR)!($G(ER)))
. I MODFLG=0 S SUBS="+1,1,"_TRNDT_","_TID_","_VPSDFN_","
. E S SUBS=SEQ_",1,"_TRNDT_","_TID_","_VPSDFN_","
. K FDA S FLD=0
. F S FLD=$O(MSURVEY(SEQ,FLD)) QUIT:'FLD D
.. I '$D(WPFLD(FIL,FLD)) S FDA(FIL,SUBS,FLD)=MSURVEY(SEQ,FLD)
.. I $D(WPFLD(FIL,FLD)) D
... N I
... S I=0
... K ^TMP("CSQ ARRAY",$J)
... F S I=$O(MSURVEY(SEQ,FLD,I)) Q:'I S ^TMP("CSQ ARRAY",$J,I,0)=MSURVEY(SEQ,FLD,I)
. D UPDATE^DIE("E","FDA",,"FDAERR")
. S SUBWP=SEQ_",1,"_TRNDT_","_TID_","_VPSDFN_","
. K WPERR
. D WP^DIE(FIL,SUBWP,2,"","^TMP(""CSQ ARRAY"",$J)","WPERR")
. I $D(ANSSUR(SEQ)) D
.. I MODFLG=2 D ;K ^VPS(853.8,VPSDFN,1,TID,1,TRNDT,1,1,3,SEQ,3)
... N DIK,DA
... S DIK="^VPS(853.8,VPSDFN,1,TID,1,TRNDT,1,1,3,SEQ,3,"
... S DA(1)=SEQ,DA(2)=1,DA(3)=TRNDT,DA(4)=TID,DA(5)=VPSDFN
... S DA=" "
... F S DA=$O(^VPS(853.8,VPSDFN,1,TID,1,TRNDT,1,1,3,SEQ,3,DA),-1) Q:'DA D ^DIK
.. N SQN
.. S SQN=""
.. F S SQN=$O(ANSSUR(SEQ,SQN)) Q:SQN=""!($G(ER)]"") S ER=$$ADDANS(VPSDFN,TID,TRNDT,.ANSSUR,.WPFLD,SEQ,SQN,SUBWP,MODFLG)
I '$D(FDAERR),$D(WPERR) G QWPER
;
Q:$G(ER)]"" ER
QUIT $$ERROR(.FDAERR)
;
QWPER ;
QUIT $$ERROR(.WPERR)
;
ADDANS(VPSDFN,TID,TRNDT,MSURVEY,WPFLD,SEQ,SQN,SUBS,MODFLG) ;add ANSWER
N FIL S FIL=853.81133
N FDA,FDAERR
N SUBWP,WPERR
; -- fill in FDA with the survey data
;
S SUBS="+1,"_SUBS
;I MODFLG<2 S SUBS="+1,"_SUBS
;E S SUBS=$O(^VPS(853.8,VPSDFN,1,TID,1,TRNDT,1,1,3,SEQ,3," "),-1)_","_SUBS
K FDA S FLD=0
F S FLD=$O(MSURVEY(SEQ,SQN,FLD)) QUIT:'FLD!($D(FDAERR)) D
. I '$D(WPFLD(FIL,FLD)) D
.. I FLD=.03,(MSURVEY(SEQ,SQN,FLD)=3!(MSURVEY(SEQ,SQN,FLD)["O")),$G(MSURVEY(SEQ,SQN,.04))="" S FDAERR("DIERR",1,"TEXT",1)="RESPONDENT NAME is required when RESPONDENT is other" Q
.. I '$D(WPFLD(FIL,FLD)) S FDA(FIL,SUBS,FLD)=MSURVEY(SEQ,SQN,FLD)
. I $D(WPFLD(FIL,FLD)) D
.. N I
.. S I=0
.. K ^TMP("CSQ ARRAY",$J)
.. F S I=$O(MSURVEY(SEQ,SQN,FLD,I)) Q:'I S ^TMP("CSQ ARRAY",$J,I,0)=MSURVEY(SEQ,SQN,FLD,I)
. Q:$D(FDAERR)
G:$D(FDAERR) AAEX
N IEN
D UPDATE^DIE("E","FDA","IEN","FDAERR")
I '$D(FDAERR) D
. I $G(IEN(1))="" S IEN(1)=1
. I MODFLG<2 S SUBWP=IEN(1)_","_SEQ_",1,"_TRNDT_","_TID_","_VPSDFN_","
. E S SUBWP=$O(^VPS(853.8,VPSDFN,1,TID,1,TRNDT,1,1,3,SEQ,3," "),-1)_","_SEQ_",1,"_TRNDT_","_TID_","_VPSDFN_","
. K WPERR
. D WP^DIE(FIL,SUBWP,6,"","^TMP(""CSQ ARRAY"",$J)","WPERR")
;
I '$D(FDAERR),$D(WPERR) G QWPER
;
AAEX ;
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVPSSRVY4 5190 printed Nov 22, 2024@17:53:34 Page 2
VPSSRVY4 ;WOIFO/KC - VPS CLINICAL SURVEY QUESTIONNAIRE;11/06/2015 11:23
+1 ;;1.0;VA POINT OF SERVICE (KIOSKS);**14**;Nov 6, 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 ;
ADDSRVY(VPSDFN,TID,TRNDT) ;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 ;
+10 ; -- store the survey data
+11 DO UPDATE^DIE("","FDA","IENS","FDAERR")
+12 QUIT $$ERROR(.FDAERR)
+13 ;
ADDRES(VPSDFN,TID,TRNDT,MSURVEY,MODFLG) ;add questionnaire response
+1 NEW FIL
SET FIL=853.811
+2 NEW SUBS
+3 IF MODFLG=0
SET SUBS="+1,"_TRNDT_","_TID_","_VPSDFN_","
+4 IF '$TEST
SET SUBS="1,"_TRNDT_","_TID_","_VPSDFN_","
+5 NEW FDA,FDAERR
+6 NEW SEQ,FLD
SET SEQ=0
+7 ;
+8 FOR
SET SEQ=$ORDER(MSURVEY(SEQ))
if 'SEQ
QUIT
IF ",1,9,10,11,"'[(","_SEQ_",")
Begin DoDot:1
+9 SET FDA(FIL,SUBS,SEQ)=MSURVEY(SEQ)
End DoDot:1
if $DATA(FDAERR)
QUIT
+10 IF $DATA(FDA)
DO UPDATE^DIE("E","FDA",,"FDAERR")
+11 ;
+12 QUIT $$ERROR(.FDAERR)
+13 ;
ADDAPPT(VPSDFN,TID,TRNDT,MSURVEY,MODFLG) ;add survey (questionnaire level)
+1 NEW FIL
SET FIL=853.8111
+2 NEW SUBS
+3 IF MODFLG=0
SET SUBS="+1,1,"_TRNDT_","_TID_","_VPSDFN_","
+4 IF '$TEST
SET SUBS="1,1,"_TRNDT_","_TID_","_VPSDFN_","
+5 NEW FDA,FDAERR
+6 NEW FLD
SET FLD=0
+7 NEW SEQ
SET SEQ=0
+8 ;
+9 ; -- fill in FDA with the survey data
+10 FOR
SET SEQ=$ORDER(MSURVEY(SEQ))
if 'SEQ
QUIT
Begin DoDot:1
+11 KILL FDA
SET FLD=0
+12 FOR
SET FLD=$ORDER(MSURVEY(SEQ,FLD))
if 'FLD
QUIT
SET FDA(FIL,SUBS,FLD)=MSURVEY(SEQ,FLD)
+13 DO UPDATE^DIE("E","FDA",,"FDAERR")
End DoDot:1
if $DATA(FDAERR)
QUIT
+14 ; ;
+15 ; -- store the survey data
+16 QUIT $$ERROR(.FDAERR)
+17 ;
ADDCALC(VPSDFN,TID,TRNDT,MSURVEY,MODFLG) ;add additional calcualted information
+1 NEW FIL
SET FIL=853.8112
+2 NEW SUBS
+3 IF MODFLG=0
SET SUBS="+1,1,"_TRNDT_","_TID_","_VPSDFN_","
+4 IF '$TEST
SET SUBS="1,1,"_TRNDT_","_TID_","_VPSDFN_","
+5 NEW FDA,FDAERR
+6 NEW FLD
SET FLD=0
+7 NEW SEQ
SET SEQ=0
+8 ;
+9 ; -- fill in FDA with the survey data
+10 FOR
SET SEQ=$ORDER(MSURVEY(SEQ))
if 'SEQ
QUIT
Begin DoDot:1
+11 KILL FDA
SET FLD=0
+12 FOR
SET FLD=$ORDER(MSURVEY(SEQ,FLD))
if 'FLD
QUIT
SET FDA(FIL,SUBS,FLD)=MSURVEY(SEQ,FLD)
+13 DO UPDATE^DIE("E","FDA",,"FDAERR")
End DoDot:1
if $DATA(FDAERR)
QUIT
+14 ; ;
+15 ; -- store the survey data
+16 QUIT $$ERROR(.FDAERR)
+17 ;
ADDQUEST(VPSDFN,TID,TRNDT,MSURVEY,ANSSUR,WPFLD,MODFLG) ;add question
+1 NEW FIL
SET FIL=853.8113
+2 NEW SUBS,SUBWP
+3 NEW ER
+4 ;N FDA,FDAERR
+5 NEW WPERR,I
+6 ; -- fill in FDA with the survey data
+7 SET SEQ=0
+8 FOR
SET SEQ=$ORDER(MSURVEY(SEQ))
if 'SEQ
QUIT
Begin DoDot:1
+9 IF MODFLG=0
SET SUBS="+1,1,"_TRNDT_","_TID_","_VPSDFN_","
+10 IF '$TEST
SET SUBS=SEQ_",1,"_TRNDT_","_TID_","_VPSDFN_","
+11 KILL FDA
SET FLD=0
+12 FOR
SET FLD=$ORDER(MSURVEY(SEQ,FLD))
if 'FLD
QUIT
Begin DoDot:2
+13 IF '$DATA(WPFLD(FIL,FLD))
SET FDA(FIL,SUBS,FLD)=MSURVEY(SEQ,FLD)
+14 IF $DATA(WPFLD(FIL,FLD))
Begin DoDot:3
+15 NEW I
+16 SET I=0
+17 KILL ^TMP("CSQ ARRAY",$JOB)
+18 FOR
SET I=$ORDER(MSURVEY(SEQ,FLD,I))
if 'I
QUIT
SET ^TMP("CSQ ARRAY",$JOB,I,0)=MSURVEY(SEQ,FLD,I)
End DoDot:3
End DoDot:2
+19 DO UPDATE^DIE("E","FDA",,"FDAERR")
+20 SET SUBWP=SEQ_",1,"_TRNDT_","_TID_","_VPSDFN_","
+21 KILL WPERR
+22 DO WP^DIE(FIL,SUBWP,2,"","^TMP(""CSQ ARRAY"",$J)","WPERR")
+23 IF $DATA(ANSSUR(SEQ))
Begin DoDot:2
+24 ;K ^VPS(853.8,VPSDFN,1,TID,1,TRNDT,1,1,3,SEQ,3)
IF MODFLG=2
Begin DoDot:3
+25 NEW DIK,DA
+26 SET DIK="^VPS(853.8,VPSDFN,1,TID,1,TRNDT,1,1,3,SEQ,3,"
+27 SET DA(1)=SEQ
SET DA(2)=1
SET DA(3)=TRNDT
SET DA(4)=TID
SET DA(5)=VPSDFN
+28 SET DA=" "
+29 FOR
SET DA=$ORDER(^VPS(853.8,VPSDFN,1,TID,1,TRNDT,1,1,3,SEQ,3,DA),-1)
if 'DA
QUIT
DO ^DIK
End DoDot:3
+30 NEW SQN
+31 SET SQN=""
+32 FOR
SET SQN=$ORDER(ANSSUR(SEQ,SQN))
if SQN=""!($GET(ER)]"")
QUIT
SET ER=$$ADDANS(VPSDFN,TID,TRNDT,.ANSSUR,.WPFLD,SEQ,SQN,SUBWP,MODFLG)
End DoDot:2
End DoDot:1
if ($DATA(FDAERR)!$DATA(WPERR)!($GET(ER)))
QUIT
+33 IF '$DATA(FDAERR)
IF $DATA(WPERR)
GOTO QWPER
+34 ;
+35 if $GET(ER)]""
QUIT ER
+36 QUIT $$ERROR(.FDAERR)
+37 ;
QWPER ;
+1 QUIT $$ERROR(.WPERR)
+2 ;
ADDANS(VPSDFN,TID,TRNDT,MSURVEY,WPFLD,SEQ,SQN,SUBS,MODFLG) ;add ANSWER
+1 NEW FIL
SET FIL=853.81133
+2 NEW FDA,FDAERR
+3 NEW SUBWP,WPERR
+4 ; -- fill in FDA with the survey data
+5 ;
+6 SET SUBS="+1,"_SUBS
+7 ;I MODFLG<2 S SUBS="+1,"_SUBS
+8 ;E S SUBS=$O(^VPS(853.8,VPSDFN,1,TID,1,TRNDT,1,1,3,SEQ,3," "),-1)_","_SUBS
+9 KILL FDA
SET FLD=0
+10 FOR
SET FLD=$ORDER(MSURVEY(SEQ,SQN,FLD))
if 'FLD!($DATA(FDAERR))
QUIT
Begin DoDot:1
+11 IF '$DATA(WPFLD(FIL,FLD))
Begin DoDot:2
+12 IF FLD=.03
IF (MSURVEY(SEQ,SQN,FLD)=3!(MSURVEY(SEQ,SQN,FLD)["O"))
IF $GET(MSURVEY(SEQ,SQN,.04))=""
SET FDAERR("DIERR",1,"TEXT",1)="RESPONDENT NAME is required when RESPONDENT is other"
QUIT
+13 IF '$DATA(WPFLD(FIL,FLD))
SET FDA(FIL,SUBS,FLD)=MSURVEY(SEQ,SQN,FLD)
End DoDot:2
+14 IF $DATA(WPFLD(FIL,FLD))
Begin DoDot:2
+15 NEW I
+16 SET I=0
+17 KILL ^TMP("CSQ ARRAY",$JOB)
+18 FOR
SET I=$ORDER(MSURVEY(SEQ,SQN,FLD,I))
if 'I
QUIT
SET ^TMP("CSQ ARRAY",$JOB,I,0)=MSURVEY(SEQ,SQN,FLD,I)
End DoDot:2
+19 if $DATA(FDAERR)
QUIT
End DoDot:1
+20 if $DATA(FDAERR)
GOTO AAEX
+21 NEW IEN
+22 DO UPDATE^DIE("E","FDA","IEN","FDAERR")
+23 IF '$DATA(FDAERR)
Begin DoDot:1
+24 IF $GET(IEN(1))=""
SET IEN(1)=1
+25 IF MODFLG<2
SET SUBWP=IEN(1)_","_SEQ_",1,"_TRNDT_","_TID_","_VPSDFN_","
+26 IF '$TEST
SET SUBWP=$ORDER(^VPS(853.8,VPSDFN,1,TID,1,TRNDT,1,1,3,SEQ,3," "),-1)_","_SEQ_",1,"_TRNDT_","_TID_","_VPSDFN_","
+27 KILL WPERR
+28 DO WP^DIE(FIL,SUBWP,6,"","^TMP(""CSQ ARRAY"",$J)","WPERR")
End DoDot:1
+29 ;
+30 IF '$DATA(FDAERR)
IF $DATA(WPERR)
GOTO QWPER
+31 ;
AAEX ;
+1 QUIT $$ERROR(.FDAERR)
+2 ;
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
