Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: YTQRCRD

YTQRCRD.m

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