VPSSRVY2 ;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#
; ------------------------
;
QUIT
GETRPC(VPSRES,VPSPID,VPSTYP,VPSQIEN,VPSQNM,VPSFDT,VPSTDT,VPSNUM,AHFLG) ;
;INPUT
; VPSPID : Parameter Value - patient SSN OR DFN OR ICN OR VIC/CAC (REQUIRED)
; VPSTYP - Parameter TYPE - SSN or DFN OR ICN OR VIC/CAC (REQUIRED)
; VPSQIEN : Questionnaire IEN
; VPSQNM : Questionnaire Name
; VPSFDT : From Date
; VPSTDT : To Date
; VPSNUM : Number of Occurrences
; AHFLG : Answer history Flag
; current answer - 0 (default)
; all answers to question - 1 1
;
;OUTPUT
; If error
; VPSRES(0)=-1^Error Message
;
; otherwise
; VPSRES(0)=1^Number of Questionnaires
; VPSRES(1) = <CSQ>
; VPSRES(2) = PATIENT ^ QUESTIONNAIRE TEMPLATE ID ^ QUESTIONNAIRE TEMPLATE NAME ^ QUESTIONNAIRE TEMPLATE IEN ^ VERSION
; VPSRES(3) = <RESPONSE>
; VPSRES(4) = RESPONSE IDENTIFIER ^ DATE/TIME TAKEN ^ DATE/TIME LAST MODIFIED ^ COMPLETION STATUS ^ PATIENT SAFETY ^ IMMEDIATE ACTION ^ SURVEY CALCULATED VALUE
; VPSRES(5) = <APPOINTMENT CHECK-IN>
; VPSRES(6) = APPOINTMENT CHECK-IN ID
; VPSRES(7) = </APPOINTMENT CHECK-IN>
; VPSRES(8) = <ADDITIONAL CALCULATED VALUE>
; VPSRES(9) = ADDITIONAL CALC VALUE NAME ^ ADDITIONAL CALC VALUE SCORE
; VPSRES(10) = </ADDITIONAL CALCULATED VALUE>
; VPSRES(11) = <QUESTIONS>
; VPSRES(12) = QUESTION NUMBER ^ QUESTION CALCULATED VALUE
; VPSRES(13) = <QUESTION PRESENTED>
; VPSRES(14) = QUESTION TEXT....
; VPSRES(15) = </QUESTION PRESENTED>
; VPSRES(16) = <ANSWER>
; VPSRES(17) = ANSWER IDENTIFIER ^ INTERFACE USED ^ RESPONDENT ^ RESPONDENT NAME ^ ANSWER DATE/TIME ^ INTERVIEWER NAME ^ KIOSK IDENTIFIER ^ KIOSK SESSION IDENTIFIER ^ KIOSK GROUP IDENTIFIER
; VPSRES(18) = <ANSWER RESPONSE>
; VPSRES(19) = ANSWER TEXT
; VPSRES(20) = </ANSWER RESPONSE>
; VPSRES(21) = </ANSWER>
; VPSRES(22) = </QUESTIONS>
; VPSRES(23) = </RESPONSE>
; VPSRES(24) = </CSQ>
; VPSRES(25) = <CSQ>
; ...
; VPSRES(n) = </CSQ>
;
;
K ^TMP("VPSGSRY",$J)
S VPSRES=$NA(^TMP("VPSGSRY",$J))
N VPSDFN
I $G(VPSTYP)="" S VPSTYP="DFN"
I $G(VPSQNM)]"" S VPSQNM=$$UPCASE(VPSQNM)
S VPSDFN=$$VALIDATE^VPSRPC1($G(VPSTYP),$G(VPSPID))
I +VPSDFN=-1 D ADDERR(VPSDFN) Q
I $G(VPSDFN)="" D ADDERR("-1^Patient IEN not sent") Q
I '$D(^DPT(VPSDFN)) D ADDERR("-1^Patient not found") Q
I '$D(^VPS(853.8,VPSDFN)) D ADDERR("-1^No questionnaires found") Q
;
N FDT,CNT,FLG,DAT,DATA,X,Y,TID,TMP
S FDT=0,TID=0
S CNT=0,FLG=0
I $G(VPSFDT)["T" S X=VPSFDT D ^%DT S VPSFDT=Y I Y=-1 D ADDERR("-1^Issue with From Date") Q
I $G(VPSTDT)["T" S X=VPSTDT D ^%DT S VPSTDT=Y I Y=-1 D ADDERR("-1^Issue with To Date") Q
I $G(VPSFDT) S FDT=$P(VPSFDT,".")-.000001
I $G(VPSTDT) S VPSTDT=$P(VPSTDT,".")_".999999"
N VFDT
S VFDT=FDT
F S TID=$O(^VPS(853.8,VPSDFN,1,TID)) Q:'TID D
. S FDT=VFDT
. F S FDT=$O(^VPS(853.8,VPSDFN,1,TID,1,FDT)) Q:'FDT D
.. I $G(VPSTDT),FDT>VPSTDT Q
.. I $$PASSCHK(TID,$G(VPSQIEN),$G(VPSQNM)) S TMP(FDT,TID)=""
S FDT=""
N LN
S LN=0
F S FDT=$O(TMP(FDT)) Q:'FDT!(FLG) D
. S TID=""
. F S TID=$O(TMP(FDT,TID)) Q:'TID!(FLG) D
.. S LN=LN+1
.. D STORE(LN,"<CSQ>")
.. D GETDATA(.LN,TID,FDT)
.. S CNT=CNT+1
.. I $G(VPSNUM),CNT=VPSNUM S FLG=1 Q
. S LN=LN+1
. D STORE(LN,"</CSQ>")
D STORE(0,"1^"_CNT)
;
Q
;
;
PASSCHK(ID1,VPSQIEN,VPSQNM) ;
; test is see if this is the survey being requested
I $G(VPSQIEN)="",$G(VPSQNM)="" Q 1
N ID,FLG
S FLG=1
I $G(VPSQIEN)]"" D Q 'FLG
. S ID=$O(^VPS(853.85,"B",VPSQIEN,""))
. I ID1=ID S FLG=0
I $G(VPSQNM)]"" D Q 'FLG
. I $$GET1^DIQ(853.85,ID1_",",1)=VPSQNM S FLG=0
Q 0
;
;
ADDERR(MSG) ;add error message to result array
S ^TMP("VPSGSRY",$J,0)=MSG
Q
;
GETDATA(LN,TID,FDT) ;
N I,DAT,DATA
S DATA=$G(^VPS(853.8,VPSDFN,1,TID,1,FDT,1,1,0))
; Patient DFN ^ Patient Name ^ Template ID ^ Questionnaire Name ^ Version
S DAT=VPSDFN_U_$$GET1^DIQ(2,VPSDFN_",",.01)_U_$E($$GET1^DIQ(853.85,TID_",",.01),5,99)_U_$$GET1^DIQ(853.85,TID_",",1)_U_$$GET1^DIQ(853.85,TID_",",2)
S LN=LN+1
D STORE(LN,DAT)
S LN=LN+1
D STORE(LN,"<RESPONSE>")
; Obtain Response identifier
S DAT=$$GET1^DIQ(853.811,"1,"_FDT_","_TID_","_VPSDFN_",",.01)
; Obtain converted Date and Time Taken
S DAT=DAT_U_$$GET1^DIQ(853.811,"1,"_FDT_","_TID_","_VPSDFN_",",.02)
; Obtain Date and Time Last Modified and convert to external format
S DAT=DAT_U_$$GET1^DIQ(853.811,"1,"_FDT_","_TID_","_VPSDFN_",",.03)
; Obtain COMPLETION STATUS
S DAT=DAT_U_$$GET1^DIQ(853.811,"1,"_FDT_","_TID_","_VPSDFN_",",.04)
; Obtain PATIENT SAFETY
S DAT=DAT_U_$$GET1^DIQ(853.811,"1,"_FDT_","_TID_","_VPSDFN_",",.05)
; Obtain IMMEDIATE ACTION
S DAT=DAT_U_$$GET1^DIQ(853.811,"1,"_FDT_","_TID_","_VPSDFN_",",.06)
; Obtain SURVEY CALCULATED VALUE
S DAT=DAT_U_$$GET1^DIQ(853.811,"1,"_FDT_","_TID_","_VPSDFN_",",4)
S LN=LN+1
D STORE(LN,DAT)
S LN=LN+1
D STORE(LN,"<APPOINTMENT CHECK-IN>")
S I=0
F S I=$O(^VPS(853.8,VPSDFN,1,TID,1,FDT,1,1,1,I)) Q:'I D
. S DAT=^VPS(853.8,VPSDFN,1,TID,1,FDT,1,1,1,I,0)
. S LN=LN+1
. D STORE(LN,DAT)
S LN=LN+1
D STORE(LN,"</APPOINTMENT CHECK-IN>")
S LN=LN+1
D STORE(LN,"<ADDITIONAL CALCULATED VALUE>")
S I=0
F S I=$O(^VPS(853.8,VPSDFN,1,TID,1,FDT,1,1,2,I)) Q:'I D
. S DAT=^VPS(853.8,VPSDFN,1,TID,1,FDT,1,1,2,I,0)
. S LN=LN+1
. D STORE(LN,DAT)
S LN=LN+1
D STORE(LN,"</APPOINTMENT CHECK-IN>")
S LN=LN+1
D STORE(LN,"<QUESTIONS>")
N J,II
S I=0
F S I=$O(^VPS(853.8,VPSDFN,1,TID,1,FDT,1,1,3,I)) Q:'I D
. S DAT=$$GET1^DIQ(853.8113,I_",1,"_FDT_","_TID_","_VPSDFN_",",.01)
. S DAT=DAT_U_$$GET1^DIQ(853.8113,I_",1,"_FDT_","_TID_","_VPSDFN_",",1)
. S LN=LN+1
. D STORE(LN,DAT)
. S LN=LN+1
. D STORE(LN,"<QUESTION PRESENTED>")
. N TMP
. I $$GET1^DIQ(853.8113,I_",1,"_FDT_","_TID_","_VPSDFN_",",2,"","TMP")
. S J=0
. F S J=$O(TMP(J)) Q:'J S LN=LN+1 D STORE(LN,TMP(J))
. S LN=LN+1
. D STORE(LN,"</QUESTION PRESENTED>")
. ;S LN=LN+1
. ;D STORE(LN,"<ANSWER>")
. S II="A"
. N CUR
. S CUR=0
. F S II=$O(^VPS(853.8,VPSDFN,1,TID,1,FDT,1,1,3,I,3,II),-1) Q:'II!(CUR=99&(+$G(AHFLG)=0)) D
.. ; Obtain ANSWER IDENTIFIER
.. I CUR'=0,CUR'=$$GET1^DIQ(853.81133,II_","_I_",1,"_FDT_","_TID_","_VPSDFN_",",1),+$G(AHFLG)=0 S CUR=99 Q
.. S LN=LN+1
.. D STORE(LN,"<ANSWER>")
.. I CUR=0 S CUR=$$GET1^DIQ(853.81133,II_","_I_",1,"_FDT_","_TID_","_VPSDFN_",",1)
.. S DAT=$$GET1^DIQ(853.81133,II_","_I_",1,"_FDT_","_TID_","_VPSDFN_",",.01)
.. S DAT=DAT_U_$$GET1^DIQ(853.81133,II_","_I_",1,"_FDT_","_TID_","_VPSDFN_",",.02)
.. S DAT=DAT_U_$$GET1^DIQ(853.81133,II_","_I_",1,"_FDT_","_TID_","_VPSDFN_",",.03)
.. S DAT=DAT_U_$$GET1^DIQ(853.81133,II_","_I_",1,"_FDT_","_TID_","_VPSDFN_",",.04)
.. S DAT=DAT_U_$$GET1^DIQ(853.81133,II_","_I_",1,"_FDT_","_TID_","_VPSDFN_",",1)
.. S DAT=DAT_U_$$GET1^DIQ(853.81133,II_","_I_",1,"_FDT_","_TID_","_VPSDFN_",",2)
.. S DAT=DAT_U_$$GET1^DIQ(853.81133,II_","_I_",1,"_FDT_","_TID_","_VPSDFN_",",3)
.. S DAT=DAT_U_$$GET1^DIQ(853.81133,II_","_I_",1,"_FDT_","_TID_","_VPSDFN_",",4)
.. S DAT=DAT_U_$$GET1^DIQ(853.81133,II_","_I_",1,"_FDT_","_TID_","_VPSDFN_",",5)
.. S LN=LN+1
.. D STORE(LN,DAT)
.. S DAT=""
.. S LN=LN+1
.. D STORE(LN,"<ANSWER RESPONSE>")
.. K TMP
.. I $$GET1^DIQ(853.81133,II_","_I_",1,"_FDT_","_TID_","_VPSDFN_",",6,"","TMP")
.. S J=0
.. F S J=$O(TMP(J)) Q:'J S LN=LN+1 D STORE(LN,TMP(J))
.. S LN=LN+1
.. D STORE(LN,"</ANSWER RESPONSE>")
.. S LN=LN+1
.. D STORE(LN,"</ANSWER>")
. ;S LN=LN+1
. ;D STORE(LN,"</ANSWER>")
S LN=LN+1
D STORE(LN,"</QUESTIONS>")
S LN=LN+1
D STORE(LN,"</RESPONSE>")
Q
;
APPEND(LINE,ARR) ;
N J,STR
S J=0
F S J=$O(ARR(J)) Q:'J S STR=STR_ARR(J)
I LINE="" S LINE=STR
E S LINE=LINE_U_STR
Q
;
STORE(IEN,MSG) ;add message to result array
S ^TMP("VPSGSRY",$J,IEN)=MSG
Q
;
; Convert string to upper case
UPCASE(X) ;
N STR,I
S STR=""
F I=1:1:$L(X) S STR=STR_$$CAP($E(X,I))
Q STR
;
CAP(X) ; Convert lower case X to UPPER CASE
Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVPSSRVY2 8647 printed Nov 22, 2024@17:53:32 Page 2
VPSSRVY2 ;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 ;
+7 QUIT
GETRPC(VPSRES,VPSPID,VPSTYP,VPSQIEN,VPSQNM,VPSFDT,VPSTDT,VPSNUM,AHFLG) ;
+1 ;INPUT
+2 ; VPSPID : Parameter Value - patient SSN OR DFN OR ICN OR VIC/CAC (REQUIRED)
+3 ; VPSTYP - Parameter TYPE - SSN or DFN OR ICN OR VIC/CAC (REQUIRED)
+4 ; VPSQIEN : Questionnaire IEN
+5 ; VPSQNM : Questionnaire Name
+6 ; VPSFDT : From Date
+7 ; VPSTDT : To Date
+8 ; VPSNUM : Number of Occurrences
+9 ; AHFLG : Answer history Flag
+10 ; current answer - 0 (default)
+11 ; all answers to question - 1 1
+12 ;
+13 ;OUTPUT
+14 ; If error
+15 ; VPSRES(0)=-1^Error Message
+16 ;
+17 ; otherwise
+18 ; VPSRES(0)=1^Number of Questionnaires
+19 ; VPSRES(1) = <CSQ>
+20 ; VPSRES(2) = PATIENT ^ QUESTIONNAIRE TEMPLATE ID ^ QUESTIONNAIRE TEMPLATE NAME ^ QUESTIONNAIRE TEMPLATE IEN ^ VERSION
+21 ; VPSRES(3) = <RESPONSE>
+22 ; VPSRES(4) = RESPONSE IDENTIFIER ^ DATE/TIME TAKEN ^ DATE/TIME LAST MODIFIED ^ COMPLETION STATUS ^ PATIENT SAFETY ^ IMMEDIATE ACTION ^ SURVEY CALCULATED VALUE
+23 ; VPSRES(5) = <APPOINTMENT CHECK-IN>
+24 ; VPSRES(6) = APPOINTMENT CHECK-IN ID
+25 ; VPSRES(7) = </APPOINTMENT CHECK-IN>
+26 ; VPSRES(8) = <ADDITIONAL CALCULATED VALUE>
+27 ; VPSRES(9) = ADDITIONAL CALC VALUE NAME ^ ADDITIONAL CALC VALUE SCORE
+28 ; VPSRES(10) = </ADDITIONAL CALCULATED VALUE>
+29 ; VPSRES(11) = <QUESTIONS>
+30 ; VPSRES(12) = QUESTION NUMBER ^ QUESTION CALCULATED VALUE
+31 ; VPSRES(13) = <QUESTION PRESENTED>
+32 ; VPSRES(14) = QUESTION TEXT....
+33 ; VPSRES(15) = </QUESTION PRESENTED>
+34 ; VPSRES(16) = <ANSWER>
+35 ; VPSRES(17) = ANSWER IDENTIFIER ^ INTERFACE USED ^ RESPONDENT ^ RESPONDENT NAME ^ ANSWER DATE/TIME ^ INTERVIEWER NAME ^ KIOSK IDENTIFIER ^ KIOSK SESSION IDENTIFIER ^ KIOSK GROUP IDENTIFIER
+36 ; VPSRES(18) = <ANSWER RESPONSE>
+37 ; VPSRES(19) = ANSWER TEXT
+38 ; VPSRES(20) = </ANSWER RESPONSE>
+39 ; VPSRES(21) = </ANSWER>
+40 ; VPSRES(22) = </QUESTIONS>
+41 ; VPSRES(23) = </RESPONSE>
+42 ; VPSRES(24) = </CSQ>
+43 ; VPSRES(25) = <CSQ>
+44 ; ...
+45 ; VPSRES(n) = </CSQ>
+46 ;
+47 ;
+48 KILL ^TMP("VPSGSRY",$JOB)
+49 SET VPSRES=$NAME(^TMP("VPSGSRY",$JOB))
+50 NEW VPSDFN
+51 IF $GET(VPSTYP)=""
SET VPSTYP="DFN"
+52 IF $GET(VPSQNM)]""
SET VPSQNM=$$UPCASE(VPSQNM)
+53 SET VPSDFN=$$VALIDATE^VPSRPC1($GET(VPSTYP),$GET(VPSPID))
+54 IF +VPSDFN=-1
DO ADDERR(VPSDFN)
QUIT
+55 IF $GET(VPSDFN)=""
DO ADDERR("-1^Patient IEN not sent")
QUIT
+56 IF '$DATA(^DPT(VPSDFN))
DO ADDERR("-1^Patient not found")
QUIT
+57 IF '$DATA(^VPS(853.8,VPSDFN))
DO ADDERR("-1^No questionnaires found")
QUIT
+58 ;
+59 NEW FDT,CNT,FLG,DAT,DATA,X,Y,TID,TMP
+60 SET FDT=0
SET TID=0
+61 SET CNT=0
SET FLG=0
+62 IF $GET(VPSFDT)["T"
SET X=VPSFDT
DO ^%DT
SET VPSFDT=Y
IF Y=-1
DO ADDERR("-1^Issue with From Date")
QUIT
+63 IF $GET(VPSTDT)["T"
SET X=VPSTDT
DO ^%DT
SET VPSTDT=Y
IF Y=-1
DO ADDERR("-1^Issue with To Date")
QUIT
+64 IF $GET(VPSFDT)
SET FDT=$PIECE(VPSFDT,".")-.000001
+65 IF $GET(VPSTDT)
SET VPSTDT=$PIECE(VPSTDT,".")_".999999"
+66 NEW VFDT
+67 SET VFDT=FDT
+68 FOR
SET TID=$ORDER(^VPS(853.8,VPSDFN,1,TID))
if 'TID
QUIT
Begin DoDot:1
+69 SET FDT=VFDT
+70 FOR
SET FDT=$ORDER(^VPS(853.8,VPSDFN,1,TID,1,FDT))
if 'FDT
QUIT
Begin DoDot:2
+71 IF $GET(VPSTDT)
IF FDT>VPSTDT
QUIT
+72 IF $$PASSCHK(TID,$GET(VPSQIEN),$GET(VPSQNM))
SET TMP(FDT,TID)=""
End DoDot:2
End DoDot:1
+73 SET FDT=""
+74 NEW LN
+75 SET LN=0
+76 FOR
SET FDT=$ORDER(TMP(FDT))
if 'FDT!(FLG)
QUIT
Begin DoDot:1
+77 SET TID=""
+78 FOR
SET TID=$ORDER(TMP(FDT,TID))
if 'TID!(FLG)
QUIT
Begin DoDot:2
+79 SET LN=LN+1
+80 DO STORE(LN,"<CSQ>")
+81 DO GETDATA(.LN,TID,FDT)
+82 SET CNT=CNT+1
+83 IF $GET(VPSNUM)
IF CNT=VPSNUM
SET FLG=1
QUIT
End DoDot:2
+84 SET LN=LN+1
+85 DO STORE(LN,"</CSQ>")
End DoDot:1
+86 DO STORE(0,"1^"_CNT)
+87 ;
+88 QUIT
+89 ;
+90 ;
PASSCHK(ID1,VPSQIEN,VPSQNM) ;
+1 ; test is see if this is the survey being requested
+2 IF $GET(VPSQIEN)=""
IF $GET(VPSQNM)=""
QUIT 1
+3 NEW ID,FLG
+4 SET FLG=1
+5 IF $GET(VPSQIEN)]""
Begin DoDot:1
+6 SET ID=$ORDER(^VPS(853.85,"B",VPSQIEN,""))
+7 IF ID1=ID
SET FLG=0
End DoDot:1
QUIT 'FLG
+8 IF $GET(VPSQNM)]""
Begin DoDot:1
+9 IF $$GET1^DIQ(853.85,ID1_",",1)=VPSQNM
SET FLG=0
End DoDot:1
QUIT 'FLG
+10 QUIT 0
+11 ;
+12 ;
ADDERR(MSG) ;add error message to result array
+1 SET ^TMP("VPSGSRY",$JOB,0)=MSG
+2 QUIT
+3 ;
GETDATA(LN,TID,FDT) ;
+1 NEW I,DAT,DATA
+2 SET DATA=$GET(^VPS(853.8,VPSDFN,1,TID,1,FDT,1,1,0))
+3 ; Patient DFN ^ Patient Name ^ Template ID ^ Questionnaire Name ^ Version
+4 SET DAT=VPSDFN_U_$$GET1^DIQ(2,VPSDFN_",",.01)_U_$EXTRACT($$GET1^DIQ(853.85,TID_",",.01),5,99)_U_$$GET1^DIQ(853.85,TID_",",1)_U_$$GET1^DIQ(853.85,TID_",",2)
+5 SET LN=LN+1
+6 DO STORE(LN,DAT)
+7 SET LN=LN+1
+8 DO STORE(LN,"<RESPONSE>")
+9 ; Obtain Response identifier
+10 SET DAT=$$GET1^DIQ(853.811,"1,"_FDT_","_TID_","_VPSDFN_",",.01)
+11 ; Obtain converted Date and Time Taken
+12 SET DAT=DAT_U_$$GET1^DIQ(853.811,"1,"_FDT_","_TID_","_VPSDFN_",",.02)
+13 ; Obtain Date and Time Last Modified and convert to external format
+14 SET DAT=DAT_U_$$GET1^DIQ(853.811,"1,"_FDT_","_TID_","_VPSDFN_",",.03)
+15 ; Obtain COMPLETION STATUS
+16 SET DAT=DAT_U_$$GET1^DIQ(853.811,"1,"_FDT_","_TID_","_VPSDFN_",",.04)
+17 ; Obtain PATIENT SAFETY
+18 SET DAT=DAT_U_$$GET1^DIQ(853.811,"1,"_FDT_","_TID_","_VPSDFN_",",.05)
+19 ; Obtain IMMEDIATE ACTION
+20 SET DAT=DAT_U_$$GET1^DIQ(853.811,"1,"_FDT_","_TID_","_VPSDFN_",",.06)
+21 ; Obtain SURVEY CALCULATED VALUE
+22 SET DAT=DAT_U_$$GET1^DIQ(853.811,"1,"_FDT_","_TID_","_VPSDFN_",",4)
+23 SET LN=LN+1
+24 DO STORE(LN,DAT)
+25 SET LN=LN+1
+26 DO STORE(LN,"<APPOINTMENT CHECK-IN>")
+27 SET I=0
+28 FOR
SET I=$ORDER(^VPS(853.8,VPSDFN,1,TID,1,FDT,1,1,1,I))
if 'I
QUIT
Begin DoDot:1
+29 SET DAT=^VPS(853.8,VPSDFN,1,TID,1,FDT,1,1,1,I,0)
+30 SET LN=LN+1
+31 DO STORE(LN,DAT)
End DoDot:1
+32 SET LN=LN+1
+33 DO STORE(LN,"</APPOINTMENT CHECK-IN>")
+34 SET LN=LN+1
+35 DO STORE(LN,"<ADDITIONAL CALCULATED VALUE>")
+36 SET I=0
+37 FOR
SET I=$ORDER(^VPS(853.8,VPSDFN,1,TID,1,FDT,1,1,2,I))
if 'I
QUIT
Begin DoDot:1
+38 SET DAT=^VPS(853.8,VPSDFN,1,TID,1,FDT,1,1,2,I,0)
+39 SET LN=LN+1
+40 DO STORE(LN,DAT)
End DoDot:1
+41 SET LN=LN+1
+42 DO STORE(LN,"</APPOINTMENT CHECK-IN>")
+43 SET LN=LN+1
+44 DO STORE(LN,"<QUESTIONS>")
+45 NEW J,II
+46 SET I=0
+47 FOR
SET I=$ORDER(^VPS(853.8,VPSDFN,1,TID,1,FDT,1,1,3,I))
if 'I
QUIT
Begin DoDot:1
+48 SET DAT=$$GET1^DIQ(853.8113,I_",1,"_FDT_","_TID_","_VPSDFN_",",.01)
+49 SET DAT=DAT_U_$$GET1^DIQ(853.8113,I_",1,"_FDT_","_TID_","_VPSDFN_",",1)
+50 SET LN=LN+1
+51 DO STORE(LN,DAT)
+52 SET LN=LN+1
+53 DO STORE(LN,"<QUESTION PRESENTED>")
+54 NEW TMP
+55 IF $$GET1^DIQ(853.8113,I_",1,"_FDT_","_TID_","_VPSDFN_",",2,"","TMP")
+56 SET J=0
+57 FOR
SET J=$ORDER(TMP(J))
if 'J
QUIT
SET LN=LN+1
DO STORE(LN,TMP(J))
+58 SET LN=LN+1
+59 DO STORE(LN,"</QUESTION PRESENTED>")
+60 ;S LN=LN+1
+61 ;D STORE(LN,"<ANSWER>")
+62 SET II="A"
+63 NEW CUR
+64 SET CUR=0
+65 FOR
SET II=$ORDER(^VPS(853.8,VPSDFN,1,TID,1,FDT,1,1,3,I,3,II),-1)
if 'II!(CUR=99&(+$GET(AHFLG)=0))
QUIT
Begin DoDot:2
+66 ; Obtain ANSWER IDENTIFIER
+67 IF CUR'=0
IF CUR'=$$GET1^DIQ(853.81133,II_","_I_",1,"_FDT_","_TID_","_VPSDFN_",",1)
IF +$GET(AHFLG)=0
SET CUR=99
QUIT
+68 SET LN=LN+1
+69 DO STORE(LN,"<ANSWER>")
+70 IF CUR=0
SET CUR=$$GET1^DIQ(853.81133,II_","_I_",1,"_FDT_","_TID_","_VPSDFN_",",1)
+71 SET DAT=$$GET1^DIQ(853.81133,II_","_I_",1,"_FDT_","_TID_","_VPSDFN_",",.01)
+72 SET DAT=DAT_U_$$GET1^DIQ(853.81133,II_","_I_",1,"_FDT_","_TID_","_VPSDFN_",",.02)
+73 SET DAT=DAT_U_$$GET1^DIQ(853.81133,II_","_I_",1,"_FDT_","_TID_","_VPSDFN_",",.03)
+74 SET DAT=DAT_U_$$GET1^DIQ(853.81133,II_","_I_",1,"_FDT_","_TID_","_VPSDFN_",",.04)
+75 SET DAT=DAT_U_$$GET1^DIQ(853.81133,II_","_I_",1,"_FDT_","_TID_","_VPSDFN_",",1)
+76 SET DAT=DAT_U_$$GET1^DIQ(853.81133,II_","_I_",1,"_FDT_","_TID_","_VPSDFN_",",2)
+77 SET DAT=DAT_U_$$GET1^DIQ(853.81133,II_","_I_",1,"_FDT_","_TID_","_VPSDFN_",",3)
+78 SET DAT=DAT_U_$$GET1^DIQ(853.81133,II_","_I_",1,"_FDT_","_TID_","_VPSDFN_",",4)
+79 SET DAT=DAT_U_$$GET1^DIQ(853.81133,II_","_I_",1,"_FDT_","_TID_","_VPSDFN_",",5)
+80 SET LN=LN+1
+81 DO STORE(LN,DAT)
+82 SET DAT=""
+83 SET LN=LN+1
+84 DO STORE(LN,"<ANSWER RESPONSE>")
+85 KILL TMP
+86 IF $$GET1^DIQ(853.81133,II_","_I_",1,"_FDT_","_TID_","_VPSDFN_",",6,"","TMP")
+87 SET J=0
+88 FOR
SET J=$ORDER(TMP(J))
if 'J
QUIT
SET LN=LN+1
DO STORE(LN,TMP(J))
+89 SET LN=LN+1
+90 DO STORE(LN,"</ANSWER RESPONSE>")
+91 SET LN=LN+1
+92 DO STORE(LN,"</ANSWER>")
End DoDot:2
+93 ;S LN=LN+1
+94 ;D STORE(LN,"</ANSWER>")
End DoDot:1
+95 SET LN=LN+1
+96 DO STORE(LN,"</QUESTIONS>")
+97 SET LN=LN+1
+98 DO STORE(LN,"</RESPONSE>")
+99 QUIT
+100 ;
APPEND(LINE,ARR) ;
+1 NEW J,STR
+2 SET J=0
+3 FOR
SET J=$ORDER(ARR(J))
if 'J
QUIT
SET STR=STR_ARR(J)
+4 IF LINE=""
SET LINE=STR
+5 IF '$TEST
SET LINE=LINE_U_STR
+6 QUIT
+7 ;
STORE(IEN,MSG) ;add message to result array
+1 SET ^TMP("VPSGSRY",$JOB,IEN)=MSG
+2 QUIT
+3 ;
+4 ; Convert string to upper case
UPCASE(X) ;
+1 NEW STR,I
+2 SET STR=""
+3 FOR I=1:1:$LENGTH(X)
SET STR=STR_$$CAP($EXTRACT(X,I))
+4 QUIT STR
+5 ;
CAP(X) ; Convert lower case X to UPPER CASE
+1 QUIT $TRANSLATE(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
