ORRDI2 ; SLC/JMH - RDI routine for user interface and data cleanup; 3/24/05 2:31 ; 1/11/07 8:12am
;;3.0;ORDER ENTRY/RESULTS REPORTING;**232**;Dec 17, 1997;Build 19
;
SET ;utility to set RDI related parameters
I '$$PATCH^XPDUTL("OR*3.0*238") D Q
. W !,"This menu is locked until patch OR*3.0*238 is installed."
N QUIT,QUITALL
W !!,"Sets System wide parameters to control order checking against"
W !," remote data",!
F Q:$G(QUIT)!($G(QUITALL)) D
. N VAL,VALEXT,DIR,DTOUT,Y
. S VAL=$$GET^XPAR("SYS","OR RDI HAVE HDR")
. S VALEXT="NO" I VAL=1 S VALEXT="YES"
. S DIR("A")="HAVE AN HDR"
. S DIR("B")=VALEXT
. S DIR("?")="^D HELP1^ORRDI2"
. S DIR(0)="Y"
. D ^DIR
. I $G(Y)="^"!($G(DTOUT)) S QUITALL=1
. I $G(Y)=1!($G(Y)=0) S QUIT=1 D
. . D EN^XPAR("SYS","OR RDI HAVE HDR",,Y)
I $G(QUITALL) Q
I '$$GET^XPAR("SYS","OR RDI HAVE HDR") Q
S QUIT=0
F Q:$G(QUIT)!($G(QUITALL)) D
. N VAL,VALEXT,DIR,DTOUT,Y
. S VAL=$$GET^XPAR("SYS","OR RDI CACHE TIME")
. S VALEXT=$G(VAL,0)
. S DIR("A")="CACHE TIME (Minutes)"
. S DIR("B")=VALEXT
. S DIR("?")="^D HELP3^ORRDI2"
. S DIR(0)="N^0:9999:0"
. D ^DIR
. I $G(Y)="^"!($G(DTOUT)) S QUITALL=1
. I $G(Y)>-1 S QUIT=1 D
. . D EN^XPAR("SYS","OR RDI CACHE TIME",,Y)
Q
HELP1 ;
W "Set this to ""YES"" if this system has an HDR system that"
W !," it uses to access remote data."
Q
HELP3 ;
W "Set this to the number of minutes that the retrieved data is "
W !," to be considered valid for order checking purposes."
Q
LIST ;
W !
W $$GET^XPAR("SYS","OR RDI HAVE HDR")," "
W $$GET^XPAR("SYS","OR RDI CACHE TIME")
Q
CLEANUP ;
N VAL,NOW,THRESH,DOM,DFN,TIME
S VAL=$$GET^XPAR("SYS","OR RDI CACHE TIME")
S NOW=$$NOW^XLFDT
S THRESH=$$FMADD^XLFDT(NOW,,,-VAL)
S DFN=0
F DOM="PSOO","ART" F S DFN=$O(^XTMP("ORRDI",DOM,DFN)) Q:'DFN D
. S TIME=$G(^XTMP("ORRDI",DOM,DFN,0))
. I TIME<THRESH K ^XTMP("ORRDI",DOM,DFN)
; checking if OUTAGE task crashed or hasn't completed successfully
I $$DOWNXVAL D
.I $$FMDIFF^XLFDT($$NOW^XLFDT,$$PINGXVAL,2)>($$PINGPVAL*2) D SPAWN^ORRDI2
Q
PIECEOUT(Y,DATA,DEL) ;
K Y
N I,J,COUNT
S I="",COUNT=0 F S I=$O(DATA(I)) Q:I="" D
. S J=0 F S J=J+1 Q:J>$L(DATA(I),DEL) D
.. I COUNT>0,J=1 S Y(COUNT)=Y(COUNT)_$P(DATA(I),DEL,J) Q
.. S COUNT=COUNT+1,Y(COUNT)=$P(DATA(I),DEL,J)
Q
DOWNRPC(ORY) ;can be used in an RPC to check if RDI is in an OUTAGE state (HDR DOWN)
S ORY=$$DOWNXVAL
Q
DICNPVAL() ;parameter value for dummy patient ICN
Q $$GET^XPAR("ALL","ORRDI DUMMY ICN")
FAILPVAL() ;parameter value for failure threshold
Q $$GET^XPAR("ALL","ORRDI FAIL THRESH")
SUCCPVAL() ;parameter value for success threshold
Q $$GET^XPAR("ALL","ORRDI SUCCEED THRESH")
PINGPVAL() ;parameter value for ping frequency
Q $$GET^XPAR("ALL","ORRDI PING FREQ")
DOWNXVAL() ;xtmp value for OUTAGE state
Q $G(^XTMP("ORRDI","OUTAGE INFO","DOWN"))
FAILXVAL() ;xtmp value for number of failed reads
Q $G(^XTMP("ORRDI","OUTAGE INFO","FAILURES"))
SUCCXVAL() ;xtmp value for number of successful reads
Q $G(^XTMP("ORRDI","OUTAGE INFO","SUCCEEDS"))
PINGXVAL() ;xtmp value for last ping time
Q $G(^XTMP("ORRDI","OUTAGE INFO","DOWN","LAST PING"))
LDPTTVAL(DFN) ;tmp value for if the local data only message has been shown to the user during ordering session
Q $G(^TMP($J,"ORRDI",DFN))
SPAWN ;subroutine to spawn the DOWNTSK task
K ^XTMP("ORRDI","ART"),^XTMP("ORRDI","PSOO")
N ZTDESC,ZTRTN,ZTSAVE,ZTIO,ZTSK,ZTDTH
S ZTDESC="RDI TASK TO CHECK IF HDR IS UP"
S ZTRTN="DOWNTSK^ORRDI2"
S ZTIO=""
S ZTDTH=$$NOW^XLFDT+.000001
D ^%ZTLOAD
Q
DOWNTSK ;subroutine to check if HDR is back up
F Q:(($$SUCCXVAL'<$$SUCCPVAL)!('$$DOWNXVAL)) D
.N WAIT,RSLT
.S WAIT=$$FMDIFF^XLFDT($$NOW^XLFDT,$$PINGXVAL,2)
.S WAIT=$$PINGPVAL-WAIT
.;wait until the proper # of seconds has expired before retrying
.I WAIT>0 H WAIT
.S ^XTMP("ORRDI","OUTAGE INFO","DOWN","LAST PING")=$$NOW^XLFDT
.;send dummy message
.S RSLT=$$TESTCALL
.;if successful increment success counter
.I RSLT S ^XTMP("ORRDI","OUTAGE INFO","SUCCEEDS")=1+$$SUCCXVAL
.;if failure set success counter to 0
.I 'RSLT S ^XTMP("ORRDI","OUTAGE INFO","SUCCEEDS")=0
K ^XTMP("ORRDI","OUTAGE INFO")
Q
TESTCALL() ;call to send a test call to CDS...returns 1 if successful, 0 if not
N START,END,HLL,HLA,ORFS,ORCS,ORRS,ORES,ORSS
N Y,ORRSLT,ICN,WHATOUT,HLNEXT,HLNODE,HLQUIT,ORHLP,RET,HL,HLDOM,HLDONE1,HLECH,HLFS,HLINSTN,HLMTIEN,HLPARAM,HLQ,STATUS,PRE
S (ORFS,ORCS,ORRS,ORES,ORSS)=""
S START=$P($$NOW^XLFDT,".")
;build HLA array with request HL7
S HLA("HLS",1)="SPR^XWBDRPC845-569716_0^T^ZREMOTE RPC^@SPR.4.2~003RPC017ORWRP REPORT TEXT&006RPCVER0010&007XWBPCNT0017&007XWBESSO066321214321\F\\F\\F\657\F"
S HLA("HLS",1,1)="\48102&007XWBDVER0011&006XWBSEC0043.14&002P10187369543;"_$$DICNPVAL_"&002P2039OC_AL:ALLERGIES;1\S\RXOP;ORDV06;28;200&002P3000&002P4000&002P5000&002P600"_$L($G(START))_$G(START)_"&002P700"_$L($G(END))_$G(END)
S HLA("HLS",2)="RDF^1^@DSP.3~TX~300"
;set HLL("LINKS") node to specify receiver location
S HLL("LINKS",1)="ORRDI SUBSCRIBER^ORHDR"
S ORHLP("OPEN TIMEOUT")=10
S ORHLP("SUBSCRIBER")="^OR RDI SENDER^"_$P($$SITE^VASITE,U,3)_"^OR RDI RECEIVER^^^"
;call DIRECT^HLMA to send request
D DIRECT^HLMA("ORRDI EVENT","LM",1,.ORRSLT,,.ORHLP)
;check if call failed
I $P($G(ORRSLT),U,2) Q 0
Q 1
ORRDI2 ; SLC/JMH - RDI routine for user interface and data cleanup; 3/24/05 2:31 ; 1/11/07 8:12am
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**232**;Dec 17, 1997;Build 19
+2 ;
SET ;utility to set RDI related parameters
+1 IF '$$PATCH^XPDUTL("OR*3.0*238")
Begin DoDot:1
+2 WRITE !,"This menu is locked until patch OR*3.0*238 is installed."
End DoDot:1
QUIT
+3 NEW QUIT,QUITALL
+4 WRITE !!,"Sets System wide parameters to control order checking against"
+5 WRITE !," remote data",!
+6 FOR
IF $GET(QUIT)!($GET(QUITALL))
QUIT
Begin DoDot:1
+7 NEW VAL,VALEXT,DIR,DTOUT,Y
+8 SET VAL=$$GET^XPAR("SYS","OR RDI HAVE HDR")
+9 SET VALEXT="NO"
IF VAL=1
SET VALEXT="YES"
+10 SET DIR("A")="HAVE AN HDR"
+11 SET DIR("B")=VALEXT
+12 SET DIR("?")="^D HELP1^ORRDI2"
+13 SET DIR(0)="Y"
+14 DO ^DIR
+15 IF $GET(Y)="^"!($GET(DTOUT))
SET QUITALL=1
+16 IF $GET(Y)=1!($GET(Y)=0)
SET QUIT=1
Begin DoDot:2
+17 DO EN^XPAR("SYS","OR RDI HAVE HDR",,Y)
End DoDot:2
End DoDot:1
+18 IF $GET(QUITALL)
QUIT
+19 IF '$$GET^XPAR("SYS","OR RDI HAVE HDR")
QUIT
+20 SET QUIT=0
+21 FOR
IF $GET(QUIT)!($GET(QUITALL))
QUIT
Begin DoDot:1
+22 NEW VAL,VALEXT,DIR,DTOUT,Y
+23 SET VAL=$$GET^XPAR("SYS","OR RDI CACHE TIME")
+24 SET VALEXT=$GET(VAL,0)
+25 SET DIR("A")="CACHE TIME (Minutes)"
+26 SET DIR("B")=VALEXT
+27 SET DIR("?")="^D HELP3^ORRDI2"
+28 SET DIR(0)="N^0:9999:0"
+29 DO ^DIR
+30 IF $GET(Y)="^"!($GET(DTOUT))
SET QUITALL=1
+31 IF $GET(Y)>-1
SET QUIT=1
Begin DoDot:2
+32 DO EN^XPAR("SYS","OR RDI CACHE TIME",,Y)
End DoDot:2
End DoDot:1
+33 QUIT
HELP1 ;
+1 WRITE "Set this to ""YES"" if this system has an HDR system that"
+2 WRITE !," it uses to access remote data."
+3 QUIT
HELP3 ;
+1 WRITE "Set this to the number of minutes that the retrieved data is "
+2 WRITE !," to be considered valid for order checking purposes."
+3 QUIT
LIST ;
+1 WRITE !
+2 WRITE $$GET^XPAR("SYS","OR RDI HAVE HDR")," "
+3 WRITE $$GET^XPAR("SYS","OR RDI CACHE TIME")
+4 QUIT
CLEANUP ;
+1 NEW VAL,NOW,THRESH,DOM,DFN,TIME
+2 SET VAL=$$GET^XPAR("SYS","OR RDI CACHE TIME")
+3 SET NOW=$$NOW^XLFDT
+4 SET THRESH=$$FMADD^XLFDT(NOW,,,-VAL)
+5 SET DFN=0
+6 FOR DOM="PSOO","ART"
FOR
SET DFN=$ORDER(^XTMP("ORRDI",DOM,DFN))
IF 'DFN
QUIT
Begin DoDot:1
+7 SET TIME=$GET(^XTMP("ORRDI",DOM,DFN,0))
+8 IF TIME<THRESH
KILL ^XTMP("ORRDI",DOM,DFN)
End DoDot:1
+9 ; checking if OUTAGE task crashed or hasn't completed successfully
+10 IF $$DOWNXVAL
Begin DoDot:1
+11 IF $$FMDIFF^XLFDT($$NOW^XLFDT,$$PINGXVAL,2)>($$PINGPVAL*2)
DO SPAWN^ORRDI2
End DoDot:1
+12 QUIT
PIECEOUT(Y,DATA,DEL) ;
+1 KILL Y
+2 NEW I,J,COUNT
+3 SET I=""
SET COUNT=0
FOR
SET I=$ORDER(DATA(I))
IF I=""
QUIT
Begin DoDot:1
+4 SET J=0
FOR
SET J=J+1
IF J>$LENGTH(DATA(I),DEL)
QUIT
Begin DoDot:2
+5 IF COUNT>0
IF J=1
SET Y(COUNT)=Y(COUNT)_$PIECE(DATA(I),DEL,J)
QUIT
+6 SET COUNT=COUNT+1
SET Y(COUNT)=$PIECE(DATA(I),DEL,J)
End DoDot:2
End DoDot:1
+7 QUIT
DOWNRPC(ORY) ;can be used in an RPC to check if RDI is in an OUTAGE state (HDR DOWN)
+1 SET ORY=$$DOWNXVAL
+2 QUIT
DICNPVAL() ;parameter value for dummy patient ICN
+1 QUIT $$GET^XPAR("ALL","ORRDI DUMMY ICN")
FAILPVAL() ;parameter value for failure threshold
+1 QUIT $$GET^XPAR("ALL","ORRDI FAIL THRESH")
SUCCPVAL() ;parameter value for success threshold
+1 QUIT $$GET^XPAR("ALL","ORRDI SUCCEED THRESH")
PINGPVAL() ;parameter value for ping frequency
+1 QUIT $$GET^XPAR("ALL","ORRDI PING FREQ")
DOWNXVAL() ;xtmp value for OUTAGE state
+1 QUIT $GET(^XTMP("ORRDI","OUTAGE INFO","DOWN"))
FAILXVAL() ;xtmp value for number of failed reads
+1 QUIT $GET(^XTMP("ORRDI","OUTAGE INFO","FAILURES"))
SUCCXVAL() ;xtmp value for number of successful reads
+1 QUIT $GET(^XTMP("ORRDI","OUTAGE INFO","SUCCEEDS"))
PINGXVAL() ;xtmp value for last ping time
+1 QUIT $GET(^XTMP("ORRDI","OUTAGE INFO","DOWN","LAST PING"))
LDPTTVAL(DFN) ;tmp value for if the local data only message has been shown to the user during ordering session
+1 QUIT $GET(^TMP($JOB,"ORRDI",DFN))
SPAWN ;subroutine to spawn the DOWNTSK task
+1 KILL ^XTMP("ORRDI","ART"),^XTMP("ORRDI","PSOO")
+2 NEW ZTDESC,ZTRTN,ZTSAVE,ZTIO,ZTSK,ZTDTH
+3 SET ZTDESC="RDI TASK TO CHECK IF HDR IS UP"
+4 SET ZTRTN="DOWNTSK^ORRDI2"
+5 SET ZTIO=""
+6 SET ZTDTH=$$NOW^XLFDT+.000001
+7 DO ^%ZTLOAD
+8 QUIT
DOWNTSK ;subroutine to check if HDR is back up
+1 FOR
IF (($$SUCCXVAL'<$$SUCCPVAL)!('$$DOWNXVAL))
QUIT
Begin DoDot:1
+2 NEW WAIT,RSLT
+3 SET WAIT=$$FMDIFF^XLFDT($$NOW^XLFDT,$$PINGXVAL,2)
+4 SET WAIT=$$PINGPVAL-WAIT
+5 ;wait until the proper # of seconds has expired before retrying
+6 IF WAIT>0
HANG WAIT
+7 SET ^XTMP("ORRDI","OUTAGE INFO","DOWN","LAST PING")=$$NOW^XLFDT
+8 ;send dummy message
+9 SET RSLT=$$TESTCALL
+10 ;if successful increment success counter
+11 IF RSLT
SET ^XTMP("ORRDI","OUTAGE INFO","SUCCEEDS")=1+$$SUCCXVAL
+12 ;if failure set success counter to 0
+13 IF 'RSLT
SET ^XTMP("ORRDI","OUTAGE INFO","SUCCEEDS")=0
End DoDot:1
+14 KILL ^XTMP("ORRDI","OUTAGE INFO")
+15 QUIT
TESTCALL() ;call to send a test call to CDS...returns 1 if successful, 0 if not
+1 NEW START,END,HLL,HLA,ORFS,ORCS,ORRS,ORES,ORSS
+2 NEW Y,ORRSLT,ICN,WHATOUT,HLNEXT,HLNODE,HLQUIT,ORHLP,RET,HL,HLDOM,HLDONE1,HLECH,HLFS,HLINSTN,HLMTIEN,HLPARAM,HLQ,STATUS,PRE
+3 SET (ORFS,ORCS,ORRS,ORES,ORSS)=""
+4 SET START=$PIECE($$NOW^XLFDT,".")
+5 ;build HLA array with request HL7
+6 SET HLA("HLS",1)="SPR^XWBDRPC845-569716_0^T^ZREMOTE RPC^@SPR.4.2~003RPC017ORWRP REPORT TEXT&006RPCVER0010&007XWBPCNT0017&007XWBESSO066321214321\F\\F\\F\657\F"
+7 SET HLA("HLS",1,1)="\48102&007XWBDVER0011&006XWBSEC0043.14&002P10187369543;"_$$DICNPVAL_"&002P2039OC_AL:ALLERGIES;1\S\RXOP;ORDV06;28;200&002P3000&002P4000&002P5000&002P600"_$L($GET(START))_$GET(START)_"&002P700"_$LENGTH($GET(END))_$GET(END)
+8 SET HLA("HLS",2)="RDF^1^@DSP.3~TX~300"
+9 ;set HLL("LINKS") node to specify receiver location
+10 SET HLL("LINKS",1)="ORRDI SUBSCRIBER^ORHDR"
+11 SET ORHLP("OPEN TIMEOUT")=10
+12 SET ORHLP("SUBSCRIBER")="^OR RDI SENDER^"_$PIECE($$SITE^VASITE,U,3)_"^OR RDI RECEIVER^^^"
+13 ;call DIRECT^HLMA to send request
+14 DO DIRECT^HLMA("ORRDI EVENT","LM",1,.ORRSLT,,.ORHLP)
+15 ;check if call failed
+16 IF $PIECE($GET(ORRSLT),U,2)
QUIT 0
+17 QUIT 1
