MDRPCOO ; HOIFO/DP - Object RPCs (TMDOutput) ; [03-24-2003 15:44]
;;1.0;CLINICAL PROCEDURES;;Apr 01, 2004
; Integration Agreements:
; IA# 2263 [Supported] Kernel Parameter APIs.
; IA# 2541 [Supported] API to get some Kernel System Parameter fields.
; IA# 2320 [Supported] %ZISH entry points.
;
ANALYZE ; [Procedure] Analyze an insturment interface
; Checks the CP instrument file for completeness of an entry.
; Special Note, variable RTN actually contains the IEN of the
; entry.
;
; Variables:
; MDTMP: [Private] Scratch
;
; New private variables
NEW MDTMP
D INST^MDHL7U2(RTN,.MDTMP)
S @RESULTS@(0)=MDTMP_U_MDTMP(0)
F X=0:0 S X=$O(MDTMP(X)) Q:X="" D
.S @RESULTS@(X)=MDTMP(X)
Q
;
DIQ(DD,IENS) ; [Procedure] Gather data about an entry
; Input parameters
; 1. DD [Literal/Required] DDNumber
; 2. IENS [Literal/Required] IENS of entry to retrieve
;
K ^TMP($J)
D GETS^DIQ(DD,IENS,"*","",$NA(^TMP($J)))
Q
;
EXECUTE ; [Procedure] Execute the output
D INIT
D HFSOPEN("TMDOUTPUT")
I POP S @RESULTS@(0)="-1^Unable to open HFS Device" Q
U IO D @RTN
D HFSCLOSE("TMDOUTPUT")
D EXIT
Q
;
EXIT ; [Procedure] Cleanup
K ^TMP("DILIST",$J),^TMP($J)
Q
;
HFSCLOSE(HANDLE) ; [Procedure]
; Input parameters
; 1. HANDLE [Literal/Required] File Handle
;
; Variables:
; MDDEL: [Private] Deletion array for Kernel
; MDDIR: [Private] Holds VistA scratch directory
; MDFILE: [Private] Unique filename
;
; New private variables
NEW MDDEL,MDDIR,MDFILE
D CLOSE^%ZISH(HANDLE)
K @RESULTS
S MDDIR=$$GET^XPAR("DIV","MD HFS SCRATCH")
S MDFILE="MD"_DUZ_".DAT",MDDEL(MDFILE)=""
S X=$$FTG^%ZISH(MDDIR,MDFILE,$NAME(@RESULTS@(1)),3)
S Y=$O(@RESULTS@(""),-1)+1,@RESULTS@(Y)="[End of Report]"
S X=$$DEL^%ZISH(MDDIR,$NA(MDDEL))
Q
;
HFSOPEN(HANDLE) ; [Procedure] Open Host File for output
; Input parameters
; 1. HANDLE [Literal/Required] File Handle
;
; Variables:
; MDDIR: [Private] VistA scratch directory
; MDFILE: [Private] Unique file name
;
; New private variables
NEW MDDIR,MDFILE
S MDDIR=$$GET^XPAR("DIV","MD HFS SCRATCH")
S MDFILE="MD"_DUZ_".DAT"
D OPEN^%ZISH(HANDLE,MDDIR,MDFILE,"W") Q:POP
Q
;
INIT ; [Procedure] Cleanup environment before starting
K ^TMP("DILIST",$J),^TMP($J)
Q
;
INST(IEN) ; [Procedure] Display Instrument
; Input parameters
; 1. IEN [Literal/Required] Instrument IEN or * for all
;
; Variables:
; MDDX: [Private] Scratch counter
;
; New private variables
NEW MDDX
I $G(IEN,"*")="*" D Q
.W "NAME",?20,"PRINT NAME",?40,"SERIAL #",?50,"M RTN",?60,"PKG",?72,"ACTIVE"
.D LIST^DIC(702.09,"","@;.01;.06;.08;.11;.12;.09","P")
.F X=0:0 S X=$O(^TMP("DILIST",$J,X)) Q:'X S MDDX=$G(^(X,0)) D
..W !,$$EXT($P(MDDX,U,2),18),?20,$E($P(MDDX,U,3),1,18),?40,$P(MDDX,U,4),?50,$P(MDDX,U,5),?60,$P(MDDX,U,6),?72,$P(MDDX,U,7)
D DIQ(702.09,IEN_",")
W $$LINE(702.09,IEN_",",.01,0,1),!!
S X=.01 F S X=$O(^TMP($J,702.09,IEN_",",X)) Q:'X D
.W !,$$LINE(702.09,IEN_",",X,30,1)
Q
;
LINE(DD,IENS,FIELD,COL,TITLE) ; [Procedure] Display a default line of a field loaded from DIQ above
; Input parameters
; 1. DD [Literal/Required] DD Number
; 2. IENS [Literal/Required] Record IENS
; 3. FIELD [Literal/Required] Field number
; 4. COL [Literal/Required] Column for data
; 5. TITLE [Literal/Required] Use FileMan TITLE:1 or LABEL:0
;
Q:'$$VFIELD^DILFD(DD,FIELD) ""
W:$X>1 !
W $S($G(TITLE):$$GET1^DID(DD,FIELD,"","TITLE"),1:$$GET1^DID(DD,FIELD,"","LABEL"))
W ": ",?($G(COL,0)),$S(^TMP($J,DD,IENS,FIELD)]"":^(FIELD),1:"<Blank>")
Q ""
;
PAR ; [Procedure] Display System Parameters
; Variables:
; MD: [Private] Scratch
; MDLST: [Private] Scratch
; MDMULT: [Private] Scratch
; MDPAR: [Private] Scratch
; MDWP: [Private] Scratch
;
; New private variables
NEW MD,MDLST,MDMULT,MDPAR,MDWP
W "System Parameters For: ",$$KSP^XUPARAM("WHERE")
D RPC^MDRPCOV(.X,"PARLST","SYS")
F MD=0:0 S MD=$O(^TMP($J,MD)) Q:'MD D
.S MDPAR=$P(^TMP($J,MD),U,2)
.S MDMULT=($P(^TMP($J,MD),U,5)="Yes")
.S MDWP=($P(^TMP($J,MD),U,4)="word processing")
.W !!,"Parameter: ",MDPAR
.W ?55,"Type: ",$P(^TMP($J,MD),U,4)
.W !,"Description: ",$P(^TMP($J,MD),U,3)
.W ?55,"Multiple: ",$P(^TMP($J,MD),U,5)
.D:'MDMULT ; Not Multiple
..I 'MDWP W !," Value: ",$$GET^XPAR("SYS",MDPAR,,"E") Q
..K MDWP D GETWP^XPAR(.MDWP,"SYS",MDPAR,1) D
...W !,"WP-Text:"
...F X=0:0 S X=$O(MDWP(X)) Q:'X W !?2,MDWP(X,0)
.D:MDMULT ; Multiple Instances
..D:'MDWP
...W !,?2,"Values:"
...D GETLST^XPAR(.MDLST,"SYS",MDPAR,"E")
...F X=0:0 S X=$O(MDLST(X)) Q:'X D
....W !?2,$P(MDLST(X),"^",1)
....W ?30,"= ",$P(MDLST(X),U,2)
....;W !!," Instance: ",$P(MDLST(X),"^",1)
....;W !," Value: ",$P(MDLST(X),U,2)
K ^TMP($J)
Q
;
PROC(IEN) ; [Procedure] Display a procedure
; Input parameters
; 1. IEN [Literal/Required] Procedure IEN or * for all
;
I $G(IEN,"*")="*" D Q
.W "NAME",?32,"TREATING SPECIALTY",?54,"TIU NOTE",?76,"LOCATION",?98,"ACTIVE",?108,"EXT DATA"
.D LIST^DIC(702.01,"","@;.01;.02;.04;.05;.09;.03","P")
.F X=0:0 S X=$O(^TMP("DILIST",$J,X)) Q:'X D
..; Naked refs below are from ^TMP("DILIST",$J,X)
..W !,$$EXT($P(^(X,0),U,2),30)
..W ?32,$$EXT($P(^(0),U,3),20)
..W ?54,$$EXT($P(^(0),U,4),20)
..W ?76,$$EXT($P(^(0),U,5),20)
..W ?98,$P(^(0),U,6)
..W ?108,$P(^(0),U,7)
D DIQ(702.01,IEN_",")
W $$LINE(702.01,IEN_",",.01,0,1),!
S X=.01 F S X=$O(^TMP($J,702.01,IEN_",",X)) Q:'X D
.W !,$$LINE(702.01,IEN_",",X,32,1)
K ^TMP("DILIST",$J),^TMP($J)
W !!,"Associated Instruments",!,$TR($J("",30)," ","-"),!
D LIST^DIC(702.011,","_IEN_",",.01,"P")
I '$O(^TMP("DILIST",$J,0)) W ?5,"<None>"
E F X=0:0 S X=$O(^TMP("DILIST",$J,X)) Q:'X W $P(^(X,0),U,2),!
K ^TMP("DILIST",$J)
Q
;
RPC(RESULTS,OPTION,RTN) ; [Procedure] Main RPC for TMD_Output Object
; RPC: [MD TMDOUTPUT]
;
; Input parameters
; 1. RESULTS [Literal/Required] RPC Return Array
; 2. OPTION [Literal/Required] Option to execute
; 3. RTN [Literal/Required] Routine to execute
;
S RESULTS=$NA(^TMP("MD",$J)) K @RESULTS
I $T(@OPTION)]"" D @OPTION
D:'$D(@RESULTS) BADRPC^MDRPCU("MD TMDOUTPUT","MDRPCOO",OPTION)
D CLEAN^DILF
Q
;
EXT(VALUE,LENGTH) ; [Function] $Extract with ... trailer
; Input parameters
; 1. VALUE [Literal/Required] Value to truncate
; 2. LENGTH [Literal/Required] Result length
;
I $L(VALUE)>LENGTH S VALUE=$E(VALUE,1,LENGTH-3)_"..."
Q VALUE
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMDRPCOO 6538 printed Apr 09, 2024@20:48:29 Page 2
MDRPCOO ; HOIFO/DP - Object RPCs (TMDOutput) ; [03-24-2003 15:44]
+1 ;;1.0;CLINICAL PROCEDURES;;Apr 01, 2004
+2 ; Integration Agreements:
+3 ; IA# 2263 [Supported] Kernel Parameter APIs.
+4 ; IA# 2541 [Supported] API to get some Kernel System Parameter fields.
+5 ; IA# 2320 [Supported] %ZISH entry points.
+6 ;
ANALYZE ; [Procedure] Analyze an insturment interface
+1 ; Checks the CP instrument file for completeness of an entry.
+2 ; Special Note, variable RTN actually contains the IEN of the
+3 ; entry.
+4 ;
+5 ; Variables:
+6 ; MDTMP: [Private] Scratch
+7 ;
+8 ; New private variables
+9 NEW MDTMP
+10 DO INST^MDHL7U2(RTN,.MDTMP)
+11 SET @RESULTS@(0)=MDTMP_U_MDTMP(0)
+12 FOR X=0:0
SET X=$ORDER(MDTMP(X))
if X=""
QUIT
Begin DoDot:1
+13 SET @RESULTS@(X)=MDTMP(X)
End DoDot:1
+14 QUIT
+15 ;
DIQ(DD,IENS) ; [Procedure] Gather data about an entry
+1 ; Input parameters
+2 ; 1. DD [Literal/Required] DDNumber
+3 ; 2. IENS [Literal/Required] IENS of entry to retrieve
+4 ;
+5 KILL ^TMP($JOB)
+6 DO GETS^DIQ(DD,IENS,"*","",$NAME(^TMP($JOB)))
+7 QUIT
+8 ;
EXECUTE ; [Procedure] Execute the output
+1 DO INIT
+2 DO HFSOPEN("TMDOUTPUT")
+3 IF POP
SET @RESULTS@(0)="-1^Unable to open HFS Device"
QUIT
+4 USE IO
DO @RTN
+5 DO HFSCLOSE("TMDOUTPUT")
+6 DO EXIT
+7 QUIT
+8 ;
EXIT ; [Procedure] Cleanup
+1 KILL ^TMP("DILIST",$JOB),^TMP($JOB)
+2 QUIT
+3 ;
HFSCLOSE(HANDLE) ; [Procedure]
+1 ; Input parameters
+2 ; 1. HANDLE [Literal/Required] File Handle
+3 ;
+4 ; Variables:
+5 ; MDDEL: [Private] Deletion array for Kernel
+6 ; MDDIR: [Private] Holds VistA scratch directory
+7 ; MDFILE: [Private] Unique filename
+8 ;
+9 ; New private variables
+10 NEW MDDEL,MDDIR,MDFILE
+11 DO CLOSE^%ZISH(HANDLE)
+12 KILL @RESULTS
+13 SET MDDIR=$$GET^XPAR("DIV","MD HFS SCRATCH")
+14 SET MDFILE="MD"_DUZ_".DAT"
SET MDDEL(MDFILE)=""
+15 SET X=$$FTG^%ZISH(MDDIR,MDFILE,$NAME(@RESULTS@(1)),3)
+16 SET Y=$ORDER(@RESULTS@(""),-1)+1
SET @RESULTS@(Y)="[End of Report]"
+17 SET X=$$DEL^%ZISH(MDDIR,$NAME(MDDEL))
+18 QUIT
+19 ;
HFSOPEN(HANDLE) ; [Procedure] Open Host File for output
+1 ; Input parameters
+2 ; 1. HANDLE [Literal/Required] File Handle
+3 ;
+4 ; Variables:
+5 ; MDDIR: [Private] VistA scratch directory
+6 ; MDFILE: [Private] Unique file name
+7 ;
+8 ; New private variables
+9 NEW MDDIR,MDFILE
+10 SET MDDIR=$$GET^XPAR("DIV","MD HFS SCRATCH")
+11 SET MDFILE="MD"_DUZ_".DAT"
+12 DO OPEN^%ZISH(HANDLE,MDDIR,MDFILE,"W")
if POP
QUIT
+13 QUIT
+14 ;
INIT ; [Procedure] Cleanup environment before starting
+1 KILL ^TMP("DILIST",$JOB),^TMP($JOB)
+2 QUIT
+3 ;
INST(IEN) ; [Procedure] Display Instrument
+1 ; Input parameters
+2 ; 1. IEN [Literal/Required] Instrument IEN or * for all
+3 ;
+4 ; Variables:
+5 ; MDDX: [Private] Scratch counter
+6 ;
+7 ; New private variables
+8 NEW MDDX
+9 IF $GET(IEN,"*")="*"
Begin DoDot:1
+10 WRITE "NAME",?20,"PRINT NAME",?40,"SERIAL #",?50,"M RTN",?60,"PKG",?72,"ACTIVE"
+11 DO LIST^DIC(702.09,"","@;.01;.06;.08;.11;.12;.09","P")
+12 FOR X=0:0
SET X=$ORDER(^TMP("DILIST",$JOB,X))
if 'X
QUIT
SET MDDX=$GET(^(X,0))
Begin DoDot:2
+13 WRITE !,$$EXT($PIECE(MDDX,U,2),18),?20,$EXTRACT($PIECE(MDDX,U,3),1,18),?40,$PIECE(MDDX,U,4),?50,$PIECE(MDDX,U,5),?60,$PIECE(MDDX,U,6),?72,$PIECE(MDDX,U,7)
End DoDot:2
End DoDot:1
QUIT
+14 DO DIQ(702.09,IEN_",")
+15 WRITE $$LINE(702.09,IEN_",",.01,0,1),!!
+16 SET X=.01
FOR
SET X=$ORDER(^TMP($JOB,702.09,IEN_",",X))
if 'X
QUIT
Begin DoDot:1
+17 WRITE !,$$LINE(702.09,IEN_",",X,30,1)
End DoDot:1
+18 QUIT
+19 ;
LINE(DD,IENS,FIELD,COL,TITLE) ; [Procedure] Display a default line of a field loaded from DIQ above
+1 ; Input parameters
+2 ; 1. DD [Literal/Required] DD Number
+3 ; 2. IENS [Literal/Required] Record IENS
+4 ; 3. FIELD [Literal/Required] Field number
+5 ; 4. COL [Literal/Required] Column for data
+6 ; 5. TITLE [Literal/Required] Use FileMan TITLE:1 or LABEL:0
+7 ;
+8 if '$$VFIELD^DILFD(DD,FIELD)
QUIT ""
+9 if $X>1
WRITE !
+10 WRITE $SELECT($GET(TITLE):$$GET1^DID(DD,FIELD,"","TITLE"),1:$$GET1^DID(DD,FIELD,"","LABEL"))
+11 WRITE ": ",?($GET(COL,0)),$SELECT(^TMP($JOB,DD,IENS,FIELD)]"":^(FIELD),1:"<Blank>")
+12 QUIT ""
+13 ;
PAR ; [Procedure] Display System Parameters
+1 ; Variables:
+2 ; MD: [Private] Scratch
+3 ; MDLST: [Private] Scratch
+4 ; MDMULT: [Private] Scratch
+5 ; MDPAR: [Private] Scratch
+6 ; MDWP: [Private] Scratch
+7 ;
+8 ; New private variables
+9 NEW MD,MDLST,MDMULT,MDPAR,MDWP
+10 WRITE "System Parameters For: ",$$KSP^XUPARAM("WHERE")
+11 DO RPC^MDRPCOV(.X,"PARLST","SYS")
+12 FOR MD=0:0
SET MD=$ORDER(^TMP($JOB,MD))
if 'MD
QUIT
Begin DoDot:1
+13 SET MDPAR=$PIECE(^TMP($JOB,MD),U,2)
+14 SET MDMULT=($PIECE(^TMP($JOB,MD),U,5)="Yes")
+15 SET MDWP=($PIECE(^TMP($JOB,MD),U,4)="word processing")
+16 WRITE !!,"Parameter: ",MDPAR
+17 WRITE ?55,"Type: ",$PIECE(^TMP($JOB,MD),U,4)
+18 WRITE !,"Description: ",$PIECE(^TMP($JOB,MD),U,3)
+19 WRITE ?55,"Multiple: ",$PIECE(^TMP($JOB,MD),U,5)
+20 ; Not Multiple
if 'MDMULT
Begin DoDot:2
+21 IF 'MDWP
WRITE !," Value: ",$$GET^XPAR("SYS",MDPAR,,"E")
QUIT
+22 KILL MDWP
DO GETWP^XPAR(.MDWP,"SYS",MDPAR,1)
Begin DoDot:3
+23 WRITE !,"WP-Text:"
+24 FOR X=0:0
SET X=$ORDER(MDWP(X))
if 'X
QUIT
WRITE !?2,MDWP(X,0)
End DoDot:3
End DoDot:2
+25 ; Multiple Instances
if MDMULT
Begin DoDot:2
+26 if 'MDWP
Begin DoDot:3
+27 WRITE !,?2,"Values:"
+28 DO GETLST^XPAR(.MDLST,"SYS",MDPAR,"E")
+29 FOR X=0:0
SET X=$ORDER(MDLST(X))
if 'X
QUIT
Begin DoDot:4
+30 WRITE !?2,$PIECE(MDLST(X),"^",1)
+31 WRITE ?30,"= ",$PIECE(MDLST(X),U,2)
+32 ;W !!," Instance: ",$P(MDLST(X),"^",1)
+33 ;W !," Value: ",$P(MDLST(X),U,2)
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+34 KILL ^TMP($JOB)
+35 QUIT
+36 ;
PROC(IEN) ; [Procedure] Display a procedure
+1 ; Input parameters
+2 ; 1. IEN [Literal/Required] Procedure IEN or * for all
+3 ;
+4 IF $GET(IEN,"*")="*"
Begin DoDot:1
+5 WRITE "NAME",?32,"TREATING SPECIALTY",?54,"TIU NOTE",?76,"LOCATION",?98,"ACTIVE",?108,"EXT DATA"
+6 DO LIST^DIC(702.01,"","@;.01;.02;.04;.05;.09;.03","P")
+7 FOR X=0:0
SET X=$ORDER(^TMP("DILIST",$JOB,X))
if 'X
QUIT
Begin DoDot:2
+8 ; Naked refs below are from ^TMP("DILIST",$J,X)
+9 WRITE !,$$EXT($PIECE(^(X,0),U,2),30)
+10 WRITE ?32,$$EXT($PIECE(^(0),U,3),20)
+11 WRITE ?54,$$EXT($PIECE(^(0),U,4),20)
+12 WRITE ?76,$$EXT($PIECE(^(0),U,5),20)
+13 WRITE ?98,$PIECE(^(0),U,6)
+14 WRITE ?108,$PIECE(^(0),U,7)
End DoDot:2
End DoDot:1
QUIT
+15 DO DIQ(702.01,IEN_",")
+16 WRITE $$LINE(702.01,IEN_",",.01,0,1),!
+17 SET X=.01
FOR
SET X=$ORDER(^TMP($JOB,702.01,IEN_",",X))
if 'X
QUIT
Begin DoDot:1
+18 WRITE !,$$LINE(702.01,IEN_",",X,32,1)
End DoDot:1
+19 KILL ^TMP("DILIST",$JOB),^TMP($JOB)
+20 WRITE !!,"Associated Instruments",!,$TRANSLATE($JUSTIFY("",30)," ","-"),!
+21 DO LIST^DIC(702.011,","_IEN_",",.01,"P")
+22 IF '$ORDER(^TMP("DILIST",$JOB,0))
WRITE ?5,"<None>"
+23 IF '$TEST
FOR X=0:0
SET X=$ORDER(^TMP("DILIST",$JOB,X))
if 'X
QUIT
WRITE $PIECE(^(X,0),U,2),!
+24 KILL ^TMP("DILIST",$JOB)
+25 QUIT
+26 ;
RPC(RESULTS,OPTION,RTN) ; [Procedure] Main RPC for TMD_Output Object
+1 ; RPC: [MD TMDOUTPUT]
+2 ;
+3 ; Input parameters
+4 ; 1. RESULTS [Literal/Required] RPC Return Array
+5 ; 2. OPTION [Literal/Required] Option to execute
+6 ; 3. RTN [Literal/Required] Routine to execute
+7 ;
+8 SET RESULTS=$NAME(^TMP("MD",$JOB))
KILL @RESULTS
+9 IF $TEXT(@OPTION)]""
DO @OPTION
+10 if '$DATA(@RESULTS)
DO BADRPC^MDRPCU("MD TMDOUTPUT","MDRPCOO",OPTION)
+11 DO CLEAN^DILF
+12 QUIT
+13 ;
EXT(VALUE,LENGTH) ; [Function] $Extract with ... trailer
+1 ; Input parameters
+2 ; 1. VALUE [Literal/Required] Value to truncate
+3 ; 2. LENGTH [Literal/Required] Result length
+4 ;
+5 IF $LENGTH(VALUE)>LENGTH
SET VALUE=$EXTRACT(VALUE,1,LENGTH-3)_"..."
+6 QUIT VALUE
+7 ;
