MDRPCOG ; HOIFO/DP - CP Gateway ; [01-09-2003 15:20]
;;1.0;CLINICAL PROCEDURES;**6**;Apr 01, 2004;Build 102
; Description:
; This is the main routine that manages the CLINICAL PROCEDURES Gateway functions.
; Access to these functions is controlled via the MD GATEWAY RPC.
;
; Integration Agreements:
; IA# 10097 [Supported] %ZOSV calls
; IA# 10103 [Supported] Calls to XLFDT
; IA# 2263 [Supported] Calls to XPAR
;
CLEANUP ; [Procedure] Cleanup a past results report
F X=0:0 S X=$O(^MDD(703.1,DATA,.1,X)) Q:'X D
.S:$G(^MDD(703.1,DATA,.1,X,.1))]"" MDFDA(703.11,X_","_DATA_",",.1)="@"
.S:$O(^MDD(703.1,DATA,.1,X,.2,0)) MDFDA(703.11,X_","_DATA_",",.2)="@"
D:$D(MDFDA) FILE^DIE("K","MDFDA","MDERR")
I $D(MDERR) D ERROR^MDRPCU(RESULTS,.MDERR) Q
; Manual cleanup of the empty UNC nodes and WP root
F X=0:0 S X=$O(^MDD(703.1,DATA,.1,X)) Q:'X D
.K ^MDD(703.1,DATA,.1,X,.1)
.K ^MDD(703.1,DATA,.1,X,.2)
S @RESULTS@(0)="1^Item purged"
Q
;
DONE ; [Procedure] Done processing, Mark study status
S MDFDA(703.1,+DATA_",",.09)=$G(P1,"U")
D FILE^DIE("","MDFDA")
Q
;
GETATT ; [Procedure] Get attachments for study
F X=0:0 S X=$O(^MDD(703.1,+DATA,.1,X)) Q:'X D
.S Y=+$O(@RESULTS@(""),-1)+1
.S @RESULTS@(Y)="703.11;"_X_U_^MDD(703.1,+DATA,.1,X,0)
S @RESULTS@(0)=+$O(@RESULTS@(""),-1)
Q
;
GETOLD ; [Procedure] Returns old results by date
; Variables:
; LOGDATE: [Private] Loop variable
; STOPDATE: [Private] Date to stop retrieving entries
;
; New private variables
NEW LOGDATE,STOPDATE,MDX
S LOGDATE=+DATA,STOPDATE=+$P(DATA,U,2)+.2359
F S LOGDATE=$O(^MDD(703.1,"ADTP",LOGDATE)) W !,"-->",LOGDATE Q:'LOGDATE!(LOGDATE>STOPDATE) D Q:Y>50
.F MDX=0:0 S MDX=$O(^MDD(703.1,"ADTP",LOGDATE,MDX)) Q:'MDX D
..I '$$CHECK(MDX) Q
..S Y=$O(@RESULTS@(""),-1)+1
..S @RESULTS@(Y)="703.1;"_MDX_U_$G(^MDD(703.1,MDX,0))
S:'LOGDATE!(LOGDATE>STOPDATE) LOGDATE=STOPDATE
S @RESULTS@(0)=+$O(@RESULTS@(""),-1)_U_LOGDATE_U_$$FMTE^XLFDT(LOGDATE)
Q
;
GETPAR ; [Procedure] Get a parameter value for an RPC Call
S @RESULTS@(0)=$$PARVAL(DATA)
Q
;
GETTXT ; [Procedure] Get attachment text for processing
N X,STUDY,ATT
S X=0,STUDY=$P(DATA,",",2),ATT=+DATA
I '$O(^MDD(703.1,STUDY,.1,ATT,.2,0)) S @RESULTS@(0)="-1^No Data" Q
F S X=$O(^MDD(703.1,STUDY,.1,ATT,.2,X)) Q:'X S @RESULTS@(X)=^(X,0)
S @RESULTS@(0)=+$O(@RESULTS@(""),-1)
Q
;
NEXT ; [Procedure] Get the next study to process
S Y=+$O(^MDD(703.1,"ASTATUS","P",$G(DATA)))
S @RESULTS@(0)=$S($D(^MDD(703.1,Y,0)):"703.1;"_Y_U_^MDD(703.1,Y,0),1:0)
Q
;
PARVAL(INSTANCE) ; [Procedure] Extrinsic get of parameter values
; Input parameters
; 1. INSTANCE [Literal/Required] XPAR instance
;
Q $$GET^XPAR("SYS","MD GATEWAY",INSTANCE)
;
POLL ; [Procedure] Returns server time and flag for studies to process
I $$PARVAL("Shutdown Flag")]"" D Q
.S @RESULTS@(0)="-1^SHUTDOWN"
.D SETPAR("Shutdown Flag","")
S @RESULTS@(0)=$$FMTE^XLFDT($$NOW^XLFDT)
S @RESULTS@(1)=$D(^MDD(703.1,"ASTATUS","P"))
Q
;
POLLER(RESULTS) ; [Procedure] Non-Disk activity poller
; With the exception of a shutdown request pending, this stand alone RPC will operate
; without creating any disk activity and not crash during backup operations on the main
; VistA server.
;
; Input parameters
; 1. RESULTS [Reference/Required]
;
I $$PARVAL("Shutdown Flag")]"" D Q
.S RESULTS(0)="-1^SHUTDOWN"
.D SETPAR("Shutdown Flag","")
S RESULTS(0)=$$FMTE^XLFDT($$NOW^XLFDT)
S RESULTS(1)=$D(^MDD(703.1,"ASTATUS","P"))
Q
;
RPC(RESULTS,OPTION,DATA,P1) ; [Procedure]
; Input parameters
; 1. RESULTS [Literal/Required] RPC Return Array
; 2. OPTION [Literal/Required] Gateway Option to execute
; 3. DATA [Literal/Required] Other information
; 4. P1 [Literal/Required] Overflow variable
;
; Variables:
; MDENV: [Private] Server environment variable
; MDERR: [Private] Fileman return array
; MDFDA: [Private] Fileman FDA
;
; New private variables
NEW MDENV,MDERR,MDFDA
S RESULTS=$NA(^TMP("MDRPCOB",$J)) K @RESULTS
D @OPTION
Q
;
RUNNING ; [Procedure] Returns 0/1 and message on running status
; Note: If lock CAN be obtained, then gateway is NOT running
L +^MDD("CPGATEWAY"):1 E S @RESULTS@(0)="1^RUNNING" Q
L -(^MDD("CPGATEWAY")) S @RESULTS@(0)="0^NOT RUNNING"
Q
;
SETFILE ; [Procedure] Set filename of new attachment
S MDFDA(703.11,$P(DATA,U,1),.02)=$P(DATA,U,2)
D FILE^DIE("","MDFDA")
Q
;
SETPAR(INSTANCE,VALUE) ; [Procedure] Set value into XPAR parameter
; Input parameters
; 1. INSTANCE [Literal/Required] Parameter Instance
; 2. VALUE [Literal/Required] Parameter Value
;
D EN^XPAR("SYS","MD GATEWAY",INSTANCE,VALUE)
Q
;
START ; [Procedure] Can we begin?
; Ensure only one Gateway per system by locking the phantom global node
L +^MDD("CPGATEWAY"):1
I '$T D STATUS S @RESULTS@(0)="-1^FAIL" Q
; Clear all process settings
D NDEL^XPAR("SYS","MD GATEWAY")
S DATA=$G(DATA,"30^1000") ; Default poll interval and log entries
D SETPAR("Polling Interval",+$P(DATA,U,1))
D SETPAR("Maximum Log Entries",+$P(DATA,U,2))
D SETPAR("Job ID",$J)
D SETPAR("Started At",$$FMTE^XLFDT($$NOW^XLFDT))
D SETPAR("Started By",$$GET1^DIQ(200,DUZ_",",.01))
D GETENV^%ZOSV S MDENV=Y
D SETPAR("UCI",$P(MDENV,U,1))
D SETPAR("Volume",$P(MDENV,U,2))
D SETPAR("Node",$P(MDENV,U,3))
D SETNM^%ZOSV("CP Gateway")
S @RESULTS@(0)="1^OK"
Q
;
STATUS ; [Procedure] Return status of BP
D GETLST^XPAR(.MDRET,"SYS","MD GATEWAY","Q")
F X=0:0 S X=$O(MDRET(X)) Q:'X S @RESULTS@(X)=MDRET(X)
Q
;
STOP ; [Procedure] Flag client to stop via cal to POLL
D SETPAR("Shutdown Flag","Yes")
Q
;
XFERDIR ; [Procedure] Return Imaging xfer directory
S @RESULTS@(0)=$$GET^XPAR("SYS","MD IMAGING XFER")
Q
;
CHECK(MDRI) ; Check if Upload Value and Upload Text has already been purged.
N MDFLG S MDFLG=0
F X=0:0 S X=$O(^MDD(703.1,MDRI,.1,X)) Q:'X D Q:MDFLG
.S:$G(^MDD(703.1,MDRI,.1,X,.1))]"" MDFLG=1
.S:$O(^MDD(703.1,MDRI,.1,X,.2,0)) MDFLG=1
Q MDFLG
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMDRPCOG 6083 printed Sep 23, 2025@19:20:03 Page 2
MDRPCOG ; HOIFO/DP - CP Gateway ; [01-09-2003 15:20]
+1 ;;1.0;CLINICAL PROCEDURES;**6**;Apr 01, 2004;Build 102
+2 ; Description:
+3 ; This is the main routine that manages the CLINICAL PROCEDURES Gateway functions.
+4 ; Access to these functions is controlled via the MD GATEWAY RPC.
+5 ;
+6 ; Integration Agreements:
+7 ; IA# 10097 [Supported] %ZOSV calls
+8 ; IA# 10103 [Supported] Calls to XLFDT
+9 ; IA# 2263 [Supported] Calls to XPAR
+10 ;
CLEANUP ; [Procedure] Cleanup a past results report
+1 FOR X=0:0
SET X=$ORDER(^MDD(703.1,DATA,.1,X))
if 'X
QUIT
Begin DoDot:1
+2 if $GET(^MDD(703.1,DATA,.1,X,.1))]""
SET MDFDA(703.11,X_","_DATA_",",.1)="@"
+3 if $ORDER(^MDD(703.1,DATA,.1,X,.2,0))
SET MDFDA(703.11,X_","_DATA_",",.2)="@"
End DoDot:1
+4 if $DATA(MDFDA)
DO FILE^DIE("K","MDFDA","MDERR")
+5 IF $DATA(MDERR)
DO ERROR^MDRPCU(RESULTS,.MDERR)
QUIT
+6 ; Manual cleanup of the empty UNC nodes and WP root
+7 FOR X=0:0
SET X=$ORDER(^MDD(703.1,DATA,.1,X))
if 'X
QUIT
Begin DoDot:1
+8 KILL ^MDD(703.1,DATA,.1,X,.1)
+9 KILL ^MDD(703.1,DATA,.1,X,.2)
End DoDot:1
+10 SET @RESULTS@(0)="1^Item purged"
+11 QUIT
+12 ;
DONE ; [Procedure] Done processing, Mark study status
+1 SET MDFDA(703.1,+DATA_",",.09)=$GET(P1,"U")
+2 DO FILE^DIE("","MDFDA")
+3 QUIT
+4 ;
GETATT ; [Procedure] Get attachments for study
+1 FOR X=0:0
SET X=$ORDER(^MDD(703.1,+DATA,.1,X))
if 'X
QUIT
Begin DoDot:1
+2 SET Y=+$ORDER(@RESULTS@(""),-1)+1
+3 SET @RESULTS@(Y)="703.11;"_X_U_^MDD(703.1,+DATA,.1,X,0)
End DoDot:1
+4 SET @RESULTS@(0)=+$ORDER(@RESULTS@(""),-1)
+5 QUIT
+6 ;
GETOLD ; [Procedure] Returns old results by date
+1 ; Variables:
+2 ; LOGDATE: [Private] Loop variable
+3 ; STOPDATE: [Private] Date to stop retrieving entries
+4 ;
+5 ; New private variables
+6 NEW LOGDATE,STOPDATE,MDX
+7 SET LOGDATE=+DATA
SET STOPDATE=+$PIECE(DATA,U,2)+.2359
+8 FOR
SET LOGDATE=$ORDER(^MDD(703.1,"ADTP",LOGDATE))
WRITE !,"-->",LOGDATE
if 'LOGDATE!(LOGDATE>STOPDATE)
QUIT
Begin DoDot:1
+9 FOR MDX=0:0
SET MDX=$ORDER(^MDD(703.1,"ADTP",LOGDATE,MDX))
if 'MDX
QUIT
Begin DoDot:2
+10 IF '$$CHECK(MDX)
QUIT
+11 SET Y=$ORDER(@RESULTS@(""),-1)+1
+12 SET @RESULTS@(Y)="703.1;"_MDX_U_$GET(^MDD(703.1,MDX,0))
End DoDot:2
End DoDot:1
if Y>50
QUIT
+13 if 'LOGDATE!(LOGDATE>STOPDATE)
SET LOGDATE=STOPDATE
+14 SET @RESULTS@(0)=+$ORDER(@RESULTS@(""),-1)_U_LOGDATE_U_$$FMTE^XLFDT(LOGDATE)
+15 QUIT
+16 ;
GETPAR ; [Procedure] Get a parameter value for an RPC Call
+1 SET @RESULTS@(0)=$$PARVAL(DATA)
+2 QUIT
+3 ;
GETTXT ; [Procedure] Get attachment text for processing
+1 NEW X,STUDY,ATT
+2 SET X=0
SET STUDY=$PIECE(DATA,",",2)
SET ATT=+DATA
+3 IF '$ORDER(^MDD(703.1,STUDY,.1,ATT,.2,0))
SET @RESULTS@(0)="-1^No Data"
QUIT
+4 FOR
SET X=$ORDER(^MDD(703.1,STUDY,.1,ATT,.2,X))
if 'X
QUIT
SET @RESULTS@(X)=^(X,0)
+5 SET @RESULTS@(0)=+$ORDER(@RESULTS@(""),-1)
+6 QUIT
+7 ;
NEXT ; [Procedure] Get the next study to process
+1 SET Y=+$ORDER(^MDD(703.1,"ASTATUS","P",$GET(DATA)))
+2 SET @RESULTS@(0)=$SELECT($DATA(^MDD(703.1,Y,0)):"703.1;"_Y_U_^MDD(703.1,Y,0),1:0)
+3 QUIT
+4 ;
PARVAL(INSTANCE) ; [Procedure] Extrinsic get of parameter values
+1 ; Input parameters
+2 ; 1. INSTANCE [Literal/Required] XPAR instance
+3 ;
+4 QUIT $$GET^XPAR("SYS","MD GATEWAY",INSTANCE)
+5 ;
POLL ; [Procedure] Returns server time and flag for studies to process
+1 IF $$PARVAL("Shutdown Flag")]""
Begin DoDot:1
+2 SET @RESULTS@(0)="-1^SHUTDOWN"
+3 DO SETPAR("Shutdown Flag","")
End DoDot:1
QUIT
+4 SET @RESULTS@(0)=$$FMTE^XLFDT($$NOW^XLFDT)
+5 SET @RESULTS@(1)=$DATA(^MDD(703.1,"ASTATUS","P"))
+6 QUIT
+7 ;
POLLER(RESULTS) ; [Procedure] Non-Disk activity poller
+1 ; With the exception of a shutdown request pending, this stand alone RPC will operate
+2 ; without creating any disk activity and not crash during backup operations on the main
+3 ; VistA server.
+4 ;
+5 ; Input parameters
+6 ; 1. RESULTS [Reference/Required]
+7 ;
+8 IF $$PARVAL("Shutdown Flag")]""
Begin DoDot:1
+9 SET RESULTS(0)="-1^SHUTDOWN"
+10 DO SETPAR("Shutdown Flag","")
End DoDot:1
QUIT
+11 SET RESULTS(0)=$$FMTE^XLFDT($$NOW^XLFDT)
+12 SET RESULTS(1)=$DATA(^MDD(703.1,"ASTATUS","P"))
+13 QUIT
+14 ;
RPC(RESULTS,OPTION,DATA,P1) ; [Procedure]
+1 ; Input parameters
+2 ; 1. RESULTS [Literal/Required] RPC Return Array
+3 ; 2. OPTION [Literal/Required] Gateway Option to execute
+4 ; 3. DATA [Literal/Required] Other information
+5 ; 4. P1 [Literal/Required] Overflow variable
+6 ;
+7 ; Variables:
+8 ; MDENV: [Private] Server environment variable
+9 ; MDERR: [Private] Fileman return array
+10 ; MDFDA: [Private] Fileman FDA
+11 ;
+12 ; New private variables
+13 NEW MDENV,MDERR,MDFDA
+14 SET RESULTS=$NAME(^TMP("MDRPCOB",$JOB))
KILL @RESULTS
+15 DO @OPTION
+16 QUIT
+17 ;
RUNNING ; [Procedure] Returns 0/1 and message on running status
+1 ; Note: If lock CAN be obtained, then gateway is NOT running
+2 LOCK +^MDD("CPGATEWAY"):1
IF '$TEST
SET @RESULTS@(0)="1^RUNNING"
QUIT
+3 LOCK -(^MDD("CPGATEWAY"))
SET @RESULTS@(0)="0^NOT RUNNING"
+4 QUIT
+5 ;
SETFILE ; [Procedure] Set filename of new attachment
+1 SET MDFDA(703.11,$PIECE(DATA,U,1),.02)=$PIECE(DATA,U,2)
+2 DO FILE^DIE("","MDFDA")
+3 QUIT
+4 ;
SETPAR(INSTANCE,VALUE) ; [Procedure] Set value into XPAR parameter
+1 ; Input parameters
+2 ; 1. INSTANCE [Literal/Required] Parameter Instance
+3 ; 2. VALUE [Literal/Required] Parameter Value
+4 ;
+5 DO EN^XPAR("SYS","MD GATEWAY",INSTANCE,VALUE)
+6 QUIT
+7 ;
START ; [Procedure] Can we begin?
+1 ; Ensure only one Gateway per system by locking the phantom global node
+2 LOCK +^MDD("CPGATEWAY"):1
+3 IF '$TEST
DO STATUS
SET @RESULTS@(0)="-1^FAIL"
QUIT
+4 ; Clear all process settings
+5 DO NDEL^XPAR("SYS","MD GATEWAY")
+6 ; Default poll interval and log entries
SET DATA=$GET(DATA,"30^1000")
+7 DO SETPAR("Polling Interval",+$PIECE(DATA,U,1))
+8 DO SETPAR("Maximum Log Entries",+$PIECE(DATA,U,2))
+9 DO SETPAR("Job ID",$JOB)
+10 DO SETPAR("Started At",$$FMTE^XLFDT($$NOW^XLFDT))
+11 DO SETPAR("Started By",$$GET1^DIQ(200,DUZ_",",.01))
+12 DO GETENV^%ZOSV
SET MDENV=Y
+13 DO SETPAR("UCI",$PIECE(MDENV,U,1))
+14 DO SETPAR("Volume",$PIECE(MDENV,U,2))
+15 DO SETPAR("Node",$PIECE(MDENV,U,3))
+16 DO SETNM^%ZOSV("CP Gateway")
+17 SET @RESULTS@(0)="1^OK"
+18 QUIT
+19 ;
STATUS ; [Procedure] Return status of BP
+1 DO GETLST^XPAR(.MDRET,"SYS","MD GATEWAY","Q")
+2 FOR X=0:0
SET X=$ORDER(MDRET(X))
if 'X
QUIT
SET @RESULTS@(X)=MDRET(X)
+3 QUIT
+4 ;
STOP ; [Procedure] Flag client to stop via cal to POLL
+1 DO SETPAR("Shutdown Flag","Yes")
+2 QUIT
+3 ;
XFERDIR ; [Procedure] Return Imaging xfer directory
+1 SET @RESULTS@(0)=$$GET^XPAR("SYS","MD IMAGING XFER")
+2 QUIT
+3 ;
CHECK(MDRI) ; Check if Upload Value and Upload Text has already been purged.
+1 NEW MDFLG
SET MDFLG=0
+2 FOR X=0:0
SET X=$ORDER(^MDD(703.1,MDRI,.1,X))
if 'X
QUIT
Begin DoDot:1
+3 if $GET(^MDD(703.1,MDRI,.1,X,.1))]""
SET MDFLG=1
+4 if $ORDER(^MDD(703.1,MDRI,.1,X,.2,0))
SET MDFLG=1
End DoDot:1
if MDFLG
QUIT
+5 QUIT MDFLG
