VPSSRVY3 ;WOIFO/BT - VPS CLINICAL SURVEY QUESTIONNAIRE;01/16/15 13:07
;;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
UTGET(VPSDFN,TARGET,VPSQIEN,VPSQNM,VPSFDT,VPSTDT,VPSNUM) ;
N UTFLG,UT
S UTFLG=1
S UT=$$GETRPT(VPSDFN,TARGET)
;S UT=$$GETRPT(VPSDFN,TARGET,$G(VPSQIEN),$G(VPSQNM),$G(VPSFDT),$G(VPSTDT),$G(VPSNUM))
Q UT
;
GETRPT(VPSDFN,TARGET,VPSQIEN,VPSQNM,VPSFDT,VPSTDT,VPSNUM,AHFLG) ;
;INPUT
; VPSDFN : Patient IEN
; TARGET : Location for the results
; 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
; RESULT(0) = Success or Fail flag
;RESULT(1..n) = Formatted Questionnaire data
;
;Example:
;
;RESULT(0) = 1 (Success) ^ 2 (No of questionnaires found)
;RESULT(1) = Patient Name: TEST, PATIENT
;RESULT(2) = Questionnaire IEN: 20
;RESULT(3) = Questionnaire Name: PTSD Survey
;RESULT(4) = Date and Time Taken: 8/20/14 3:15pm
;RESULT(5) = Date and Time Last Modified: 8/20/14 4:00pm
;RESULT(6) = Questions and Answers:
;RESULT(7) = Are you a smoker? Yes
;RESULT(8) = How many packs per week? 3
;
;
N CNT,NEXTLINE,TDT
S NEXTLINE=0
S CNT=0
;
STARTHS ;
K @TARGET
; valid input parameters
; set up variables for the extraction of clinical survey information
I $G(VPSDFN)="" S @TARGET@(0)="-1^Patient IEN not sent" G EX
I '$D(^DPT(VPSDFN)) S @TARGET@(0)="-1^Patient not found" G EX
I '$D(^VPS(853.8,VPSDFN)) S @TARGET@(0)="-1^There are no questionnaires for this patient" G EX
;
N FDT,FLG,DAT,DATA,X,Y,FLT
S TDT=$$NOW^XLFDT()+.0001
S FLG=0
I $G(VPSTDT) D
. I VPSTDT["." S TDT=VPSTDT+.0001 Q
. I VPSTDT'["." S TDT=VPSTDT+1
S VPSQIEN=$G(VPSQIEN)
S VPSQNM=$G(VPSQNM)
S VPSQNM=$$UPCASE^VPSSRVY2(VPSQNM)
; loop through obtaining the most current information first
S FLG=0,TID=0
F S TID=$O(^VPS(853.8,VPSDFN,1,TID)) Q:'TID!FLG D
. S FDT=TDT
. F S FDT=$O(^VPS(853.8,VPSDFN,1,TID,1,FDT),-1) Q:'FDT!FLG D
.. I $G(VPSFDT),TDT<VPSFDT Q
.. I $G(VPSTDT)="",$G(VPSFDT)]"",$G(VPSFDT)'=$P(FDT,".") Q
.. I $G(VPSNUM),CNT=VPSNUM S FLG=1 Q
.. I $$PASSCHK(TID,$G(VPSQIEN),$G(VPSQNM)) D
... D GETDATA(VPSDFN,TID,FDT,VPSQNM)
... S CNT=CNT+1
I CNT=0 D
. N STR
. S STR="No Survey results for "
. I $G(VPSQIEN)]"" S STR=STR_"CSQ IEN: "_VPSQIEN_", "
. I $G(VPSQNM)]"" S STR=STR_"CSQ NAME: "_VPSQNM_" "
. I $G(VPSFDT)]"" S STR=STR_"since "_VPSFDT
. D ADD(STR)
S @TARGET@(0)="1^"_CNT
;
EX ;
I $G(VPSHSFLG)=1 Q
I $G(UTFLG) Q "~@"_$NA(@TARGET)
D PDO(VPSDFN,.TARGET)
;
Q "~@"_$NA(@TARGET)
;
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
;
;
; obtain the information from the clinical survey
; and format the information into the report
GETDATA(VPSDFN,TID,FDT,VPSQNM) ;
;
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="Patient DFN: "_VPSDFN
;D ADD(DAT)
;S DAT="Patient Name: "_$$GET1^DIQ(2,VPSDFN_",",.01)
;D ADD(DAT)
S DAT="Questionnaire Name: "_$$GET1^DIQ(853.85,TID_",",1)
D ADD(DAT)
S DAT="ID: "_$$GET1^DIQ(853.85,TID_",",.01)
;D ADD(DAT)
S DAT=DAT_$J(" ",66-$L(DAT))_"Ver: "_$$GET1^DIQ(853.85,TID_",",2)
D ADD(DAT)
; Obtain Response identifier
S DAT="Response Identifier: "_$$GET1^DIQ(853.811,"1,"_FDT_","_TID_","_VPSDFN_",",.01)
D ADD(DAT)
; Obtain converted Date and Time Taken
S DAT="Date/Time Taken: "_$$GET1^DIQ(853.811,"1,"_FDT_","_TID_","_VPSDFN_",",.02)
;D ADD(DAT)
; Obtain Date and Time Last Modified and convert to external format
S DAT=DAT_$J(" ",41-$L(DAT))_"Last Modified: "_$$GET1^DIQ(853.811,"1,"_FDT_","_TID_","_VPSDFN_",",.03)
D ADD(DAT)
; Obtain COMPLETION STATUS
S DAT="Completion Status: "_$$GET1^DIQ(853.811,"1,"_FDT_","_TID_","_VPSDFN_",",.04)
D ADD(DAT)
; Obtain PATIENT SAFETY
S DAT="Patient Safety: "_$$GET1^DIQ(853.811,"1,"_FDT_","_TID_","_VPSDFN_",",.05)
S DAT=DAT_$J(" ",41-$L(DAT))_"Immediate Action: "_$$GET1^DIQ(853.811,"1,"_FDT_","_TID_","_VPSDFN_",",.06)
D ADD(DAT)
; Obtain IMMEDIATE ACTION
;S DAT="Immediate Action: "_$$GET1^DIQ(853.811,"1,"_FDT_","_TID_","_VPSDFN_",",.06)
;D ADD(DAT)
; Obtain SURVEY CALCULATED VALUE
S DAT=$$GET1^DIQ(853.811,"1,"_FDT_","_TID_","_VPSDFN_",",4)
I $G(CALC),DAT]"" D ADD("Survey Calculated Value: "_DAT)
S I=0
N DAT1
F S I=$O(^VPS(853.8,VPSDFN,1,TID,1,FDT,1,1,2,I)) Q:'I D
. S DAT=$P(^VPS(853.8,VPSDFN,1,TID,1,FDT,1,1,2,I,0),U)
. I DAT]"" S DAT="Additional Calc Value Name: "_DAT ;D ADD(DAT)
. S DAT1=$P(^VPS(853.8,VPSDFN,1,TID,1,FDT,1,1,2,I,0),U,2)
. I DAT1]"" S DAT1="Additional Calc Value Score: "_DAT1 ;D ADD(DAT)
. I DAT]""!(DAT1]"") S DAT=DAT_$J(" ",41-$L(DAT))_DAT1 D ADD(DAT)
S I=0
F S I=$O(^VPS(853.8,VPSDFN,1,TID,1,FDT,1,1,1,I)) Q:'I D
. S DAT="Appointment Check-in: "_^VPS(853.8,VPSDFN,1,TID,1,FDT,1,1,1,I,0)
. D ADD(DAT)
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
. D ADD("______________________________")
. ;S DAT="Question Number: "_$$GET1^DIQ(853.8113,I_",1,"_FDT_","_TID_","_VPSDFN_",",.01)
. ;D ADD(DAT)
. S DAT=$$GET1^DIQ(853.8113,I_",1,"_FDT_","_TID_","_VPSDFN_",",1)
. I $G(CALC),DAT]"" D ADD("Question Calculated Value: "_DAT)
. N TMP
. I $$GET1^DIQ(853.8113,I_",1,"_FDT_","_TID_","_VPSDFN_",",2,"","TMP")
. I $D(TMP(1)) S TMP(1)=$$GET1^DIQ(853.8113,I_",1,"_FDT_","_TID_","_VPSDFN_",",.01)_" - "_TMP(1)
. S J=0
. F S J=$O(TMP(J)) Q:'J D ADD(TMP(J))
. 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
.. I CUR'=0,CUR'=$$GET1^DIQ(853.81133,II_","_I_",1,"_FDT_","_TID_","_VPSDFN_",",1),+$G(AHFLG)=0 S CUR=99 Q
.. I CUR=0 S CUR=$$GET1^DIQ(853.81133,II_","_I_",1,"_FDT_","_TID_","_VPSDFN_",",1)
.. ;D ADD(" _-_-_-_-_-_-_-_-_-_-_-_-_-_-_-")
.. ; Obtain ANSWER IDENTIFIER
.. ;S DAT="Answer Identifier: "_$$GET1^DIQ(853.81133,II_","_I_",1,"_FDT_","_TID_","_VPSDFN_",",.01)
.. ;D ADD(DAT)
.. ;S DAT="Interface Used: "_$$GET1^DIQ(853.81133,II_","_I_",1,"_FDT_","_TID_","_VPSDFN_",",.02)
.. ;D ADD(DAT)
.. ;S DAT="Kiosk Identifier: "_$$GET1^DIQ(853.81133,II_","_I_",1,"_FDT_","_TID_","_VPSDFN_",",3)
.. ;D ADD(DAT)
.. ;S DAT="Kiosk Session Identifier: "_$$GET1^DIQ(853.81133,II_","_I_",1,"_FDT_","_TID_","_VPSDFN_",",4)
.. ;D ADD(DAT)
.. ;S DAT="Kiosk Group Identifier: "_$$GET1^DIQ(853.81133,II_","_I_",1,"_FDT_","_TID_","_VPSDFN_",",5)
.. ;D ADD(DAT)
.. S DAT=""
.. K TMP
.. I $$GET1^DIQ(853.81133,II_","_I_",1,"_FDT_","_TID_","_VPSDFN_",",6,"","TMP")
.. I $D(TMP(1)) D ADD(" "_$$GET1^DIQ(853.81133,II_","_I_",1,"_FDT_","_TID_","_VPSDFN_",",.01)_" - "_TMP(1))
.. S J=1
.. F S J=$O(TMP(J)) Q:'J D ADD(" "_TMP(J))
.. S DAT=$$GET1^DIQ(853.81133,II_","_I_",1,"_FDT_","_TID_","_VPSDFN_",",.03)
.. I DAT'="PATIENT" D
... S DAT=" Respondent: "_DAT
... ;D ADD(" "_DAT)
... S DAT=DAT_$J(" ",41-$L(DAT))_"Respondent Name: "_$$GET1^DIQ(853.81133,II_","_I_",1,"_FDT_","_TID_","_VPSDFN_",",.04)
... D ADD(DAT)
.. S DAT=" Answer Date/Time: "_$$GET1^DIQ(853.81133,II_","_I_",1,"_FDT_","_TID_","_VPSDFN_",",1)
.. ;D ADD(" "_DAT)
.. S DAT1=$$GET1^DIQ(853.81133,II_","_I_",1,"_FDT_","_TID_","_VPSDFN_",",2)
.. I DAT1]"",+DAT1=0,DAT1'=0 D
... S DAT1="Interviewer Name: "_DAT1
... S DAT=DAT_$J(" ",41-$L(DAT))_DAT1
... D ADD(DAT)
.. D ADD("")
.. S CUR=1
D ADD("@#END OF SURVEY#@")
Q
ADD(TXT) ;
S NEXTLINE=NEXTLINE+1
S @TARGET@(NEXTLINE)=TXT
Q
;
PDO(PTIEN,PDOARY) ;
; create object and store the results of this clinical survey request
N PDOOREF,LINE,ARR
S ARR="^TMP(""VPSSRVY3PDO"",$J)"
S PDOOREF=$$NEW^VPSOBJ(PTIEN,ARR)
I $P(@PDOARY@(0),U)=-1 D ADDPDO^VPSOBJ(PDOOREF,$P(@TARGET@(0),U,2)) G CLOSE
S LINE=0
F S LINE=$O(@PDOARY@(LINE)) Q:'LINE D
. I @PDOARY@(LINE)'="@#END OF SURVEY#@" D ADDPDO^VPSOBJ(PDOOREF,@PDOARY@(LINE)) I 1
. E D ADDBLANK^VPSOBJ(PDOOREF),ADDUNDLN^VPSOBJ(PDOOREF),ADDBLANK^VPSOBJ(PDOOREF)
CLOSE ;
; close the object
D CLOSE^VPSOBJ(PDOOREF)
S PDOARY=ARR
Q
;
HSAHCAL ;
; Entry point for including answer history and calculated values with the health summary
; AHFLG - is the flag for obtaining answer history
N AHFLG
S AHFLG=1
HSCAL ;
; Entry point for including calculated values with the health summary
; CALC - is the flag for obtaining calcualted values
N CALC
S CALC=1
HS ;
; Entry point for health summary
; VPSHSFLG - Flag that indicates health summary so the report is processed accordingly
; obtains key values that are provided by the CPRS call
N VPSHSFLG,LINE,DATA,VPSDFN,TARGET,VPSQIEN,VPSQNM,VPSFDT,VPSTDT,VPSNUM,DIEN
S VPSHSFLG=1
S TARGET="^TMP(""VPSSRVY3 HS"",$J)"
I $G(DFN)]"" S VPSDFN=DFN
I $G(GMTSBEG)=1 S GMTSBEG=""
I $G(GMTSEND)=9999999 S GMTSEND=""
I $G(GMTSNDM)=-1 S GMTSNDM=""
I $G(GMTSNDM)]"" S VPSNUM=GMTSNDM
I $G(GMTSBEG)]"" S VPSFDT=GMTSBEG
I $G(GMTSEND)]"" S VPSTDT=GMTSEND
W !,$$CJ^XLFSTR(GMTSEGH,75),!
N CNT,NEXTLINE,I
S NEXTLINE=0,CNT=0
I '$D(GMTSEG(1,853.875)) D STARTHS,PRINTHS("") Q
S I=0
F S I=$O(GMTSEG(1,853.875,I)) Q:'I D
. S DIEN=$G(GMTSEG(1,853.875,I))
. S VPSQNM=$P($G(^VPS(853.875,DIEN,0)),U)
. S CNT=0
. D STARTHS
. D PRINTHS(VPSQNM_" - "_GMTSEGL)
Q
;
; print the results of the health summary
;
PRINTHS(SURVEY) ;
N LINE
W $$REPEAT^XLFSTR("_",75),!,$$CJ^XLFSTR(SURVEY,75),!,!
I $P(@TARGET@(0),U)=-1 W !,$P(@TARGET@(0),U,2) Q
I $P(@TARGET@(0),U,2)=0 W !,"No results",!,$$REPEAT^XLFSTR("_",75),! Q
S LINE=0
F S LINE=$O(@TARGET@(LINE)) Q:'LINE D
. S DATA=@TARGET@(LINE)
. I DATA'="@#END OF SURVEY#@" W !,DATA
. E W !,$$REPEAT^XLFSTR("_",75),!
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVPSSRVY3 10422 printed Dec 13, 2024@02:43:40 Page 2
VPSSRVY3 ;WOIFO/BT - VPS CLINICAL SURVEY QUESTIONNAIRE;01/16/15 13:07
+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
UTGET(VPSDFN,TARGET,VPSQIEN,VPSQNM,VPSFDT,VPSTDT,VPSNUM) ;
+1 NEW UTFLG,UT
+2 SET UTFLG=1
+3 SET UT=$$GETRPT(VPSDFN,TARGET)
+4 ;S UT=$$GETRPT(VPSDFN,TARGET,$G(VPSQIEN),$G(VPSQNM),$G(VPSFDT),$G(VPSTDT),$G(VPSNUM))
+5 QUIT UT
+6 ;
GETRPT(VPSDFN,TARGET,VPSQIEN,VPSQNM,VPSFDT,VPSTDT,VPSNUM,AHFLG) ;
+1 ;INPUT
+2 ; VPSDFN : Patient IEN
+3 ; TARGET : Location for the results
+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 ; RESULT(0) = Success or Fail flag
+19 ;RESULT(1..n) = Formatted Questionnaire data
+20 ;
+21 ;Example:
+22 ;
+23 ;RESULT(0) = 1 (Success) ^ 2 (No of questionnaires found)
+24 ;RESULT(1) = Patient Name: TEST, PATIENT
+25 ;RESULT(2) = Questionnaire IEN: 20
+26 ;RESULT(3) = Questionnaire Name: PTSD Survey
+27 ;RESULT(4) = Date and Time Taken: 8/20/14 3:15pm
+28 ;RESULT(5) = Date and Time Last Modified: 8/20/14 4:00pm
+29 ;RESULT(6) = Questions and Answers:
+30 ;RESULT(7) = Are you a smoker? Yes
+31 ;RESULT(8) = How many packs per week? 3
+32 ;
+33 ;
+34 NEW CNT,NEXTLINE,TDT
+35 SET NEXTLINE=0
+36 SET CNT=0
+37 ;
STARTHS ;
+1 KILL @TARGET
+2 ; valid input parameters
+3 ; set up variables for the extraction of clinical survey information
+4 IF $GET(VPSDFN)=""
SET @TARGET@(0)="-1^Patient IEN not sent"
GOTO EX
+5 IF '$DATA(^DPT(VPSDFN))
SET @TARGET@(0)="-1^Patient not found"
GOTO EX
+6 IF '$DATA(^VPS(853.8,VPSDFN))
SET @TARGET@(0)="-1^There are no questionnaires for this patient"
GOTO EX
+7 ;
+8 NEW FDT,FLG,DAT,DATA,X,Y,FLT
+9 SET TDT=$$NOW^XLFDT()+.0001
+10 SET FLG=0
+11 IF $GET(VPSTDT)
Begin DoDot:1
+12 IF VPSTDT["."
SET TDT=VPSTDT+.0001
QUIT
+13 IF VPSTDT'["."
SET TDT=VPSTDT+1
End DoDot:1
+14 SET VPSQIEN=$GET(VPSQIEN)
+15 SET VPSQNM=$GET(VPSQNM)
+16 SET VPSQNM=$$UPCASE^VPSSRVY2(VPSQNM)
+17 ; loop through obtaining the most current information first
+18 SET FLG=0
SET TID=0
+19 FOR
SET TID=$ORDER(^VPS(853.8,VPSDFN,1,TID))
if 'TID!FLG
QUIT
Begin DoDot:1
+20 SET FDT=TDT
+21 FOR
SET FDT=$ORDER(^VPS(853.8,VPSDFN,1,TID,1,FDT),-1)
if 'FDT!FLG
QUIT
Begin DoDot:2
+22 IF $GET(VPSFDT)
IF TDT<VPSFDT
QUIT
+23 IF $GET(VPSTDT)=""
IF $GET(VPSFDT)]""
IF $GET(VPSFDT)'=$PIECE(FDT,".")
QUIT
+24 IF $GET(VPSNUM)
IF CNT=VPSNUM
SET FLG=1
QUIT
+25 IF $$PASSCHK(TID,$GET(VPSQIEN),$GET(VPSQNM))
Begin DoDot:3
+26 DO GETDATA(VPSDFN,TID,FDT,VPSQNM)
+27 SET CNT=CNT+1
End DoDot:3
End DoDot:2
End DoDot:1
+28 IF CNT=0
Begin DoDot:1
+29 NEW STR
+30 SET STR="No Survey results for "
+31 IF $GET(VPSQIEN)]""
SET STR=STR_"CSQ IEN: "_VPSQIEN_", "
+32 IF $GET(VPSQNM)]""
SET STR=STR_"CSQ NAME: "_VPSQNM_" "
+33 IF $GET(VPSFDT)]""
SET STR=STR_"since "_VPSFDT
+34 DO ADD(STR)
End DoDot:1
+35 SET @TARGET@(0)="1^"_CNT
+36 ;
EX ;
+1 IF $GET(VPSHSFLG)=1
QUIT
+2 IF $GET(UTFLG)
QUIT "~@"_$NAME(@TARGET)
+3 DO PDO(VPSDFN,.TARGET)
+4 ;
+5 QUIT "~@"_$NAME(@TARGET)
+6 ;
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 ;
+13 ; obtain the information from the clinical survey
+14 ; and format the information into the report
GETDATA(VPSDFN,TID,FDT,VPSQNM) ;
+1 ;
+2 NEW I,DAT,DATA
+3 SET DATA=$GET(^VPS(853.8,VPSDFN,1,TID,1,FDT,1,1,0))
+4 ; Patient DFN ^ Patient Name ^ Template ID ^ Questionnaire Name ^ Version
+5 ;S DAT="Patient DFN: "_VPSDFN
+6 ;D ADD(DAT)
+7 ;S DAT="Patient Name: "_$$GET1^DIQ(2,VPSDFN_",",.01)
+8 ;D ADD(DAT)
+9 SET DAT="Questionnaire Name: "_$$GET1^DIQ(853.85,TID_",",1)
+10 DO ADD(DAT)
+11 SET DAT="ID: "_$$GET1^DIQ(853.85,TID_",",.01)
+12 ;D ADD(DAT)
+13 SET DAT=DAT_$JUSTIFY(" ",66-$LENGTH(DAT))_"Ver: "_$$GET1^DIQ(853.85,TID_",",2)
+14 DO ADD(DAT)
+15 ; Obtain Response identifier
+16 SET DAT="Response Identifier: "_$$GET1^DIQ(853.811,"1,"_FDT_","_TID_","_VPSDFN_",",.01)
+17 DO ADD(DAT)
+18 ; Obtain converted Date and Time Taken
+19 SET DAT="Date/Time Taken: "_$$GET1^DIQ(853.811,"1,"_FDT_","_TID_","_VPSDFN_",",.02)
+20 ;D ADD(DAT)
+21 ; Obtain Date and Time Last Modified and convert to external format
+22 SET DAT=DAT_$JUSTIFY(" ",41-$LENGTH(DAT))_"Last Modified: "_$$GET1^DIQ(853.811,"1,"_FDT_","_TID_","_VPSDFN_",",.03)
+23 DO ADD(DAT)
+24 ; Obtain COMPLETION STATUS
+25 SET DAT="Completion Status: "_$$GET1^DIQ(853.811,"1,"_FDT_","_TID_","_VPSDFN_",",.04)
+26 DO ADD(DAT)
+27 ; Obtain PATIENT SAFETY
+28 SET DAT="Patient Safety: "_$$GET1^DIQ(853.811,"1,"_FDT_","_TID_","_VPSDFN_",",.05)
+29 SET DAT=DAT_$JUSTIFY(" ",41-$LENGTH(DAT))_"Immediate Action: "_$$GET1^DIQ(853.811,"1,"_FDT_","_TID_","_VPSDFN_",",.06)
+30 DO ADD(DAT)
+31 ; Obtain IMMEDIATE ACTION
+32 ;S DAT="Immediate Action: "_$$GET1^DIQ(853.811,"1,"_FDT_","_TID_","_VPSDFN_",",.06)
+33 ;D ADD(DAT)
+34 ; Obtain SURVEY CALCULATED VALUE
+35 SET DAT=$$GET1^DIQ(853.811,"1,"_FDT_","_TID_","_VPSDFN_",",4)
+36 IF $GET(CALC)
IF DAT]""
DO ADD("Survey Calculated Value: "_DAT)
+37 SET I=0
+38 NEW DAT1
+39 FOR
SET I=$ORDER(^VPS(853.8,VPSDFN,1,TID,1,FDT,1,1,2,I))
if 'I
QUIT
Begin DoDot:1
+40 SET DAT=$PIECE(^VPS(853.8,VPSDFN,1,TID,1,FDT,1,1,2,I,0),U)
+41 ;D ADD(DAT)
IF DAT]""
SET DAT="Additional Calc Value Name: "_DAT
+42 SET DAT1=$PIECE(^VPS(853.8,VPSDFN,1,TID,1,FDT,1,1,2,I,0),U,2)
+43 ;D ADD(DAT)
IF DAT1]""
SET DAT1="Additional Calc Value Score: "_DAT1
+44 IF DAT]""!(DAT1]"")
SET DAT=DAT_$JUSTIFY(" ",41-$LENGTH(DAT))_DAT1
DO ADD(DAT)
End DoDot:1
+45 SET I=0
+46 FOR
SET I=$ORDER(^VPS(853.8,VPSDFN,1,TID,1,FDT,1,1,1,I))
if 'I
QUIT
Begin DoDot:1
+47 SET DAT="Appointment Check-in: "_^VPS(853.8,VPSDFN,1,TID,1,FDT,1,1,1,I,0)
+48 DO ADD(DAT)
End DoDot:1
+49 NEW J,II
+50 SET I=0
+51 FOR
SET I=$ORDER(^VPS(853.8,VPSDFN,1,TID,1,FDT,1,1,3,I))
if 'I
QUIT
Begin DoDot:1
+52 DO ADD("______________________________")
+53 ;S DAT="Question Number: "_$$GET1^DIQ(853.8113,I_",1,"_FDT_","_TID_","_VPSDFN_",",.01)
+54 ;D ADD(DAT)
+55 SET DAT=$$GET1^DIQ(853.8113,I_",1,"_FDT_","_TID_","_VPSDFN_",",1)
+56 IF $GET(CALC)
IF DAT]""
DO ADD("Question Calculated Value: "_DAT)
+57 NEW TMP
+58 IF $$GET1^DIQ(853.8113,I_",1,"_FDT_","_TID_","_VPSDFN_",",2,"","TMP")
+59 IF $DATA(TMP(1))
SET TMP(1)=$$GET1^DIQ(853.8113,I_",1,"_FDT_","_TID_","_VPSDFN_",",.01)_" - "_TMP(1)
+60 SET J=0
+61 FOR
SET J=$ORDER(TMP(J))
if 'J
QUIT
DO ADD(TMP(J))
+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 IF CUR'=0
IF CUR'=$$GET1^DIQ(853.81133,II_","_I_",1,"_FDT_","_TID_","_VPSDFN_",",1)
IF +$GET(AHFLG)=0
SET CUR=99
QUIT
+67 IF CUR=0
SET CUR=$$GET1^DIQ(853.81133,II_","_I_",1,"_FDT_","_TID_","_VPSDFN_",",1)
+68 ;D ADD(" _-_-_-_-_-_-_-_-_-_-_-_-_-_-_-")
+69 ; Obtain ANSWER IDENTIFIER
+70 ;S DAT="Answer Identifier: "_$$GET1^DIQ(853.81133,II_","_I_",1,"_FDT_","_TID_","_VPSDFN_",",.01)
+71 ;D ADD(DAT)
+72 ;S DAT="Interface Used: "_$$GET1^DIQ(853.81133,II_","_I_",1,"_FDT_","_TID_","_VPSDFN_",",.02)
+73 ;D ADD(DAT)
+74 ;S DAT="Kiosk Identifier: "_$$GET1^DIQ(853.81133,II_","_I_",1,"_FDT_","_TID_","_VPSDFN_",",3)
+75 ;D ADD(DAT)
+76 ;S DAT="Kiosk Session Identifier: "_$$GET1^DIQ(853.81133,II_","_I_",1,"_FDT_","_TID_","_VPSDFN_",",4)
+77 ;D ADD(DAT)
+78 ;S DAT="Kiosk Group Identifier: "_$$GET1^DIQ(853.81133,II_","_I_",1,"_FDT_","_TID_","_VPSDFN_",",5)
+79 ;D ADD(DAT)
+80 SET DAT=""
+81 KILL TMP
+82 IF $$GET1^DIQ(853.81133,II_","_I_",1,"_FDT_","_TID_","_VPSDFN_",",6,"","TMP")
+83 IF $DATA(TMP(1))
DO ADD(" "_$$GET1^DIQ(853.81133,II_","_I_",1,"_FDT_","_TID_","_VPSDFN_",",.01)_" - "_TMP(1))
+84 SET J=1
+85 FOR
SET J=$ORDER(TMP(J))
if 'J
QUIT
DO ADD(" "_TMP(J))
+86 SET DAT=$$GET1^DIQ(853.81133,II_","_I_",1,"_FDT_","_TID_","_VPSDFN_",",.03)
+87 IF DAT'="PATIENT"
Begin DoDot:3
+88 SET DAT=" Respondent: "_DAT
+89 ;D ADD(" "_DAT)
+90 SET DAT=DAT_$JUSTIFY(" ",41-$LENGTH(DAT))_"Respondent Name: "_$$GET1^DIQ(853.81133,II_","_I_",1,"_FDT_","_TID_","_VPSDFN_",",.04)
+91 DO ADD(DAT)
End DoDot:3
+92 SET DAT=" Answer Date/Time: "_$$GET1^DIQ(853.81133,II_","_I_",1,"_FDT_","_TID_","_VPSDFN_",",1)
+93 ;D ADD(" "_DAT)
+94 SET DAT1=$$GET1^DIQ(853.81133,II_","_I_",1,"_FDT_","_TID_","_VPSDFN_",",2)
+95 IF DAT1]""
IF +DAT1=0
IF DAT1'=0
Begin DoDot:3
+96 SET DAT1="Interviewer Name: "_DAT1
+97 SET DAT=DAT_$JUSTIFY(" ",41-$LENGTH(DAT))_DAT1
+98 DO ADD(DAT)
End DoDot:3
+99 DO ADD("")
+100 SET CUR=1
End DoDot:2
End DoDot:1
+101 DO ADD("@#END OF SURVEY#@")
+102 QUIT
ADD(TXT) ;
+1 SET NEXTLINE=NEXTLINE+1
+2 SET @TARGET@(NEXTLINE)=TXT
+3 QUIT
+4 ;
PDO(PTIEN,PDOARY) ;
+1 ; create object and store the results of this clinical survey request
+2 NEW PDOOREF,LINE,ARR
+3 SET ARR="^TMP(""VPSSRVY3PDO"",$J)"
+4 SET PDOOREF=$$NEW^VPSOBJ(PTIEN,ARR)
+5 IF $PIECE(@PDOARY@(0),U)=-1
DO ADDPDO^VPSOBJ(PDOOREF,$PIECE(@TARGET@(0),U,2))
GOTO CLOSE
+6 SET LINE=0
+7 FOR
SET LINE=$ORDER(@PDOARY@(LINE))
if 'LINE
QUIT
Begin DoDot:1
+8 IF @PDOARY@(LINE)'="@#END OF SURVEY#@"
DO ADDPDO^VPSOBJ(PDOOREF,@PDOARY@(LINE))
IF 1
+9 IF '$TEST
DO ADDBLANK^VPSOBJ(PDOOREF)
DO ADDUNDLN^VPSOBJ(PDOOREF)
DO ADDBLANK^VPSOBJ(PDOOREF)
End DoDot:1
CLOSE ;
+1 ; close the object
+2 DO CLOSE^VPSOBJ(PDOOREF)
+3 SET PDOARY=ARR
+4 QUIT
+5 ;
HSAHCAL ;
+1 ; Entry point for including answer history and calculated values with the health summary
+2 ; AHFLG - is the flag for obtaining answer history
+3 NEW AHFLG
+4 SET AHFLG=1
HSCAL ;
+1 ; Entry point for including calculated values with the health summary
+2 ; CALC - is the flag for obtaining calcualted values
+3 NEW CALC
+4 SET CALC=1
HS ;
+1 ; Entry point for health summary
+2 ; VPSHSFLG - Flag that indicates health summary so the report is processed accordingly
+3 ; obtains key values that are provided by the CPRS call
+4 NEW VPSHSFLG,LINE,DATA,VPSDFN,TARGET,VPSQIEN,VPSQNM,VPSFDT,VPSTDT,VPSNUM,DIEN
+5 SET VPSHSFLG=1
+6 SET TARGET="^TMP(""VPSSRVY3 HS"",$J)"
+7 IF $GET(DFN)]""
SET VPSDFN=DFN
+8 IF $GET(GMTSBEG)=1
SET GMTSBEG=""
+9 IF $GET(GMTSEND)=9999999
SET GMTSEND=""
+10 IF $GET(GMTSNDM)=-1
SET GMTSNDM=""
+11 IF $GET(GMTSNDM)]""
SET VPSNUM=GMTSNDM
+12 IF $GET(GMTSBEG)]""
SET VPSFDT=GMTSBEG
+13 IF $GET(GMTSEND)]""
SET VPSTDT=GMTSEND
+14 WRITE !,$$CJ^XLFSTR(GMTSEGH,75),!
+15 NEW CNT,NEXTLINE,I
+16 SET NEXTLINE=0
SET CNT=0
+17 IF '$DATA(GMTSEG(1,853.875))
DO STARTHS
DO PRINTHS("")
QUIT
+18 SET I=0
+19 FOR
SET I=$ORDER(GMTSEG(1,853.875,I))
if 'I
QUIT
Begin DoDot:1
+20 SET DIEN=$GET(GMTSEG(1,853.875,I))
+21 SET VPSQNM=$PIECE($GET(^VPS(853.875,DIEN,0)),U)
+22 SET CNT=0
+23 DO STARTHS
+24 DO PRINTHS(VPSQNM_" - "_GMTSEGL)
End DoDot:1
+25 QUIT
+26 ;
+27 ; print the results of the health summary
+28 ;
PRINTHS(SURVEY) ;
+1 NEW LINE
+2 WRITE $$REPEAT^XLFSTR("_",75),!,$$CJ^XLFSTR(SURVEY,75),!,!
+3 IF $PIECE(@TARGET@(0),U)=-1
WRITE !,$PIECE(@TARGET@(0),U,2)
QUIT
+4 IF $PIECE(@TARGET@(0),U,2)=0
WRITE !,"No results",!,$$REPEAT^XLFSTR("_",75),!
QUIT
+5 SET LINE=0
+6 FOR
SET LINE=$ORDER(@TARGET@(LINE))
if 'LINE
QUIT
Begin DoDot:1
+7 SET DATA=@TARGET@(LINE)
+8 IF DATA'="@#END OF SURVEY#@"
WRITE !,DATA
+9 IF '$TEST
WRITE !,$$REPEAT^XLFSTR("_",75),!
End DoDot:1
+10 QUIT
