MDCLIO ;HINES OIFO/DP - CliO backend driver;02 Feb 2005
;;1.0;CLINICAL PROCEDURES;**16**;Apr 01, 2004;Build 280
;Per VHA Directive 2004-038, this routine should not be modified.
;
; This routine uses the following IAs:
; # 3027 - PTSEC^DGSEC4 Registration (supported)
; # 2701 - $$GETICN^MPIF001 Master Patient Index VistA (supported)
; #10112 - $$SITE^VASITE() call Registration (supported)
; #10070 - ^XMD call MailMan (supported)
; # 2263 - $$GET^XPAR Toolkit (supported)
; # 2263 - GETWP^XPAR Toolkit (supported)
; # 4440 - $$PROD^XUPROD call Kernel (supported)
; #10076 - access ^XUSEC( Kernel (supported)
; #1381 - GMRV VITAL MEASUREMENT Vitals (controlled subscription)
;
RPC(RESULTS,OPTION,P1,P2,P3,P4,P5,P6,P7,P8,P9) ; Generic RPC tag
N MD,MDD,MDCMD,MDIEN,MDERR,MDIENS,MDFLD,MDFLAG,MDOBS,MDVUID,MDRET,MDLIST,MDTMP,MDVAL,MDRTN,MDQRY,MDIDX,MDCACHED,MDNAME,MDCMT,MDROOT,MDXROOT
K ^TMP("MDCLIO",$J) ; Default scratch space for all calls
S RESULTS=$NA(^TMP($J)) K @RESULTS
I '($T(@OPTION)]"") S @RESULTS@(0)="-1^Option '"_OPTION_"' not found in routine "_$T(+0)_"." Q
D @OPTION
I '$D(@RESULTS) S @RESULTS@(0)="-1^Unspecified Error"
K ^TMP("MDCLIO",$J) ; Default scratch space for where clauses
Q
;
EXECUTE ; Executes the command in P1
D GETWP^XPAR(.MDCMD,"SYS","MD COMMANDS",P1,.MDERR)
S MDNAME=P1,Y=MDCMD(1,0),MDCMD=$P(Y,";",1),MDFILE=$P(Y,";",2),MDRTN=$P(Y,";",3),MDROOT=$P(Y,";",4),MDWHERE=$P(Y,";",5),MDIDX=$P(Y,";",6)
S MDCACHED=$P(Y,";",7)&($$GET^XPAR("SYS","MD PARAMETERS","ALLOW_CACHED_QUERIES")=1)&('$D(P2))
D FLDS(.MDCMD)
I MDRTN="" S MDRTN=MDCMD ; Custom routine to perform the whole command
I MDWHERE]"" D @MDWHERE ; Custom where clause
D @MDRTN
K MDWHERE
Q
;
FLDS(MDTXT) ; Builds MDFLD() from a command wp-text
F Y=1:0 S Y=$O(MDTXT(Y)) Q:'Y D
.S X=MDTXT(Y,0)
.I $E(X,1)=";" Q
.I $E(X,1)="@" D FLDS($E($P(X,";",1),2,250)) Q ; Warning, recursion is an evil thing :)
.S MDFLD(+$O(MDFLD(""),-1)+1)=X
Q
;
IENLIST ; Builds MDROOT from P2(0..n) as IEN list
S MDROOT=$NA(^TMP("MDCLIO",$J)) K @MDROOT
S MDIEN=""
F S MDIEN=$O(P2(MDIEN)) Q:MDIEN="" S @MDROOT@(P2(MDIEN))=""
Q
;
IMPORT ; Import a record for the TDBConnection_Vista object
N MDFILE,MDIENS,MDX,MDVAL,MDFDA,MDRET
S MDFILE=$$TABLE(P1),MDIENS=P2
F MDX=0:2 Q:'$D(P3(MDX)) D
.S MDFLD=$$FLDNUM^DILFD(MDFILE,P3(MDX))
.D VAL^DIE(MDFILE,MDIENS,MDFLD,"FU",$G(P3(MDX+1)),.MDVAL,"MDFDA","MDRET") Q:'$D(MDRET)
S X="MDFDA" F S X=$Q(@X) Q:X="" D
.S Y=$O(@RESULTS@(99999,""),-1)+1
.S @RESULTS@(99999,Y)=X_"="_@X
D:MDIENS?1"+1," UPDATE^DIE("K","MDFDA",,"MDERR")
D:MDIENS'?1"+1," FILE^DIE("K","MDFDA","MDERR")
I '$D(MDERR) S @RESULTS@(0)="WOO HOO, IT'S FILED!" Q
S @RESULTS@(0)="OH POOP",X="MDERR"
F S X=$Q(@X) Q:X="" D
.S Y=$O(@RESULTS@(""),-1)+1
.S @RESULTS@(Y)=X_"="_@X
Q
;
GETIEN ; Returns the ien of a record for generic updates **pk only**
N MDVAL F X=0:1 Q:'$D(P2(X)) S MDVAL(X+1)=P2(X)
S @RESULTS@(0)=+$$FIND1^DIC($$TABLE(P1),,"KXP",.MDVAL)
Q
;
QUERY ; Executes a standard query
N MDXTMP S MDXTMP="MDCACHE_"_MDNAME
I MDCACHED,$D(^XTMP(MDXTMP)) L +(^XTMP(MDXTMP)):5 I $T D Q ; Returning the cached copy
.M @RESULTS=^XTMP(MDXTMP,1)
.L -(^XTMP(MDXTMP)) ; Later Gater!
D NEWDOC("RESULTS")
I $$ROOT^DILFD(MDFILE,"",1)=MDROOT D D ENDDOC("RESULTS") Q
.I '$D(P2(0))!($G(P2(0))="*") D Q ; Load whole file
..F MDREC=0:0 S MDREC=$O(@MDROOT@(MDREC)) Q:'MDREC D XMLREC(MDFILE,MDREC)
.S MDVAL=$G(P2(0)) F X=0:1 Q:'$D(P2(X)) D
..I P2(X)?4N1"-"2N1"-"2N1" "2N1":"2N1":"2N S P2(X)=$$FMDT(P2(X))
..S MDVAL(X+1)=P2(X)
.D FIND^DIC(MDFILE,"","@","KP",.MDVAL,"*",MDIDX) Q:'$O(^TMP("DILIST",$J,0))
.F MDREC=0:0 S MDREC=$O(^TMP("DILIST",$J,MDREC)) Q:'MDREC D XMLREC(MDFILE,+^(MDREC,0))
S MDROOT=$NA(@MDROOT),MDIDX=$$OREF^DILF(MDROOT)
F S MDROOT=$Q(@MDROOT) Q:MDROOT="" Q:$P(MDROOT,MDIDX,1)'="" D
.S MDREC=$QS(MDROOT,$QL(MDROOT)) D XMLREC(MDFILE,MDREC)
D ENDDOC("RESULTS")
K MDREC
Q
;
STPROC ; Place holder for no routine entered into a stored procedure type
D NEWDOC("RESULTS")
D XMLADD("NO PROCEDURE SPECIFIED")
D ENDDOC("RESULTS")
Q
;
ROLES ; Temporary Role Based Query
D NEWDOC("RESULTS","USER ROLES")
S X="A" F S X=$O(^XUSEC(X)) Q:X="" D:$D(^XUSEC(X,DUZ))
.D XMLHDR("RECORD"),XMLDATA("ROLE_ID",X),XMLFTR("RECORD")
D ENDDOC("RESULTS")
Q
;
XQUERY ; Runs the standard query after a pre-process routine has prepared the entries into @MDXROOT@(ien...)
D NEWDOC("RESULTS","FILEMAN FILE #"_MDFILE_" "_MDCMT)
F MD=0:0 S MD=$O(@MDXROOT@(MD)) Q:'MD D XMLREC(MDFILE,@MDXROOT@(MD))
K @MDXROOT
D ENDDOC("RESULTS")
Q
;
INSERT ; Performs an insert
K MDERR
F Y=0:0 S Y=$O(MDFLD(Y)) Q:'Y D
.Q:$G(P2(Y-1))=""
.I $P(MDFLD(Y),";",4)["DATE" S @$$FDA(MDFILE)@($P(MDFLD(Y),";"))=$$FMDT(P2(Y-1)) Q
.I $P(MDFLD(Y),";",3)="I"!($G(P2(Y-1))="") S @$$FDA(MDFILE)@($P(MDFLD(Y),";"))=$G(P2(Y-1)) Q ; RPC Broker sends 0..n array
.D CHK^DIE(MDFILE,$P(MDFLD(Y),";"),"",$G(P2(Y-1)),.MDVAL,"MDERR")
.I MDVAL="^" M @RESULTS@(Y)=MDERR("DIERR",1,"TEXT") K MDERR,MDVAL Q
.S @$$FDA(MDFILE)@($P(MDFLD(Y),";"))=MDVAL
I $O(@RESULTS@(0)) S @RESULTS@(0)="-1^Errors found validating data" Q
D UPDATE^DIE("",$$FDA(),,"MDERR")
I $D(MDERR) D Q
.F Y=0:0 S Y=$O(MDERR("DIERR",Y)) Q:'Y M @RESULTS@(Y)=MDERR("DIERR",Y,"TEXT")
.S @RESULTS@(0)="-1^Insert Error"
S @RESULTS@(0)="1^Insert complete"
Q
;
UPDATE ; Performs an update
; Must find an EXACT match - Need to re-evaluate later for an update where like SQL statement
S MDIEN=$$FIND1^DIC(MDFILE,,"KXP",P2(0))
I MDIEN'>0 S @RESULTS@(0)="-1^No such record '"_P2(0)_"'" Q
F Y=0:0 S Y=$O(MDFLD(Y)) Q:'Y D
.I $G(P2(Y))="" S @$$FDA(MDFILE,MDIEN)@($P(MDFLD(Y),";"))="" Q
.I $P(MDFLD(Y),";",4)["DATE" S @$$FDA(MDFILE,MDIEN)@($P(MDFLD(Y),";"))=$$FMDT(P2(Y)) Q
.I $P(MDFLD(Y),";",3)="I" S @$$FDA(MDFILE,MDIEN)@($P(MDFLD(Y),";"))=P2(Y) Q ; Notice P2 offset matches here
.K MDERR,MDHELP,MDVAL D VAL^DIE(MDFILE,MDIEN,$P(MDFLD(Y),";"),"",P2(Y),.MDVAL,"","MDERR")
.I MDVAL="^" M @RESULTS@(Y)=MDERR("DIERR",1,"TEXT") Q
.S @$$FDA(MDFILE,MDIEN)@($P(MDFLD(Y),";"))=MDVAL ; Set the internal value for filing !!!
I $O(@RESULTS@(0)) S @RESULTS@(0)="-1^Errors found validating data" Q
K MDERR D FILE^DIE("K",$$FDA(),"MDERR")
I $O(MDERR(""))]"" M @RESULTS@(1)=MDERR S @RESULTS@(0)="-1^Error" Q
S @RESULTS@(0)="1^Update complete!"
Q
;
DELETE ; Performs standard Delete command
; Will find records like the update but can return multiple entries
S X="" F S X=$O(P2(X)) Q:X="" S MDVAL($O(MDVAL(""),-1)+1)=P2(X)
D FIND^DIC(MDFILE,"","@;.01","PK",.MDVAL,"*",MDIDX)
I '$O(^TMP("DILIST",$J,0)) S @RESULTS@(0)="1^No records found to delete" Q
F X=0:0 S X=$O(^TMP("DILIST",$J,X)) Q:'X S MDIEN=+^(X,0),@$$FDA(MDFILE,MDIEN)@(.01)="@"
D FILE^DIE("",$$FDA(),"MDERR")
I $O(MDERR(""))]"" M @RESULTS@(1)=MDERR S @RESULTS@(0)="-1^Error" Q
S @RESULTS@(0)="1^Records successfully deleted."
Q
;
DELALL ; Used to purge entire file ** XML Import calls ONLY!!!! **
S MDROOT=$$ROOT^DILFD(MDFILE,"",1)
F X=0:0 S X=$O(@MDROOT@(X)) Q:'X S @$$FDA(MDFILE,X)@(.01)="@"
D:$D(@$$FDA()) FILE^DIE("",$$FDA(),"MDERR")
I $O(MDERR(""))]"" M @RESULTS@(1)=MDERR S @RESULTS@(0)="-1^Error" Q
S @RESULTS@(0)="1^Records successfully deleted."
Q
;
XMLREC(DD,IEN) ; Builds an XML Record based on DD, IEN & values in MDFLD(1..n)
N MD,MDIENS,MDTAG,MDFMT,MDTYP,X,Y
D XMLHDR("RECORD")
S MDIENS=+IEN_","
F MD=0:0 S MD=$O(MDFLD(MD)) Q:'MD D
.S MDFLD=$P(MDFLD(MD),";",1)
.S MDTAG=$P(MDFLD(MD),";",2)
.S MDFMT=$P(MDFLD(MD),";",3)
.S MDTYP=$P(MDFLD(MD),";",4)
.I MDFLD?1"$$".E D @("XMLDATA(MDTAG,"_MDFLD_")") Q
.I MDFLD?1"D ".E X MDFLD Q
.I MDTYP["DATE" S Y=$$GET1^DIQ(DD,MDIENS,MDFLD,"I") D:Y]"" XMLDT(MDTAG,Y) Q
.D XMLDATA(MDTAG,$$GET1^DIQ(DD,MDIENS,MDFLD,MDFMT))
D XMLFTR("RECORD")
Q
;
SETACL ; Sets the ACL for an Item
; P2(0)=Item
; P2(1)=User ID (DUZ)
; P2(2)=Access Level
N MDIEN,MDFDA
S MDIEN=$O(^MDC(704.001,"PK",P2(0),P2(1),0))
D:'MDIEN
.S MDFDA(704.001,"+1,",.01)=P2(0)
.S MDFDA(704.001,"+1,",.02)=P2(1)
.S MDIEN="+1"
S MDFDA(704.001,MDIEN_",",.03)=$G(P2(2),0)
D UPDATE^DIE("","MDFDA")
S @RESULTS@(0)="1^ACL Updated."
Q
;
DELACL ; Removes and item from ACL
; P2(0)=Item
; P2(1)=User ID (DUZ) - if blank or undefined deletes all record for P2(0)
N MDIEN,MDFDA,MDUSER
D:$G(P2(1))]""
.S MDIEN=$O(^MDC(704.001,"PK",P2(0),P2(1),0))
.D:MDIEN
..S MDFDA(704.001,MDIEN_",",.01)="@"
D:$G(P2(1))=""
.S MDUSER=""
.F S MDUSER=$O(^MDC(704.001,"PK",P2(0),MDUSER)) Q:MDUSER="" D
..S MDIEN=$O(^MDC(704.001,"PK",P2(0),MDUSER,0))
..S MDFDA(704.001,MDIEN_",",.01)="@"
D:$D(MDFDA) UPDATE^DIE("","MDFDA")
S @RESULTS@(0)="1^ACL Updated."
Q
;
SENDMAIL ; Sends an EMail Message
; Example of the P2(0..n) array
; P2(0)="SUB:Message Subject"
; P2(1)="TEXT:THIS IS LINE 1"
; P2(2)="TEXT:THIS IS LINE 2"
; P2(3)="TO:user.one@domain.ext;user.two@domain.ext"
N MDTO,MDTEXT,XMDUZ,XMSUB,XMTEXT,XMY
S XMDUZ="Clinical Procedure Notification System"
S XMTEXT="MDTEXT("
S X="" F S X=$O(P2(X)) Q:X="" D
.I P2(X)?1"SUB:".E S XMSUB=$P(P2(X),":",2,250) Q
.I P2(X)?1"TO:".E D Q
..S MDTO=$P(P2(X),"TO:",2,250) ; We can store recipient lists as ';' delimited strings - Just like Outlook :)
..I MDTO]"" F Y=1:1:$L(MDTO,";") S XMY($P(MDTO,";",Y))=""
.I P2(X)?1"TEXT:".E D Q
..S Y=$O(MDTEXT(""),-1)+1,MDTEXT(Y,0)=$P(P2(X),"TEXT:",2,250)
S MDTEXT(0)="^^"_$O(MDTEXT(""),-1)_U_DT
D ^XMD
S @RESULTS@(0)="1^E-Mail Sent"
Q
;
; Special extrinsic field calls
ID() Q "`"_IEN
ROWID() Q IEN
ICN() Q:MDFILE'=2 "" Q $$GETICN^MPIF001(IEN)
NAME() Q $$GET1^DIQ(MDFILE,IEN,.01,"E")
SNSTV() N MDRET D PTSEC^DGSEC4(.MDRET,IEN) Q ($G(MDRET(1))'=0)
CCOW() S X="patient.id.mrn.dfn_"_$P($$SITE^VASITE(),U,3) S:'$$PROD^XUPROD() X=X_"_test" Q X ; IUser.getCCOWDFNItemName
VITALSID() Q "{GMRV-"_IEN_"}"
VSTATUS() Q $S(+$$GET1^DIQ(120.5,IEN_",",2,"I"):4,1:1)
;
XMLCMT(COMMENT) ; Add a comment to a document
D XMLADD("<!-- "_COMMENT_" -->")
Q
;
XMLHDR(TAG) ; Add a header tag to the global
S TAG=$$TAGSAFE(TAG)
D XMLADD("<"_TAG_">")
Q
;
XMLFTR(TAG) ; Add a footer tag to the global
D XMLHDR("/"_TAG)
Q
;
XMLDATA(TAG,X) ; Add a data element to the global
S TAG=$$TAGSAFE(TAG)
S X=$$XMLSAFE(X)
Q:X=""
D XMLADD("<"_TAG_">"_X_"</"_TAG_">")
Q
;
XMLFLDS(FLDLST,DD,FLDS) ; Build FLDS into an array of FLDS
K FLDLST
F X=1:1:$L(FLDS,";") D
.S FLDLST($P(FLDS,";",X),"TAG")=$$GET1^DID(DD,$P(FLDS,";",X),"","LABEL")
.S FLDLST($P(FLDS,";",X),"TYPE")=$$GET1^DID(DD,$P(FLDS,";",X),"","TYPE")
Q
;
XMLDT(TAG,X) ; Add date or date/time to the global
S TAG=$$TAGSAFE(TAG)
I $G(X)="" D XMLADD("<"_TAG_" />") Q ; No data
S Y=(1700+$E(X,1,3))_"-"_$E(X,4,5)_"-"_$E(X,6,7)
D:X]"."
.S X=X+.0000001
.S Y=Y_" "_$E(X,9,10)_":"_$E(X,11,12)_":"_$E(X,13,14)
D XMLDATA(TAG,Y)
Q
;
XMLIDS(TAG,IDS,CLOSE) ; Add a data element to the global with ids
N X,Y
S TAG="<"_$$TAGSAFE(TAG)
F X=0:0 S X=$O(IDS(X)) Q:'X D
.S Y="" F S Y=$O(IDS(X,Y)) Q:Y="" D
..S TAG=TAG_" "_Y_"="""_$$XMLSAFE(IDS(X,Y))_""""
S:$G(CLOSE) TAG=TAG_" /" ; Close out the tag element
S TAG=TAG_">"
D XMLADD(TAG)
Q
;
XMLADD(X) ; Add to the global
S @RESULTS@($O(@RESULTS@(""),-1)+1)=$G(X)
Q
;
XMLSAFE(X) ; Transform X into XML safe data
; Strip off the spaces and make life easier
D STRIP(.X)
S X=$$TRNSLT(X,"&","&")
S X=$$TRNSLT(X,"<","<")
S X=$$TRNSLT(X,">",">")
S X=$$TRNSLT(X,"'","'")
S X=$$TRNSLT(X,"""",""")
S X=$$TRNSLT(X,":",":")
Q X
;
TAGSAFE(X) ; Transform X into XML tag
S:X?1N.E X="_"_X ; Remove starting numeric
Q $TR(X," '`()<>*[]","__________")
;
STRIP(X) ; Strip off leading and trailing spaces
F Q:$E(X)'=" " S X=$E(X,2,$L(X))
F Q:$E(X,$L(X))'=" " S X=$E(X,1,$L(X)-1)
Q
;
NEWDOC(ROOT,COMMENT) ; Start a new document
K @RESULTS
D XMLADD("<?xml version=""1.0"" standalone=""yes""?>")
D XMLCMT("OPTION = "_$G(OPTION,"NULL"))
I $G(COMMENT)]"" D XMLCMT(COMMENT)
D XMLCMT("P1 = "_$G(P1,"NULL"))
I $D(P2)#2 D XMLCMT("P2 = "_P2)
S X="" F S X=$O(P2(X)) Q:X="" D XMLCMT("P2("_X_") = "_P2(X))
D XMLHDR($G(ROOT,"RESULTS"))
Q
;
ENDDOC(ROOT) ; End this document
D XMLFTR($G(ROOT,"RESULTS"))
Q
;
QUICKDOC(TAG,VALUE) ; Builds a single record, single field document
D NEWDOC()
D XMLHDR("RECORD")
D XMLDATA(TAG,VALUE)
D XMLFTR("RECORD")
D ENDDOC()
Q
;
SRVRDT ; Returns Server Date/Time
D QUICKDOC("SERVER_DATE_TIME",$$NOW)
Q
;
TRNSLT(X,X1,X2) ; Translate every Y to Z in X
N Y
Q:X'[X1 X ; Nothing to translate
S Y="" F Q:X="" D
.I X[X1 S Y=Y_$P(X,X1)_X2,X=$P(X,X1,2,250) Q
.S Y=Y_X,X=""
Q Y
;
; Extrinsic Functions
;
FDA(DD,IEN) ; Construct a standard FDA
; Returns ^TMP("MDCLIO",$J,{DD},{IEN:+1})
Q $S($G(DD):$NA(^TMP("MDCLIO",$J,DD,$G(IEN,"+1")_",")),1:$NA(^TMP("MDCLIO",$J)))
;
SQLDATE(X) ; Returns SQL standard XML Date/Time string from FM
S X=X+.0000001
Q ($E(X,1,3)+1700)_"-"_$E(X,4,5)_"-"_$E(X,6,7)_" "_$E(X,9,10)_":"_$E(X,11,12)_":"_$E(X,13,14)
;
FMDT(X) ; Returns FM standard date/time from SQL style
N Y S Y=X
S X=($E(X,1,4)-1700)_$E(X,6,7)_$E(X,9,10)_"."_$E(X,12,13)_$E(X,15,16)_$E(X,18,19)
Q +X
;
NOW() ; Returns Date/Time
D NOW^%DTC
Q $$SQLDATE(%)
;
TABLE(X) ; Return file number from the name
Q $$FIND1^DIC(1,,"KXP",X)
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMDCLIO 13908 printed Jan 18, 2025@02:43:35 Page 2
MDCLIO ;HINES OIFO/DP - CliO backend driver;02 Feb 2005
+1 ;;1.0;CLINICAL PROCEDURES;**16**;Apr 01, 2004;Build 280
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ; This routine uses the following IAs:
+5 ; # 3027 - PTSEC^DGSEC4 Registration (supported)
+6 ; # 2701 - $$GETICN^MPIF001 Master Patient Index VistA (supported)
+7 ; #10112 - $$SITE^VASITE() call Registration (supported)
+8 ; #10070 - ^XMD call MailMan (supported)
+9 ; # 2263 - $$GET^XPAR Toolkit (supported)
+10 ; # 2263 - GETWP^XPAR Toolkit (supported)
+11 ; # 4440 - $$PROD^XUPROD call Kernel (supported)
+12 ; #10076 - access ^XUSEC( Kernel (supported)
+13 ; #1381 - GMRV VITAL MEASUREMENT Vitals (controlled subscription)
+14 ;
RPC(RESULTS,OPTION,P1,P2,P3,P4,P5,P6,P7,P8,P9) ; Generic RPC tag
+1 NEW MD,MDD,MDCMD,MDIEN,MDERR,MDIENS,MDFLD,MDFLAG,MDOBS,MDVUID,MDRET,MDLIST,MDTMP,MDVAL,MDRTN,MDQRY,MDIDX,MDCACHED,MDNAME,MDCMT,MDROOT,MDXROOT
+2 ; Default scratch space for all calls
KILL ^TMP("MDCLIO",$JOB)
+3 SET RESULTS=$NAME(^TMP($JOB))
KILL @RESULTS
+4 IF '($TEXT(@OPTION)]"")
SET @RESULTS@(0)="-1^Option '"_OPTION_"' not found in routine "_$TEXT(+0)_"."
QUIT
+5 DO @OPTION
+6 IF '$DATA(@RESULTS)
SET @RESULTS@(0)="-1^Unspecified Error"
+7 ; Default scratch space for where clauses
KILL ^TMP("MDCLIO",$JOB)
+8 QUIT
+9 ;
EXECUTE ; Executes the command in P1
+1 DO GETWP^XPAR(.MDCMD,"SYS","MD COMMANDS",P1,.MDERR)
+2 SET MDNAME=P1
SET Y=MDCMD(1,0)
SET MDCMD=$PIECE(Y,";",1)
SET MDFILE=$PIECE(Y,";",2)
SET MDRTN=$PIECE(Y,";",3)
SET MDROOT=$PIECE(Y,";",4)
SET MDWHERE=$PIECE(Y,";",5)
SET MDIDX=$PIECE(Y,";",6)
+3 SET MDCACHED=$PIECE(Y,";",7)&($$GET^XPAR("SYS","MD PARAMETERS","ALLOW_CACHED_QUERIES")=1)&('$DATA(P2))
+4 DO FLDS(.MDCMD)
+5 ; Custom routine to perform the whole command
IF MDRTN=""
SET MDRTN=MDCMD
+6 ; Custom where clause
IF MDWHERE]""
DO @MDWHERE
+7 DO @MDRTN
+8 KILL MDWHERE
+9 QUIT
+10 ;
FLDS(MDTXT) ; Builds MDFLD() from a command wp-text
+1 FOR Y=1:0
SET Y=$ORDER(MDTXT(Y))
if 'Y
QUIT
Begin DoDot:1
+2 SET X=MDTXT(Y,0)
+3 IF $EXTRACT(X,1)=";"
QUIT
+4 ; Warning, recursion is an evil thing :)
IF $EXTRACT(X,1)="@"
DO FLDS($EXTRACT($PIECE(X,";",1),2,250))
QUIT
+5 SET MDFLD(+$ORDER(MDFLD(""),-1)+1)=X
End DoDot:1
+6 QUIT
+7 ;
IENLIST ; Builds MDROOT from P2(0..n) as IEN list
+1 SET MDROOT=$NAME(^TMP("MDCLIO",$JOB))
KILL @MDROOT
+2 SET MDIEN=""
+3 FOR
SET MDIEN=$ORDER(P2(MDIEN))
if MDIEN=""
QUIT
SET @MDROOT@(P2(MDIEN))=""
+4 QUIT
+5 ;
IMPORT ; Import a record for the TDBConnection_Vista object
+1 NEW MDFILE,MDIENS,MDX,MDVAL,MDFDA,MDRET
+2 SET MDFILE=$$TABLE(P1)
SET MDIENS=P2
+3 FOR MDX=0:2
if '$DATA(P3(MDX))
QUIT
Begin DoDot:1
+4 SET MDFLD=$$FLDNUM^DILFD(MDFILE,P3(MDX))
+5 DO VAL^DIE(MDFILE,MDIENS,MDFLD,"FU",$GET(P3(MDX+1)),.MDVAL,"MDFDA","MDRET")
if '$DATA(MDRET)
QUIT
End DoDot:1
+6 SET X="MDFDA"
FOR
SET X=$QUERY(@X)
if X=""
QUIT
Begin DoDot:1
+7 SET Y=$ORDER(@RESULTS@(99999,""),-1)+1
+8 SET @RESULTS@(99999,Y)=X_"="_@X
End DoDot:1
+9 if MDIENS?1"+1,"
DO UPDATE^DIE("K","MDFDA",,"MDERR")
+10 if MDIENS'?1"+1,"
DO FILE^DIE("K","MDFDA","MDERR")
+11 IF '$DATA(MDERR)
SET @RESULTS@(0)="WOO HOO, IT'S FILED!"
QUIT
+12 SET @RESULTS@(0)="OH POOP"
SET X="MDERR"
+13 FOR
SET X=$QUERY(@X)
if X=""
QUIT
Begin DoDot:1
+14 SET Y=$ORDER(@RESULTS@(""),-1)+1
+15 SET @RESULTS@(Y)=X_"="_@X
End DoDot:1
+16 QUIT
+17 ;
GETIEN ; Returns the ien of a record for generic updates **pk only**
+1 NEW MDVAL
FOR X=0:1
if '$DATA(P2(X))
QUIT
SET MDVAL(X+1)=P2(X)
+2 SET @RESULTS@(0)=+$$FIND1^DIC($$TABLE(P1),,"KXP",.MDVAL)
+3 QUIT
+4 ;
QUERY ; Executes a standard query
+1 NEW MDXTMP
SET MDXTMP="MDCACHE_"_MDNAME
+2 ; Returning the cached copy
IF MDCACHED
IF $DATA(^XTMP(MDXTMP))
LOCK +(^XTMP(MDXTMP)):5
IF $TEST
Begin DoDot:1
+3 MERGE @RESULTS=^XTMP(MDXTMP,1)
+4 ; Later Gater!
LOCK -(^XTMP(MDXTMP))
End DoDot:1
QUIT
+5 DO NEWDOC("RESULTS")
+6 IF $$ROOT^DILFD(MDFILE,"",1)=MDROOT
Begin DoDot:1
+7 ; Load whole file
IF '$DATA(P2(0))!($GET(P2(0))="*")
Begin DoDot:2
+8 FOR MDREC=0:0
SET MDREC=$ORDER(@MDROOT@(MDREC))
if 'MDREC
QUIT
DO XMLREC(MDFILE,MDREC)
End DoDot:2
QUIT
+9 SET MDVAL=$GET(P2(0))
FOR X=0:1
if '$DATA(P2(X))
QUIT
Begin DoDot:2
+10 IF P2(X)?4N1"-"2N1"-"2N1" "2N1":"2N1":"2N
SET P2(X)=$$FMDT(P2(X))
+11 SET MDVAL(X+1)=P2(X)
End DoDot:2
+12 DO FIND^DIC(MDFILE,"","@","KP",.MDVAL,"*",MDIDX)
if '$ORDER(^TMP("DILIST",$JOB,0))
QUIT
+13 FOR MDREC=0:0
SET MDREC=$ORDER(^TMP("DILIST",$JOB,MDREC))
if 'MDREC
QUIT
DO XMLREC(MDFILE,+^(MDREC,0))
End DoDot:1
DO ENDDOC("RESULTS")
QUIT
+14 SET MDROOT=$NAME(@MDROOT)
SET MDIDX=$$OREF^DILF(MDROOT)
+15 FOR
SET MDROOT=$QUERY(@MDROOT)
if MDROOT=""
QUIT
if $PIECE(MDROOT,MDIDX,1)'=""
QUIT
Begin DoDot:1
+16 SET MDREC=$QSUBSCRIPT(MDROOT,$QLENGTH(MDROOT))
DO XMLREC(MDFILE,MDREC)
End DoDot:1
+17 DO ENDDOC("RESULTS")
+18 KILL MDREC
+19 QUIT
+20 ;
STPROC ; Place holder for no routine entered into a stored procedure type
+1 DO NEWDOC("RESULTS")
+2 DO XMLADD("NO PROCEDURE SPECIFIED")
+3 DO ENDDOC("RESULTS")
+4 QUIT
+5 ;
ROLES ; Temporary Role Based Query
+1 DO NEWDOC("RESULTS","USER ROLES")
+2 SET X="A"
FOR
SET X=$ORDER(^XUSEC(X))
if X=""
QUIT
if $DATA(^XUSEC(X,DUZ))
Begin DoDot:1
+3 DO XMLHDR("RECORD")
DO XMLDATA("ROLE_ID",X)
DO XMLFTR("RECORD")
End DoDot:1
+4 DO ENDDOC("RESULTS")
+5 QUIT
+6 ;
XQUERY ; Runs the standard query after a pre-process routine has prepared the entries into @MDXROOT@(ien...)
+1 DO NEWDOC("RESULTS","FILEMAN FILE #"_MDFILE_" "_MDCMT)
+2 FOR MD=0:0
SET MD=$ORDER(@MDXROOT@(MD))
if 'MD
QUIT
DO XMLREC(MDFILE,@MDXROOT@(MD))
+3 KILL @MDXROOT
+4 DO ENDDOC("RESULTS")
+5 QUIT
+6 ;
INSERT ; Performs an insert
+1 KILL MDERR
+2 FOR Y=0:0
SET Y=$ORDER(MDFLD(Y))
if 'Y
QUIT
Begin DoDot:1
+3 if $GET(P2(Y-1))=""
QUIT
+4 IF $PIECE(MDFLD(Y),";",4)["DATE"
SET @$$FDA(MDFILE)@($PIECE(MDFLD(Y),";"))=$$FMDT(P2(Y-1))
QUIT
+5 ; RPC Broker sends 0..n array
IF $PIECE(MDFLD(Y),";",3)="I"!($GET(P2(Y-1))="")
SET @$$FDA(MDFILE)@($PIECE(MDFLD(Y),";"))=$GET(P2(Y-1))
QUIT
+6 DO CHK^DIE(MDFILE,$PIECE(MDFLD(Y),";"),"",$GET(P2(Y-1)),.MDVAL,"MDERR")
+7 IF MDVAL="^"
MERGE @RESULTS@(Y)=MDERR("DIERR",1,"TEXT")
KILL MDERR,MDVAL
QUIT
+8 SET @$$FDA(MDFILE)@($PIECE(MDFLD(Y),";"))=MDVAL
End DoDot:1
+9 IF $ORDER(@RESULTS@(0))
SET @RESULTS@(0)="-1^Errors found validating data"
QUIT
+10 DO UPDATE^DIE("",$$FDA(),,"MDERR")
+11 IF $DATA(MDERR)
Begin DoDot:1
+12 FOR Y=0:0
SET Y=$ORDER(MDERR("DIERR",Y))
if 'Y
QUIT
MERGE @RESULTS@(Y)=MDERR("DIERR",Y,"TEXT")
+13 SET @RESULTS@(0)="-1^Insert Error"
End DoDot:1
QUIT
+14 SET @RESULTS@(0)="1^Insert complete"
+15 QUIT
+16 ;
UPDATE ; Performs an update
+1 ; Must find an EXACT match - Need to re-evaluate later for an update where like SQL statement
+2 SET MDIEN=$$FIND1^DIC(MDFILE,,"KXP",P2(0))
+3 IF MDIEN'>0
SET @RESULTS@(0)="-1^No such record '"_P2(0)_"'"
QUIT
+4 FOR Y=0:0
SET Y=$ORDER(MDFLD(Y))
if 'Y
QUIT
Begin DoDot:1
+5 IF $GET(P2(Y))=""
SET @$$FDA(MDFILE,MDIEN)@($PIECE(MDFLD(Y),";"))=""
QUIT
+6 IF $PIECE(MDFLD(Y),";",4)["DATE"
SET @$$FDA(MDFILE,MDIEN)@($PIECE(MDFLD(Y),";"))=$$FMDT(P2(Y))
QUIT
+7 ; Notice P2 offset matches here
IF $PIECE(MDFLD(Y),";",3)="I"
SET @$$FDA(MDFILE,MDIEN)@($PIECE(MDFLD(Y),";"))=P2(Y)
QUIT
+8 KILL MDERR,MDHELP,MDVAL
DO VAL^DIE(MDFILE,MDIEN,$PIECE(MDFLD(Y),";"),"",P2(Y),.MDVAL,"","MDERR")
+9 IF MDVAL="^"
MERGE @RESULTS@(Y)=MDERR("DIERR",1,"TEXT")
QUIT
+10 ; Set the internal value for filing !!!
SET @$$FDA(MDFILE,MDIEN)@($PIECE(MDFLD(Y),";"))=MDVAL
End DoDot:1
+11 IF $ORDER(@RESULTS@(0))
SET @RESULTS@(0)="-1^Errors found validating data"
QUIT
+12 KILL MDERR
DO FILE^DIE("K",$$FDA(),"MDERR")
+13 IF $ORDER(MDERR(""))]""
MERGE @RESULTS@(1)=MDERR
SET @RESULTS@(0)="-1^Error"
QUIT
+14 SET @RESULTS@(0)="1^Update complete!"
+15 QUIT
+16 ;
DELETE ; Performs standard Delete command
+1 ; Will find records like the update but can return multiple entries
+2 SET X=""
FOR
SET X=$ORDER(P2(X))
if X=""
QUIT
SET MDVAL($ORDER(MDVAL(""),-1)+1)=P2(X)
+3 DO FIND^DIC(MDFILE,"","@;.01","PK",.MDVAL,"*",MDIDX)
+4 IF '$ORDER(^TMP("DILIST",$JOB,0))
SET @RESULTS@(0)="1^No records found to delete"
QUIT
+5 FOR X=0:0
SET X=$ORDER(^TMP("DILIST",$JOB,X))
if 'X
QUIT
SET MDIEN=+^(X,0)
SET @$$FDA(MDFILE,MDIEN)@(.01)="@"
+6 DO FILE^DIE("",$$FDA(),"MDERR")
+7 IF $ORDER(MDERR(""))]""
MERGE @RESULTS@(1)=MDERR
SET @RESULTS@(0)="-1^Error"
QUIT
+8 SET @RESULTS@(0)="1^Records successfully deleted."
+9 QUIT
+10 ;
DELALL ; Used to purge entire file ** XML Import calls ONLY!!!! **
+1 SET MDROOT=$$ROOT^DILFD(MDFILE,"",1)
+2 FOR X=0:0
SET X=$ORDER(@MDROOT@(X))
if 'X
QUIT
SET @$$FDA(MDFILE,X)@(.01)="@"
+3 if $DATA(@$$FDA())
DO FILE^DIE("",$$FDA(),"MDERR")
+4 IF $ORDER(MDERR(""))]""
MERGE @RESULTS@(1)=MDERR
SET @RESULTS@(0)="-1^Error"
QUIT
+5 SET @RESULTS@(0)="1^Records successfully deleted."
+6 QUIT
+7 ;
XMLREC(DD,IEN) ; Builds an XML Record based on DD, IEN & values in MDFLD(1..n)
+1 NEW MD,MDIENS,MDTAG,MDFMT,MDTYP,X,Y
+2 DO XMLHDR("RECORD")
+3 SET MDIENS=+IEN_","
+4 FOR MD=0:0
SET MD=$ORDER(MDFLD(MD))
if 'MD
QUIT
Begin DoDot:1
+5 SET MDFLD=$PIECE(MDFLD(MD),";",1)
+6 SET MDTAG=$PIECE(MDFLD(MD),";",2)
+7 SET MDFMT=$PIECE(MDFLD(MD),";",3)
+8 SET MDTYP=$PIECE(MDFLD(MD),";",4)
+9 IF MDFLD?1"$$".E
DO @("XMLDATA(MDTAG,"_MDFLD_")")
QUIT
+10 IF MDFLD?1"D ".E
XECUTE MDFLD
QUIT
+11 IF MDTYP["DATE"
SET Y=$$GET1^DIQ(DD,MDIENS,MDFLD,"I")
if Y]""
DO XMLDT(MDTAG,Y)
QUIT
+12 DO XMLDATA(MDTAG,$$GET1^DIQ(DD,MDIENS,MDFLD,MDFMT))
End DoDot:1
+13 DO XMLFTR("RECORD")
+14 QUIT
+15 ;
SETACL ; Sets the ACL for an Item
+1 ; P2(0)=Item
+2 ; P2(1)=User ID (DUZ)
+3 ; P2(2)=Access Level
+4 NEW MDIEN,MDFDA
+5 SET MDIEN=$ORDER(^MDC(704.001,"PK",P2(0),P2(1),0))
+6 if 'MDIEN
Begin DoDot:1
+7 SET MDFDA(704.001,"+1,",.01)=P2(0)
+8 SET MDFDA(704.001,"+1,",.02)=P2(1)
+9 SET MDIEN="+1"
End DoDot:1
+10 SET MDFDA(704.001,MDIEN_",",.03)=$GET(P2(2),0)
+11 DO UPDATE^DIE("","MDFDA")
+12 SET @RESULTS@(0)="1^ACL Updated."
+13 QUIT
+14 ;
DELACL ; Removes and item from ACL
+1 ; P2(0)=Item
+2 ; P2(1)=User ID (DUZ) - if blank or undefined deletes all record for P2(0)
+3 NEW MDIEN,MDFDA,MDUSER
+4 if $GET(P2(1))]""
Begin DoDot:1
+5 SET MDIEN=$ORDER(^MDC(704.001,"PK",P2(0),P2(1),0))
+6 if MDIEN
Begin DoDot:2
+7 SET MDFDA(704.001,MDIEN_",",.01)="@"
End DoDot:2
End DoDot:1
+8 if $GET(P2(1))=""
Begin DoDot:1
+9 SET MDUSER=""
+10 FOR
SET MDUSER=$ORDER(^MDC(704.001,"PK",P2(0),MDUSER))
if MDUSER=""
QUIT
Begin DoDot:2
+11 SET MDIEN=$ORDER(^MDC(704.001,"PK",P2(0),MDUSER,0))
+12 SET MDFDA(704.001,MDIEN_",",.01)="@"
End DoDot:2
End DoDot:1
+13 if $DATA(MDFDA)
DO UPDATE^DIE("","MDFDA")
+14 SET @RESULTS@(0)="1^ACL Updated."
+15 QUIT
+16 ;
SENDMAIL ; Sends an EMail Message
+1 ; Example of the P2(0..n) array
+2 ; P2(0)="SUB:Message Subject"
+3 ; P2(1)="TEXT:THIS IS LINE 1"
+4 ; P2(2)="TEXT:THIS IS LINE 2"
+5 ; P2(3)="TO:user.one@domain.ext;user.two@domain.ext"
+6 NEW MDTO,MDTEXT,XMDUZ,XMSUB,XMTEXT,XMY
+7 SET XMDUZ="Clinical Procedure Notification System"
+8 SET XMTEXT="MDTEXT("
+9 SET X=""
FOR
SET X=$ORDER(P2(X))
if X=""
QUIT
Begin DoDot:1
+10 IF P2(X)?1"SUB:".E
SET XMSUB=$PIECE(P2(X),":",2,250)
QUIT
+11 IF P2(X)?1"TO:".E
Begin DoDot:2
+12 ; We can store recipient lists as ';' delimited strings - Just like Outlook :)
SET MDTO=$PIECE(P2(X),"TO:",2,250)
+13 IF MDTO]""
FOR Y=1:1:$LENGTH(MDTO,";")
SET XMY($PIECE(MDTO,";",Y))=""
End DoDot:2
QUIT
+14 IF P2(X)?1"TEXT:".E
Begin DoDot:2
+15 SET Y=$ORDER(MDTEXT(""),-1)+1
SET MDTEXT(Y,0)=$PIECE(P2(X),"TEXT:",2,250)
End DoDot:2
QUIT
End DoDot:1
+16 SET MDTEXT(0)="^^"_$ORDER(MDTEXT(""),-1)_U_DT
+17 DO ^XMD
+18 SET @RESULTS@(0)="1^E-Mail Sent"
+19 QUIT
+20 ;
+21 ; Special extrinsic field calls
ID() QUIT "`"_IEN
ROWID() QUIT IEN
ICN() if MDFILE'=2
QUIT ""
QUIT $$GETICN^MPIF001(IEN)
NAME() QUIT $$GET1^DIQ(MDFILE,IEN,.01,"E")
SNSTV() NEW MDRET
DO PTSEC^DGSEC4(.MDRET,IEN)
QUIT ($GET(MDRET(1))'=0)
CCOW() ; IUser.getCCOWDFNItemName
SET X="patient.id.mrn.dfn_"_$PIECE($$SITE^VASITE(),U,3)
if '$$PROD^XUPROD()
SET X=X_"_test"
QUIT X
VITALSID() QUIT "{GMRV-"_IEN_"}"
VSTATUS() QUIT $SELECT(+$$GET1^DIQ(120.5,IEN_",",2,"I"):4,1:1)
+1 ;
XMLCMT(COMMENT) ; Add a comment to a document
+1 DO XMLADD("<!-- "_COMMENT_" -->")
+2 QUIT
+3 ;
XMLHDR(TAG) ; Add a header tag to the global
+1 SET TAG=$$TAGSAFE(TAG)
+2 DO XMLADD("<"_TAG_">")
+3 QUIT
+4 ;
XMLFTR(TAG) ; Add a footer tag to the global
+1 DO XMLHDR("/"_TAG)
+2 QUIT
+3 ;
XMLDATA(TAG,X) ; Add a data element to the global
+1 SET TAG=$$TAGSAFE(TAG)
+2 SET X=$$XMLSAFE(X)
+3 if X=""
QUIT
+4 DO XMLADD("<"_TAG_">"_X_"</"_TAG_">")
+5 QUIT
+6 ;
XMLFLDS(FLDLST,DD,FLDS) ; Build FLDS into an array of FLDS
+1 KILL FLDLST
+2 FOR X=1:1:$LENGTH(FLDS,";")
Begin DoDot:1
+3 SET FLDLST($PIECE(FLDS,";",X),"TAG")=$$GET1^DID(DD,$PIECE(FLDS,";",X),"","LABEL")
+4 SET FLDLST($PIECE(FLDS,";",X),"TYPE")=$$GET1^DID(DD,$PIECE(FLDS,";",X),"","TYPE")
End DoDot:1
+5 QUIT
+6 ;
XMLDT(TAG,X) ; Add date or date/time to the global
+1 SET TAG=$$TAGSAFE(TAG)
+2 ; No data
IF $GET(X)=""
DO XMLADD("<"_TAG_" />")
QUIT
+3 SET Y=(1700+$EXTRACT(X,1,3))_"-"_$EXTRACT(X,4,5)_"-"_$EXTRACT(X,6,7)
+4 if X]"."
Begin DoDot:1
+5 SET X=X+.0000001
+6 SET Y=Y_" "_$EXTRACT(X,9,10)_":"_$EXTRACT(X,11,12)_":"_$EXTRACT(X,13,14)
End DoDot:1
+7 DO XMLDATA(TAG,Y)
+8 QUIT
+9 ;
XMLIDS(TAG,IDS,CLOSE) ; Add a data element to the global with ids
+1 NEW X,Y
+2 SET TAG="<"_$$TAGSAFE(TAG)
+3 FOR X=0:0
SET X=$ORDER(IDS(X))
if 'X
QUIT
Begin DoDot:1
+4 SET Y=""
FOR
SET Y=$ORDER(IDS(X,Y))
if Y=""
QUIT
Begin DoDot:2
+5 SET TAG=TAG_" "_Y_"="""_$$XMLSAFE(IDS(X,Y))_""""
End DoDot:2
End DoDot:1
+6 ; Close out the tag element
if $GET(CLOSE)
SET TAG=TAG_" /"
+7 SET TAG=TAG_">"
+8 DO XMLADD(TAG)
+9 QUIT
+10 ;
XMLADD(X) ; Add to the global
+1 SET @RESULTS@($ORDER(@RESULTS@(""),-1)+1)=$GET(X)
+2 QUIT
+3 ;
XMLSAFE(X) ; Transform X into XML safe data
+1 ; Strip off the spaces and make life easier
+2 DO STRIP(.X)
+3 SET X=$$TRNSLT(X,"&","&")
+4 SET X=$$TRNSLT(X,"<","<")
+5 SET X=$$TRNSLT(X,">",">")
+6 SET X=$$TRNSLT(X,"'","'")
+7 SET X=$$TRNSLT(X,"""",""")
+8 SET X=$$TRNSLT(X,":",":")
+9 QUIT X
+10 ;
TAGSAFE(X) ; Transform X into XML tag
+1 ; Remove starting numeric
if X?1N.E
SET X="_"_X
+2 QUIT $TRANSLATE(X," '`()<>*[]","__________")
+3 ;
STRIP(X) ; Strip off leading and trailing spaces
+1 FOR
if $EXTRACT(X)'=" "
QUIT
SET X=$EXTRACT(X,2,$LENGTH(X))
+2 FOR
if $EXTRACT(X,$LENGTH(X))'=" "
QUIT
SET X=$EXTRACT(X,1,$LENGTH(X)-1)
+3 QUIT
+4 ;
NEWDOC(ROOT,COMMENT) ; Start a new document
+1 KILL @RESULTS
+2 DO XMLADD("<?xml version=""1.0"" standalone=""yes""?>")
+3 DO XMLCMT("OPTION = "_$GET(OPTION,"NULL"))
+4 IF $GET(COMMENT)]""
DO XMLCMT(COMMENT)
+5 DO XMLCMT("P1 = "_$GET(P1,"NULL"))
+6 IF $DATA(P2)#2
DO XMLCMT("P2 = "_P2)
+7 SET X=""
FOR
SET X=$ORDER(P2(X))
if X=""
QUIT
DO XMLCMT("P2("_X_") = "_P2(X))
+8 DO XMLHDR($GET(ROOT,"RESULTS"))
+9 QUIT
+10 ;
ENDDOC(ROOT) ; End this document
+1 DO XMLFTR($GET(ROOT,"RESULTS"))
+2 QUIT
+3 ;
QUICKDOC(TAG,VALUE) ; Builds a single record, single field document
+1 DO NEWDOC()
+2 DO XMLHDR("RECORD")
+3 DO XMLDATA(TAG,VALUE)
+4 DO XMLFTR("RECORD")
+5 DO ENDDOC()
+6 QUIT
+7 ;
SRVRDT ; Returns Server Date/Time
+1 DO QUICKDOC("SERVER_DATE_TIME",$$NOW)
+2 QUIT
+3 ;
TRNSLT(X,X1,X2) ; Translate every Y to Z in X
+1 NEW Y
+2 ; Nothing to translate
if X'[X1
QUIT X
+3 SET Y=""
FOR
if X=""
QUIT
Begin DoDot:1
+4 IF X[X1
SET Y=Y_$PIECE(X,X1)_X2
SET X=$PIECE(X,X1,2,250)
QUIT
+5 SET Y=Y_X
SET X=""
End DoDot:1
+6 QUIT Y
+7 ;
+8 ; Extrinsic Functions
+9 ;
FDA(DD,IEN) ; Construct a standard FDA
+1 ; Returns ^TMP("MDCLIO",$J,{DD},{IEN:+1})
+2 QUIT $SELECT($GET(DD):$NAME(^TMP("MDCLIO",$JOB,DD,$GET(IEN,"+1")_",")),1:$NAME(^TMP("MDCLIO",$JOB)))
+3 ;
SQLDATE(X) ; Returns SQL standard XML Date/Time string from FM
+1 SET X=X+.0000001
+2 QUIT ($EXTRACT(X,1,3)+1700)_"-"_$EXTRACT(X,4,5)_"-"_$EXTRACT(X,6,7)_" "_$EXTRACT(X,9,10)_":"_$EXTRACT(X,11,12)_":"_$EXTRACT(X,13,14)
+3 ;
FMDT(X) ; Returns FM standard date/time from SQL style
+1 NEW Y
SET Y=X
+2 SET X=($EXTRACT(X,1,4)-1700)_$EXTRACT(X,6,7)_$EXTRACT(X,9,10)_"."_$EXTRACT(X,12,13)_$EXTRACT(X,15,16)_$EXTRACT(X,18,19)
+3 QUIT +X
+4 ;
NOW() ; Returns Date/Time
+1 DO NOW^%DTC
+2 QUIT $$SQLDATE(%)
+3 ;
TABLE(X) ; Return file number from the name
+1 QUIT $$FIND1^DIC(1,,"KXP",X)
+2 ;
