YTQRCRD ;SLC/KCM - MH Clinical Reminder Dialog DLL Calls ; 1/25/2017
;;5.01;MENTAL HEALTH;**223**;Dec 30, 1994;Build 22
;
; passed in RPC, YTQRRPC style:
; REQ(1)=command
; REQ(n)=name=value
;
; RSP(n)=return value(s)
;
DLL(YTQRRSP,REQ) ; Controller for patient select screen
N I,CMD,PARAMS
S CMD=$G(REQ(1))
S I=1 F S I=$O(REQ(I)) Q:'I S PARAMS($P(REQ(I),"="))=$P(REQ(I),"=",2,99)
;
; switch on CMD
; ---------------------------------
; setupStaging ==> guid {DLL - ShowInstrument begin}
I CMD="setupStaging" D G OUT
. D SETUP(.YTQRRSP,$$VAL("test"),$$VAL("dfn"),$$VAL("ordBy"),$$VAL("loc"),$$VAL("hwnd"))
; ---------------------------------
; getResults ==> {DLL - ShowInstrument end}
I CMD="getResults" D G OUT
. D GETRSLT(.YTQRRSP,$$VAL("test"),$$VAL("guid"))
; ---------------------------------
; commitAdmin ==> {DLL - SaveInstrument}
I CMD="commitAdmin" D G OUT
. D COMMIT(.YTQRRSP,$$VAL("test"),$$VAL("dfn"),$$VAL("ordBy"),$$VAL("admBy"),$$VAL("admDt"),$$VAL("loc"),$$VAL("hwnd"))
; ---------------------------------
; clearStaging ==> {DLL - RemoveTempVistaFile}
I CMD="clearStaging" D G OUT
. D CLEAR(.YTQRRSP,$$VAL("dfn"),$$VAL("test"),$$VAL("hwnd"))
; ---------------------------------
; else
S YTQRRSP(1)="Error: command not found"
;
OUT ; end of switch statement
Q
;
VAL(X) ; return value from request
; expects PARAMS ( with special handling for HWND)
I X="hwnd" N V S V=$TR($P($G(PARAMS(X)),"."),"-","") S:'$L(V) V=0 Q V
Q $G(PARAMS(X))
;
; -- calls from Delphi DLL
;
; ^XTMP(YTQCPRS-guid,1,property)=ASSIGNMENT property value
; ^XTMP(YTQCPRS-guid,1,"instrument",n,property)=specific instrument values
; ^XTMP(YTQCPRS-guid,3,testId,property)=ADMIN property value (replace 601.94)
; ^XTMP(YTQCPRS-guid,3,testId,"answers",n,property)=response value for admin
; ^XTMP(YTQCPRS-guid,"hwnd")=client windows handle
; ^XTMP(YTQCPRS-HWND,hwnd,dfn,testName)=guid^date ; INDEX for patient/session
;
SETUP(RSP,TESTNM,DFN,ORDBY,LOC,HWND) ; set up assignment for reminder dialog
; DLL: ShowInstrument begin - initiate instrument web page
; (testNm,DFN,OrdByNm,OrdBy,AdmByNm,AdmBy,LocNm,LocIEN,AllReq)
; input: testName, DFN, orderedBy, interviewer, location, handle
; output: URL with GUID
;
N DATA,TEST,GUID
; check to see if there is already a current assignment and use that
S GUID="" I $L(HWND),+DFN,$L(TESTNM) D I $L(GUID) QUIT
. S GUID=$G(^XTMP("YTQCPRS-HWND",HWND,DFN,TESTNM))
. I $L(GUID),($P(GUID,U,2)=DT) S GUID=$P(GUID,U) I 1
. E S GUID="" ; needed if DT doesn't match
. I $L(GUID) S RSP(1)="URL="_$$GET^XPAR("SYS","YSCPRS DLL URL",1,"Q")_GUID
;
; otherwise create a new assignment in staging area
N RPRIV,HOLDER
I 'DFN!'ORDBY S RSP(1)="ERROR: missing required fields" QUIT
S TEST=$O(^YTT(601.71,"B",TESTNM,0)) I 'TEST S RSP(1)="ERROR: test not found" QUIT
S RPRIV=$P($G(^YTT(601.71,TEST,2)),U)
I $L(RPRIV) D I '$G(HOLDER(0)) QUIT
. D OWNSKEY^XUSRB(.HOLDER,RPRIV,ORDBY)
. I 'HOLDER(0) S RSP(1)="ERROR: orderer lacks the proper key"
D DEM^VADPT I $G(VAERR) S RSP(1)="ERROR: missing patient info" QUIT
S DATA("patient","dfn")=DFN
S DATA("patient","name")=VADM(1)
S DATA("patient","pid")="xxx-xx-"_VA("BID")
S DATA("patient","ssn")=DATA("patient","pid")
S DATA("orderedBy")=ORDBY
S DATA("interview")=ORDBY
S DATA("date")=$$NOW^XLFDT()
S DATA("adminDate")=$$FMTE^XLFDT(DATA("date"),"5DZ")
S DATA("location")=+LOC ; strips the trailing "V", if there
S DATA("appSrc")="cprs-web-dll"
S DATA("questionMode")="all" ; tells web app this is CPRS-CR DLL
S DATA("entryMode")="cprs" ; tells web app this is CPRS-CR DLL
S DATA("catInfo")="null"
S DATA("instruments",1,"id")=TEST
S DATA("instruments",1,"name")=TESTNM
S DATA("instruments",1,"printTitle")=$P(^YTT(601.71,TEST,0),U,3)
S DATA("instruments",1,"restartDays")=$P($G(^YTT(601.71,TEST,8)),U,7)
S DATA("instruments",1,"adminId")="null"
S DATA("instruments",1,"replace")="null"
S DATA("instruments",1,"complete")="false"
S DATA("instruments",1,"progress")=0
D KVA^VADPT
;
N TRYS,NODE,DONE
S DONE=0 F TRYS=1:1:30 D Q:DONE ; (This should really work the first time)
. S GUID=$$GUID4
. S NODE="YTQCPRS-"_GUID
. L +^XTMP(NODE):DILOCKTM E QUIT
. I $D(^XTMP(NODE)) L -^XTMP(NODE) QUIT ; already used, so unlock & retry
. S ^XTMP(NODE,0)=$$FMADD^XLFDT(DT,1)_U_DT_U_"MH DLL Assignment",DONE=1
. L -^XTMP(NODE)
S DATA("id")=GUID
I 'DONE S RSP(1)="ERROR: failed to find GUID" QUIT
S ^XTMP("YTQCPRS-HWND",0)=^XTMP(NODE,0)_" Index"
S ^XTMP("YTQCPRS-HWND",HWND,DFN,TESTNM)=GUID_U_DT
S ^XTMP(NODE,"hwnd")=HWND
M ^XTMP(NODE,1)=DATA
S RSP(1)="URL="_$$GET^XPAR("SYS","YSCPRS DLL URL",1,"Q")_GUID
Q
GUID4() ; return a type 4 GUID (random)
N C,D,X,N ; C=ceiling, D=dash, X=uuid, N=integer
S C=4294967295,D="-",X=""
F N=1:1:4 S X=X_$TR($J($$CNV^XLFUTL($R(C),16),8)," ",0)
S $E(X,13)=4,N=$R(4),$E(X,17)=$S(N=0:8,N=1:9,N=2:"A",1:"B")
Q $E(X,1,8)_D_$E(X,9,12)_D_$E(X,13,16)_D_$E(X,17,20)_D_$E(X,21,32)
;
GETRSLT(RSP,TESTNM,GUID) ; get status and results for reminder dialog test invocation
; DLL: ShowInstrument end - web page completed, return result
; input: TESTNM, GUID
; output: status, scale=score..., questions...
; faComplete, faIncomplete, faCancelled, faNotStarted
N NODE,TEST,QCNT,I
S NODE="YTQCPRS-"_GUID
S TEST=+$O(^YTT(601.71,"B",TESTNM,0))
I 'TEST S RSP(1)="CANCELLED^" QUIT
S (I,QCNT)=0 F S I=$O(^YTT(601.76,"AC",TEST,I)) Q:'I S QCNT=QCNT+1
I '$D(^XTMP(NODE)) D QUIT
. S RSP(1)="CANCELLED^"_TESTNM_U_QCNT
I '$D(^XTMP(NODE,3,TEST)) D QUIT
. S RSP(1)="NOT STARTED^"_TESTNM_U_QCNT
I $G(^XTMP(NODE,3,TEST,"complete"))'="true" D QUIT
. S RSP(1)="INCOMPLETE^"_TESTNM_U_QCNT_U_$$SKIPSTR(NODE,TEST)
I $L($P($G(^YTT(601.71,TEST,2)),U)) D QUIT
. S RSP(1)="COMPLETE^"_TESTNM_U_QCNT_"^*Restricted instrument. No results are reported here."
;
; -- score completed, non-restricted instrument
N ANSWERS,SCORES
M ANSWERS=^XTMP(NODE,3,TEST,"answers")
I $P($G(^YTT(601.71,TEST,8)),U,3)="Y" D ; legacy scoring
. N ADFN,AUSER
. S ADFN=^XTMP(NODE,1,"patient","dfn")
. S AUSER=^XTMP(NODE,1,"orderedBy") S:'AUSER AUSER=DUZ
. D LEGACY^YTSCOREX(TESTNM,ADFN,AUSER,.ANSWERS,.SCORES)
E D CALC^YTSCOREX(TEST,.ANSWERS,.SCORES) ; normal scoring
S RSP(1)=$$CPRSSTR^YTSCOREX(TEST,.ANSWERS,.SCORES)
Q
SKIPSTR(NODE,TEST) ; return a string of skipped question identifiers
N I,QSTN,CTXT,DLIM,X
S X=""
S I=0 F S I=$O(^XTMP(NODE,3,TEST,"answers",I)) Q:'I D Q:$L(X)>200
. I $G(^XTMP(NODE,3,TEST,"answers",I,"value"))="NOT ASKED" D
. . S QSTN=+$P($G(^XTMP(NODE,3,TEST,"answers",I,"id")),"q",2)
. . S CTXT=$O(^YTT(601.76,"AF",TEST,QSTN,0))
. . S DLIM=$P(^YTT(601.76,CTXT,0),U,5)
. . I $L(DLIM) S X=X_DLIM_", "
Q X
;
COMMIT(RSP,TESTNM,DFN,ORDBY,ADMBY,ADMDT,LOC,HWND) ; save completed administration
; DLL: SaveInstrument(testNm,DFN,OrdBy,AdmBy,AdmDate,LocIEN)
; input: testName, DFN, orderedBy, interviewer, location, adminDate
; (use DFN + TESTNM to find the GUID)
; need to set adminDate so it syncs with the visit
; update ordBy, admBy, loc if necessary
; output: returnStatus
;
N GUID,NODE,TEST,DATA,ADMIN
I '$L(DFN)!'$L(ORDBY)!'$L(ADMBY)!'$L(ADMDT)!'$L(LOC) D QUIT
. S RSP(1)="ERROR: required fields are missing"
S GUID=$P($G(^XTMP("YTQCPRS-HWND",HWND,DFN,TESTNM)),U)
S NODE="YTQCPRS-"_GUID
S TEST=+$O(^YTT(601.71,"B",TESTNM,0))
I '$D(^XTMP(NODE,3,TEST,"answers")) S RSP(1)="ERROR: answers not found" QUIT
I ^XTMP(NODE,1,"patient","dfn")'=DFN S RSP(1)="ERROR: patient mis-match" QUIT
S ^XTMP(NODE,1,"date")=ADMDT,^("adminDate")="" ; force visit date from CPRS
S ^XTMP(NODE,1,"orderedBy")=ORDBY
S ^XTMP(NODE,1,"interview")=ADMBY
S ^XTMP(NODE,1,"location")=+LOC
M DATA=^XTMP(NODE,3,TEST)
S DATA("source")="cprs-web-dll"
S DATA("assignmentId")=$P(DATA("adminId"),"-",1,5)
K DATA("adminId") ; so it doesn't get confused with "real" adminId
S ADMIN=$$QASAVE^YTQRQAD2(.DATA)
I 'ADMIN S RSP(1)="ERROR: admin not created" QUIT
S RSP(1)=ADMIN
N YSDATA,YS
K ^TMP($J,"YSCOR")
S YS("AD")=ADMIN
D SCORSAVE^YTQAPI11(.YSDATA,.YS)
I $G(YSDATA(1))="[ERROR]" S RSP(1)="ERROR: "_$G(YSDATA(2)) QUIT
I $G(^TMP($J,"YSCOR",1))="[ERROR]" S RSP(1)="ERROR: "_$G(^(2)) QUIT
D CLEARTST(DFN,TESTNM,HWND)
Q
;
CLEAR(RSP,DFN,TESTNM,HWND) ; remove test data from reminder dialog temporary space
; DLL: RemoveTempVistaFile(testNm, DFN)
; input: testName, DFN, handle
; remove all for DFN if testName=""
; otherwise remove testName for DFN
S RSP(1)="OK"
N GUID,X
I $L(TESTNM) D CLEARTST(DFN,TESTNM,HWND) QUIT
; clear all scratch instruments for this session if TESTNM=""
S X="" F S X=$O(^XTMP("YTQCPRS-HWND",HWND,DFN,X)) Q:'$L(X) D
. D CLEARTST(DFN,X,HWND)
Q
CLEARTST(DFN,TESTNM,HWND) ; for DFN/HWND session, remove specific TESTNM
N GUID,NODE,I,TEST
S GUID=$P($G(^XTMP("YTQCPRS-HWND",HWND,DFN,TESTNM)),U) Q:'$L(GUID)
S NODE="YTQCPRS-"_GUID
S I=0 F S I=$O(^XTMP(NODE,1,"instruments",I)) Q:'I D
. I ^XTMP(NODE,1,"instruments",I,"name")'=TESTNM QUIT
. K ^XTMP(NODE,1,"instruments",I) ; remove TESTNM assignment
. S TEST=$O(^YTT(601.71,"B",TESTNM,0)) Q:'TEST
. K ^XTMP(NODE,3,TEST) ; remove TESTNM answer set
. K ^XTMP("YTQCPRS-HWND",HWND,DFN,TESTNM) ; remove index node
I '$D(^XTMP(NODE,1,"instruments")) K ^XTMP(NODE) ; no tests remaining
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYTQRCRD 9671 printed Dec 13, 2024@02:18:46 Page 2
YTQRCRD ;SLC/KCM - MH Clinical Reminder Dialog DLL Calls ; 1/25/2017
+1 ;;5.01;MENTAL HEALTH;**223**;Dec 30, 1994;Build 22
+2 ;
+3 ; passed in RPC, YTQRRPC style:
+4 ; REQ(1)=command
+5 ; REQ(n)=name=value
+6 ;
+7 ; RSP(n)=return value(s)
+8 ;
DLL(YTQRRSP,REQ) ; Controller for patient select screen
+1 NEW I,CMD,PARAMS
+2 SET CMD=$GET(REQ(1))
+3 SET I=1
FOR
SET I=$ORDER(REQ(I))
if 'I
QUIT
SET PARAMS($PIECE(REQ(I),"="))=$PIECE(REQ(I),"=",2,99)
+4 ;
+5 ; switch on CMD
+6 ; ---------------------------------
+7 ; setupStaging ==> guid {DLL - ShowInstrument begin}
+8 IF CMD="setupStaging"
Begin DoDot:1
+9 DO SETUP(.YTQRRSP,$$VAL("test"),$$VAL("dfn"),$$VAL("ordBy"),$$VAL("loc"),$$VAL("hwnd"))
End DoDot:1
GOTO OUT
+10 ; ---------------------------------
+11 ; getResults ==> {DLL - ShowInstrument end}
+12 IF CMD="getResults"
Begin DoDot:1
+13 DO GETRSLT(.YTQRRSP,$$VAL("test"),$$VAL("guid"))
End DoDot:1
GOTO OUT
+14 ; ---------------------------------
+15 ; commitAdmin ==> {DLL - SaveInstrument}
+16 IF CMD="commitAdmin"
Begin DoDot:1
+17 DO COMMIT(.YTQRRSP,$$VAL("test"),$$VAL("dfn"),$$VAL("ordBy"),$$VAL("admBy"),$$VAL("admDt"),$$VAL("loc"),$$VAL("hwnd"))
End DoDot:1
GOTO OUT
+18 ; ---------------------------------
+19 ; clearStaging ==> {DLL - RemoveTempVistaFile}
+20 IF CMD="clearStaging"
Begin DoDot:1
+21 DO CLEAR(.YTQRRSP,$$VAL("dfn"),$$VAL("test"),$$VAL("hwnd"))
End DoDot:1
GOTO OUT
+22 ; ---------------------------------
+23 ; else
+24 SET YTQRRSP(1)="Error: command not found"
+25 ;
OUT ; end of switch statement
+1 QUIT
+2 ;
VAL(X) ; return value from request
+1 ; expects PARAMS ( with special handling for HWND)
+2 IF X="hwnd"
NEW V
SET V=$TRANSLATE($PIECE($GET(PARAMS(X)),"."),"-","")
if '$LENGTH(V)
SET V=0
QUIT V
+3 QUIT $GET(PARAMS(X))
+4 ;
+5 ; -- calls from Delphi DLL
+6 ;
+7 ; ^XTMP(YTQCPRS-guid,1,property)=ASSIGNMENT property value
+8 ; ^XTMP(YTQCPRS-guid,1,"instrument",n,property)=specific instrument values
+9 ; ^XTMP(YTQCPRS-guid,3,testId,property)=ADMIN property value (replace 601.94)
+10 ; ^XTMP(YTQCPRS-guid,3,testId,"answers",n,property)=response value for admin
+11 ; ^XTMP(YTQCPRS-guid,"hwnd")=client windows handle
+12 ; ^XTMP(YTQCPRS-HWND,hwnd,dfn,testName)=guid^date ; INDEX for patient/session
+13 ;
SETUP(RSP,TESTNM,DFN,ORDBY,LOC,HWND) ; set up assignment for reminder dialog
+1 ; DLL: ShowInstrument begin - initiate instrument web page
+2 ; (testNm,DFN,OrdByNm,OrdBy,AdmByNm,AdmBy,LocNm,LocIEN,AllReq)
+3 ; input: testName, DFN, orderedBy, interviewer, location, handle
+4 ; output: URL with GUID
+5 ;
+6 NEW DATA,TEST,GUID
+7 ; check to see if there is already a current assignment and use that
+8 SET GUID=""
IF $LENGTH(HWND)
IF +DFN
IF $LENGTH(TESTNM)
Begin DoDot:1
+9 SET GUID=$GET(^XTMP("YTQCPRS-HWND",HWND,DFN,TESTNM))
+10 IF $LENGTH(GUID)
IF ($PIECE(GUID,U,2)=DT)
SET GUID=$PIECE(GUID,U)
IF 1
+11 ; needed if DT doesn't match
IF '$TEST
SET GUID=""
+12 IF $LENGTH(GUID)
SET RSP(1)="URL="_$$GET^XPAR("SYS","YSCPRS DLL URL",1,"Q")_GUID
End DoDot:1
IF $LENGTH(GUID)
QUIT
+13 ;
+14 ; otherwise create a new assignment in staging area
+15 NEW RPRIV,HOLDER
+16 IF 'DFN!'ORDBY
SET RSP(1)="ERROR: missing required fields"
QUIT
+17 SET TEST=$ORDER(^YTT(601.71,"B",TESTNM,0))
IF 'TEST
SET RSP(1)="ERROR: test not found"
QUIT
+18 SET RPRIV=$PIECE($GET(^YTT(601.71,TEST,2)),U)
+19 IF $LENGTH(RPRIV)
Begin DoDot:1
+20 DO OWNSKEY^XUSRB(.HOLDER,RPRIV,ORDBY)
+21 IF 'HOLDER(0)
SET RSP(1)="ERROR: orderer lacks the proper key"
End DoDot:1
IF '$GET(HOLDER(0))
QUIT
+22 DO DEM^VADPT
IF $GET(VAERR)
SET RSP(1)="ERROR: missing patient info"
QUIT
+23 SET DATA("patient","dfn")=DFN
+24 SET DATA("patient","name")=VADM(1)
+25 SET DATA("patient","pid")="xxx-xx-"_VA("BID")
+26 SET DATA("patient","ssn")=DATA("patient","pid")
+27 SET DATA("orderedBy")=ORDBY
+28 SET DATA("interview")=ORDBY
+29 SET DATA("date")=$$NOW^XLFDT()
+30 SET DATA("adminDate")=$$FMTE^XLFDT(DATA("date"),"5DZ")
+31 ; strips the trailing "V", if there
SET DATA("location")=+LOC
+32 SET DATA("appSrc")="cprs-web-dll"
+33 ; tells web app this is CPRS-CR DLL
SET DATA("questionMode")="all"
+34 ; tells web app this is CPRS-CR DLL
SET DATA("entryMode")="cprs"
+35 SET DATA("catInfo")="null"
+36 SET DATA("instruments",1,"id")=TEST
+37 SET DATA("instruments",1,"name")=TESTNM
+38 SET DATA("instruments",1,"printTitle")=$PIECE(^YTT(601.71,TEST,0),U,3)
+39 SET DATA("instruments",1,"restartDays")=$PIECE($GET(^YTT(601.71,TEST,8)),U,7)
+40 SET DATA("instruments",1,"adminId")="null"
+41 SET DATA("instruments",1,"replace")="null"
+42 SET DATA("instruments",1,"complete")="false"
+43 SET DATA("instruments",1,"progress")=0
+44 DO KVA^VADPT
+45 ;
+46 NEW TRYS,NODE,DONE
+47 ; (This should really work the first time)
SET DONE=0
FOR TRYS=1:1:30
Begin DoDot:1
+48 SET GUID=$$GUID4
+49 SET NODE="YTQCPRS-"_GUID
+50 LOCK +^XTMP(NODE):DILOCKTM
IF '$TEST
QUIT
+51 ; already used, so unlock & retry
IF $DATA(^XTMP(NODE))
LOCK -^XTMP(NODE)
QUIT
+52 SET ^XTMP(NODE,0)=$$FMADD^XLFDT(DT,1)_U_DT_U_"MH DLL Assignment"
SET DONE=1
+53 LOCK -^XTMP(NODE)
End DoDot:1
if DONE
QUIT
+54 SET DATA("id")=GUID
+55 IF 'DONE
SET RSP(1)="ERROR: failed to find GUID"
QUIT
+56 SET ^XTMP("YTQCPRS-HWND",0)=^XTMP(NODE,0)_" Index"
+57 SET ^XTMP("YTQCPRS-HWND",HWND,DFN,TESTNM)=GUID_U_DT
+58 SET ^XTMP(NODE,"hwnd")=HWND
+59 MERGE ^XTMP(NODE,1)=DATA
+60 SET RSP(1)="URL="_$$GET^XPAR("SYS","YSCPRS DLL URL",1,"Q")_GUID
+61 QUIT
GUID4() ; return a type 4 GUID (random)
+1 ; C=ceiling, D=dash, X=uuid, N=integer
NEW C,D,X,N
+2 SET C=4294967295
SET D="-"
SET X=""
+3 FOR N=1:1:4
SET X=X_$TRANSLATE($JUSTIFY($$CNV^XLFUTL($RANDOM(C),16),8)," ",0)
+4 SET $EXTRACT(X,13)=4
SET N=$RANDOM(4)
SET $EXTRACT(X,17)=$SELECT(N=0:8,N=1:9,N=2:"A",1:"B")
+5 QUIT $EXTRACT(X,1,8)_D_$EXTRACT(X,9,12)_D_$EXTRACT(X,13,16)_D_$EXTRACT(X,17,20)_D_$EXTRACT(X,21,32)
+6 ;
GETRSLT(RSP,TESTNM,GUID) ; get status and results for reminder dialog test invocation
+1 ; DLL: ShowInstrument end - web page completed, return result
+2 ; input: TESTNM, GUID
+3 ; output: status, scale=score..., questions...
+4 ; faComplete, faIncomplete, faCancelled, faNotStarted
+5 NEW NODE,TEST,QCNT,I
+6 SET NODE="YTQCPRS-"_GUID
+7 SET TEST=+$ORDER(^YTT(601.71,"B",TESTNM,0))
+8 IF 'TEST
SET RSP(1)="CANCELLED^"
QUIT
+9 SET (I,QCNT)=0
FOR
SET I=$ORDER(^YTT(601.76,"AC",TEST,I))
if 'I
QUIT
SET QCNT=QCNT+1
+10 IF '$DATA(^XTMP(NODE))
Begin DoDot:1
+11 SET RSP(1)="CANCELLED^"_TESTNM_U_QCNT
End DoDot:1
QUIT
+12 IF '$DATA(^XTMP(NODE,3,TEST))
Begin DoDot:1
+13 SET RSP(1)="NOT STARTED^"_TESTNM_U_QCNT
End DoDot:1
QUIT
+14 IF $GET(^XTMP(NODE,3,TEST,"complete"))'="true"
Begin DoDot:1
+15 SET RSP(1)="INCOMPLETE^"_TESTNM_U_QCNT_U_$$SKIPSTR(NODE,TEST)
End DoDot:1
QUIT
+16 IF $LENGTH($PIECE($GET(^YTT(601.71,TEST,2)),U))
Begin DoDot:1
+17 SET RSP(1)="COMPLETE^"_TESTNM_U_QCNT_"^*Restricted instrument. No results are reported here."
End DoDot:1
QUIT
+18 ;
+19 ; -- score completed, non-restricted instrument
+20 NEW ANSWERS,SCORES
+21 MERGE ANSWERS=^XTMP(NODE,3,TEST,"answers")
+22 ; legacy scoring
IF $PIECE($GET(^YTT(601.71,TEST,8)),U,3)="Y"
Begin DoDot:1
+23 NEW ADFN,AUSER
+24 SET ADFN=^XTMP(NODE,1,"patient","dfn")
+25 SET AUSER=^XTMP(NODE,1,"orderedBy")
if 'AUSER
SET AUSER=DUZ
+26 DO LEGACY^YTSCOREX(TESTNM,ADFN,AUSER,.ANSWERS,.SCORES)
End DoDot:1
+27 ; normal scoring
IF '$TEST
DO CALC^YTSCOREX(TEST,.ANSWERS,.SCORES)
+28 SET RSP(1)=$$CPRSSTR^YTSCOREX(TEST,.ANSWERS,.SCORES)
+29 QUIT
SKIPSTR(NODE,TEST) ; return a string of skipped question identifiers
+1 NEW I,QSTN,CTXT,DLIM,X
+2 SET X=""
+3 SET I=0
FOR
SET I=$ORDER(^XTMP(NODE,3,TEST,"answers",I))
if 'I
QUIT
Begin DoDot:1
+4 IF $GET(^XTMP(NODE,3,TEST,"answers",I,"value"))="NOT ASKED"
Begin DoDot:2
+5 SET QSTN=+$PIECE($GET(^XTMP(NODE,3,TEST,"answers",I,"id")),"q",2)
+6 SET CTXT=$ORDER(^YTT(601.76,"AF",TEST,QSTN,0))
+7 SET DLIM=$PIECE(^YTT(601.76,CTXT,0),U,5)
+8 IF $LENGTH(DLIM)
SET X=X_DLIM_", "
End DoDot:2
End DoDot:1
if $LENGTH(X)>200
QUIT
+9 QUIT X
+10 ;
COMMIT(RSP,TESTNM,DFN,ORDBY,ADMBY,ADMDT,LOC,HWND) ; save completed administration
+1 ; DLL: SaveInstrument(testNm,DFN,OrdBy,AdmBy,AdmDate,LocIEN)
+2 ; input: testName, DFN, orderedBy, interviewer, location, adminDate
+3 ; (use DFN + TESTNM to find the GUID)
+4 ; need to set adminDate so it syncs with the visit
+5 ; update ordBy, admBy, loc if necessary
+6 ; output: returnStatus
+7 ;
+8 NEW GUID,NODE,TEST,DATA,ADMIN
+9 IF '$LENGTH(DFN)!'$LENGTH(ORDBY)!'$LENGTH(ADMBY)!'$LENGTH(ADMDT)!'$LENGTH(LOC)
Begin DoDot:1
+10 SET RSP(1)="ERROR: required fields are missing"
End DoDot:1
QUIT
+11 SET GUID=$PIECE($GET(^XTMP("YTQCPRS-HWND",HWND,DFN,TESTNM)),U)
+12 SET NODE="YTQCPRS-"_GUID
+13 SET TEST=+$ORDER(^YTT(601.71,"B",TESTNM,0))
+14 IF '$DATA(^XTMP(NODE,3,TEST,"answers"))
SET RSP(1)="ERROR: answers not found"
QUIT
+15 IF ^XTMP(NODE,1,"patient","dfn")'=DFN
SET RSP(1)="ERROR: patient mis-match"
QUIT
+16 ; force visit date from CPRS
SET ^XTMP(NODE,1,"date")=ADMDT
SET ^("adminDate")=""
+17 SET ^XTMP(NODE,1,"orderedBy")=ORDBY
+18 SET ^XTMP(NODE,1,"interview")=ADMBY
+19 SET ^XTMP(NODE,1,"location")=+LOC
+20 MERGE DATA=^XTMP(NODE,3,TEST)
+21 SET DATA("source")="cprs-web-dll"
+22 SET DATA("assignmentId")=$PIECE(DATA("adminId"),"-",1,5)
+23 ; so it doesn't get confused with "real" adminId
KILL DATA("adminId")
+24 SET ADMIN=$$QASAVE^YTQRQAD2(.DATA)
+25 IF 'ADMIN
SET RSP(1)="ERROR: admin not created"
QUIT
+26 SET RSP(1)=ADMIN
+27 NEW YSDATA,YS
+28 KILL ^TMP($JOB,"YSCOR")
+29 SET YS("AD")=ADMIN
+30 DO SCORSAVE^YTQAPI11(.YSDATA,.YS)
+31 IF $GET(YSDATA(1))="[ERROR]"
SET RSP(1)="ERROR: "_$GET(YSDATA(2))
QUIT
+32 IF $GET(^TMP($JOB,"YSCOR",1))="[ERROR]"
SET RSP(1)="ERROR: "_$GET(^(2))
QUIT
+33 DO CLEARTST(DFN,TESTNM,HWND)
+34 QUIT
+35 ;
CLEAR(RSP,DFN,TESTNM,HWND) ; remove test data from reminder dialog temporary space
+1 ; DLL: RemoveTempVistaFile(testNm, DFN)
+2 ; input: testName, DFN, handle
+3 ; remove all for DFN if testName=""
+4 ; otherwise remove testName for DFN
+5 SET RSP(1)="OK"
+6 NEW GUID,X
+7 IF $LENGTH(TESTNM)
DO CLEARTST(DFN,TESTNM,HWND)
QUIT
+8 ; clear all scratch instruments for this session if TESTNM=""
+9 SET X=""
FOR
SET X=$ORDER(^XTMP("YTQCPRS-HWND",HWND,DFN,X))
if '$LENGTH(X)
QUIT
Begin DoDot:1
+10 DO CLEARTST(DFN,X,HWND)
End DoDot:1
+11 QUIT
CLEARTST(DFN,TESTNM,HWND) ; for DFN/HWND session, remove specific TESTNM
+1 NEW GUID,NODE,I,TEST
+2 SET GUID=$PIECE($GET(^XTMP("YTQCPRS-HWND",HWND,DFN,TESTNM)),U)
if '$LENGTH(GUID)
QUIT
+3 SET NODE="YTQCPRS-"_GUID
+4 SET I=0
FOR
SET I=$ORDER(^XTMP(NODE,1,"instruments",I))
if 'I
QUIT
Begin DoDot:1
+5 IF ^XTMP(NODE,1,"instruments",I,"name")'=TESTNM
QUIT
+6 ; remove TESTNM assignment
KILL ^XTMP(NODE,1,"instruments",I)
+7 SET TEST=$ORDER(^YTT(601.71,"B",TESTNM,0))
if 'TEST
QUIT
+8 ; remove TESTNM answer set
KILL ^XTMP(NODE,3,TEST)
+9 ; remove index node
KILL ^XTMP("YTQCPRS-HWND",HWND,DFN,TESTNM)
End DoDot:1
+10 ; no tests remaining
IF '$DATA(^XTMP(NODE,1,"instruments"))
KILL ^XTMP(NODE)
+11 QUIT
