MDRPCOR ; HOIFO/DP - Object RPCs (TMDRecordId) ; [01-10-2003 09:14]
;;1.0;CLINICAL PROCEDURES;**17,20**;Apr 01, 2004;Build 9
; Description:
; This routine manages both the MDVCL components and
; the TMDRecordID object
;
; Integration Agreements:
; IA# 2054 [Supported] Call to DILF
; IA# 2055 [Supported] Call to DILFD
; IA# 2056 [Supported] Call to DIQ
; IA# 2263 [Supported] Call to XPAR
; IA# 3568 [Subscription] TIUCP call
; IA# 3266 [Subscription] Calls to DPTLK1
; IA# 3267 [Subscription] Call to DPTLK1
; IA# 10003 [Supported] Call to %DT
; IA# 10104 [Public] Call to XLFSTR
;
CHANGES ; [Procedure] Returns number of changes to save
S MDCHNG=0,(MDDD,MDIENS)=""
F S MDDD=$O(^TMP("MDFDA",$J,MDDD)) Q:MDDD="" D
.Q:$E(MDDD,1,$L(DD))'=DD ; Not even the right DD
.F S MDIENS=$O(^TMP("MDFDA",$J,MDDD,MDIENS)) Q:MDIENS="" D
..Q:$E(MDIENS,$L(MDIENS)-$L(IENS)+1,$L(MDIENS))'=IENS
..F FLD=0:0 S FLD=$O(^TMP("MDFDA",$J,MDDD,MDIENS,FLD)) Q:'FLD D
...S MDCHNG=MDCHNG+1
S @RESULTS@(0)=MDCHNG_"^Changes to Save"
Q
;
CHKVER ; [Procedure]
S @RESULTS@(0)=+$G(DATA)'<1
Q
;
CLEARFDA ; [Procedure] Discards changes in the FDA
S MDFDA=$NA(^TMP("MDFDA",$J))
F S MDFDA=$Q(@MDFDA) Q:MDFDA="" Q:$QS(MDFDA,2)'=$J D
.S MDDD=$QS(MDFDA,3),MDIENS=$QS(MDFDA,4)
.I MDIENS'?@(".E1"""_IENS_"""") Q
.I MDDD'?@("1"""_DD_""".E") Q
.K ^TMP("MDFDA",$J,MDDD,MDIENS)
S @RESULTS@(0)="1^FDA CLEARED"
Q
;
DELREC ; [Procedure] Delete a fileman record
D VAL^DIE(DD,IENS,.01,"FR","@",.MDRET,"MDDEL","MDERR")
I MDRET="^" D ERROR^MDRPCU($NA(^TMP($J)),.MDERR) Q
D FILE^DIE("","MDDEL","MDERR")
I $D(MDERR) D ERROR^MDRPCU($NA(^TMP($J)),.MDERR) Q
D RPC(.X,"CLEARFDA",DD,IENS)
S @RESULTS@(0)="1^Record Deleted"
Q
;
DT ; [Procedure] Convert date/time via %DT
S DATA=$G(DATA,"NOW^TS")
S X=$P(DATA,U,1),%DT=$P(DATA,U,2)
D ^%DT
I Y<1 S @RESULTS@(0)=Y_U_"Invalid date/time input '"_X_"'"
E S @RESULTS@(0)=1_U_Y D DD^%DT S $P(@RESULTS@(0),U,3)=Y
Q
;
EXISTS ; [Procedure] Verify that a record exists
S X=$$ROOT^DILFD(DD,IENS)
S @RESULTS@(0)=$D(@(X_(+IENS)_",0)"))
Q
;
FILENAME ; [Procedure] Return a filename
I $$VFILE^DILFD(DD) S @RESULTS@(0)="1^"_$$GET1^DID(DD,"","","NAME")
E S @RESULTS@(0)="-1^Not a valid file #"
Q
;
GETCODES ; [Procedure] Returns set of codes
S MDTYPE=$$GET1^DID(DD,FLD,"","TYPE","","MDERR")
I $D(MDERR) D ERROR^MDRPCU($NA(^TMP($J)),.MDERR) Q
D:MDTYPE="SET"
.S MDSET=$$GET1^DID(DD,FLD,"","POINTER")
.F X=1:1:$L(MDSET,";")-1 D
..S @RESULTS@(X)=$P(MDSET,";",X)
.S @RESULTS@(0)=+$O(@RESULTS@(""),-1)_"^Set of Codes"
D:MDTYPE="POINTER"
.S MDPTR=$$GET1^DID(DD,FLD,"","POINTER")
.F X=0:0 S X=$O(@(U_MDPTR_"X)")) Q:'X D
..S Y=$O(@RESULTS@(""),-1)+1
..S @RESULTS@(Y)="`"_X_":"_$P(@(U_MDPTR_"X,0)"),U,1)
.S @RESULTS@(0)=+$O(@RESULTS@(""),-1)_"^Pointers as set of codes"
Q
;
GETDATA ; [Procedure] Returns data for a field
I $$GET1^DID(DD,FLD,"","TYPE")["WORD" D Q
.I $D(^TMP("MDFDA",$J,DD,IENS,FLD)) M ^TMP($J)=^TMP("MDFDA",$J,DD,IENS,FLD)
.E S X=$$GET1^DIQ(DD,IENS,FLD,"",$NA(^TMP($J)))
.S @RESULTS@(0)=+$O(@RESULTS@(""),-1)
I $$GET1^DID(DD,FLD,"","TYPE")["POINTER"&(DD=703.1)&(FLD=.05) D Q
.S @RESULTS@(0)=$$GET1^DIQ(DD,IENS,FLD,"I") Q
I $D(^TMP("MDFDA",$J,DD,IENS,FLD)) S Y=^(FLD) D Q
.I $G(DATA) S @RESULTS@(0)=Y Q ; Internal Format
.S @RESULTS@(0)=$$EXTERNAL^DILFD(DD,FLD,"",Y)
S @RESULTS@(0)=$$GET1^DIQ(DD,IENS,FLD,$S($G(DATA):"I",1:""))
Q
;
GETHELP ; [Procedure] Returns fileman help
D HELP^DIE(DD,IENS,FLD,"D")
D:'$O(^TMP("DIHELP",$J,0)) HELP^DIE(DD,IENS,FLD,"A")
I '$O(^TMP("DIHELP",$J,0)) D Q
.S @RESULTS@(0)=1
.S @RESULTS@(1)="SORRY: No help available"
M ^TMP($J)=^TMP("DIHELP",$J)
S @RESULTS@(0)=+$O(@RESULTS@(""),-1)
Q
;
GETIDS ; [Procedure] Returns list of required ID's
D FILE^DID(DD,"","REQUIRED IDENTIFIERS;NAME;ENTRIES","MDRET")
S X=$NA(MDRET("REQUIRED IDENTIFIERS",0))
F S X=$Q(@X) Q:X="" D
.S Y=$O(@RESULTS@(""),-1)+1
.S @RESULTS@(Y)=@X_U_$$GET1^DID(DD,@X,"","LABEL")_U_$$GET1^DID(DD,@X,"","TYPE")
S @RESULTS@(0)=+$O(@RESULTS@(""),-1)_U_MDRET("NAME")_U_MDRET("ENTRIES")
Q
;
GETLABEL ; [Procedure] Get field label/title
S MDLBL=$$GET1^DID(DD,FLD,"",$S($G(DATA):"TITLE",1:"LABEL"))
S:$G(DATA)&(MDLBL="") MDLBL=$$GET1^DID(DD,FLD,"","LABEL")
S @RESULTS@(0)=MDLBL_":"
Q
;
GETLST ; [Procedure] Get list of records
S IENS=$G(IENS),FLD=$G(FLD,"@;.01")
S:$P(FLD,";",1)'="@" FLD="@;"_FLD
D LIST^DIC(DD,IENS,FLD,"P",,,,,$G(DATA))
F X=0:0 S X=$O(^TMP("DILIST",$J,X)) Q:'X D
.S @RESULTS@(X)=DD_";"_^TMP("DILIST",$J,X,0)
S @RESULTS@(0)=+$O(@RESULTS@(""),-1)
F X=2:1 Q:$P(^TMP("DILIST",$J,0,"MAP"),U,X)="" D
.S @RESULTS@(0)=@RESULTS@(0)_U_$$GET1^DID(DD,$P(^TMP("DILIST",$J,0,"MAP"),U,X),"","LABEL")
Q
;
LOCK ; [Procedure] Lock a record
D LOCK^MDRPCU(.RESULTS,DD,IENS) Q
;
LOOKUP ; [Procedure] Lookup on a DD
I DD=2 D RPC(.RESULTS,"PTLKUP",DD,,,DATA) Q
D FIND^DIC(DD,IENS,.01,"P",DATA)
F X=0:0 S X=$O(^TMP("DILIST",$J,X)) Q:'X D
.S @RESULTS@(X)=DD_";"_$P(^TMP("DILIST",$J,X,0),U,1,2)
I '$D(^TMP($J)) S @RESULTS@(0)="-1^No entries found matching '"_DATA_"'"
E S @RESULTS@(0)=+$O(@RESULTS@(""),-1)
Q
;
NEWIEN ; [Procedure] Return next available IEN
S @RESULTS@(0)=$O(@($$ROOT^DILFD(DD,$G(IENS))_"""A"")"),-1)+1
Q
;
NEWREC ; [Procedure] Create a new record
I $G(DATA)]"" D Q:MDRET="^"
.D VAL^DIE(DD,"+1,"_IENS,$P(DATA,U,1),"F",$P(DATA,U,2,250),.MDRET,"MDNEW","MDERR")
.I MDRET="^" D ERROR^MDRPCU($NA(^TMP($J)),.MDERR)
S MDTMP="DATA"
F S MDTMP=$Q(@MDTMP) Q:MDTMP="" D Q:MDRET="^"
.D VAL^DIE(DD,"+1,"_IENS,$P(@MDTMP,U,1),"F",$P(@MDTMP,U,2,250),.MDRET,"MDNEW","MDERR")
.I MDRET="^" D ERROR^MDRPCU($NA(^TMP($J)),.MDERR)
D:$D(MDNEW) UPDATE^DIE("","MDNEW","MDIEN")
S @RESULTS@(0)=$G(MDIEN(1),"-1^Unable to create record")
Q
;
PTLKUP ; [Procedure] Patient lookup handled separately for security
D FIND^DIC(2,,"@;.01;.02;.03;.09","MP",DATA,45,"B^BS^BS5^SSN")
I $P($G(^TMP("DILIST",$J,0)),U,3) D Q
.S @RESULTS@(0)="-1^Too many entries found matching '"_DATA_"', please be more specific."
F MDX=0:0 S MDX=$O(^TMP("DILIST",$J,MDX)) Q:'MDX D
.S @RESULTS@(MDX)="2;"_$P(^TMP("DILIST",$J,MDX,0),U,1,5)
.S MDIENS=+^TMP("DILIST",$J,MDX,0)_","
.S $P(@RESULTS@(MDX),U,3)=$$GET1^DIQ(2,MDIENS,.02,"I")
.S $P(@RESULTS@(MDX),U,4)=$$GET1^DIQ(2,MDIENS,.03,"I")
.S $P(@RESULTS@(MDX),U,10)=$$DOB^DPTLK1(+MDIENS)
.S $P(@RESULTS@(MDX),U,11)=$$SSN^DPTLK1(+MDIENS)
I '$D(^TMP($J)) S @RESULTS@(0)="-1^No entries found matching '"_DATA_"'"
E S @RESULTS@(0)=+$O(@RESULTS@(""),-1)
Q
;
PTRLKUP ; [Procedure] Lookup a pointer field
S PTRDD=+$P($$GET1^DID(DD,FLD,"","SPECIFIER"),"P",2)
I PTRDD=8925.1 D Q ; Handle TIU Note lookup with TIU API
.S DATA=$$UP^XLFSTR(DATA)
.D LNGCP^TIUCP(.MDRET,DATA)
.I '$O(MDRET(0)) S @RESULTS@(0)=0 Q
.I $D(MDRET(44)),$P($P(MDRET(44),U,2),DATA)="" S @RESULTS@(0)=0 Q
.F X=0:0 S X=$O(MDRET(X)) Q:'X D:$P($P(MDRET(X),U,2),DATA)=""
..S @RESULTS@(X)="8925.1;"_MDRET(X)
.S @RESULTS@(0)=+$O(@RESULTS@(""),-1)
D FIND^DIC(PTRDD,"","","PM",DATA,151,"",$G(PTRSCRN))
F X=0:0 S X=$O(^TMP("DILIST",$J,X)) Q:'X D
.S @RESULTS@(X)=PTRDD_";"_^TMP("DILIST",$J,X,0)
S @RESULTS@(0)=+$O(@RESULTS@(""),-1)
Q
;
RENAME ; [Procedure] Rename a record
I DATA=""!(DATA="@") S @RESULTS@(0)="-1^Deletion Not Supported" Q
I $$DUPS^MDRPCU(DD,+IENS,DATA) D Q
.S @RESULTS@(0)="-1",@RESULTS@(1)="Duplicates not allowed"
D VAL^DIE(DD,IENS,.01,"EFHR",DATA,.MDRET,"MDRENAME","MDERR")
I MDRET="^" D ERROR^MDRPCU($NA(^TMP($J)),.MDERR) Q
D FILE^DIE("","MDRENAME")
S @RESULTS@(0)="1^"_MDRET(0)
K ^TMP("MDFDA",$J,DD,IENS,.01) ; In case of editing
Q
;
RPC(RESULTS,OPTION,DD,IENS,FLD,DATA) ; [Procedure] RPC call tag
NEW MDCHNG,MDDD,MDDEL,MDERR,MDFDA,MDGBL,MDIENS,MDIEN,MDLBL,MDNEW,MDPTR,MDRENAME,MDRET,MDSET,MDTYPE,MDUTL,PTRDD,PTRSCRN
S RESULTS=$NA(^TMP($J)) K @RESULTS
D:$T(@OPTION)]"" @OPTION
D:'$D(@RESULTS) BADRPC^MDRPCU("MD TMDRECORDID","MDRPCOR",OPTION)
D CLEAN^DILF
Q
;
SAVEFDA ; [Procedure] Save changes to the VistA database
K ^TMP("MDSAVE",$J)
S MDFDA=$NA(^TMP("MDFDA",$J))
F S MDFDA=$Q(@MDFDA) Q:MDFDA="" Q:$QS(MDFDA,2)'=$J D
.S MDDD=$QS(MDFDA,3),MDIENS=$QS(MDFDA,4)
.I MDIENS'?@(".E1"""_IENS_"""") Q
.I MDDD'?@("1"""_DD_""".E") Q
.M ^TMP("MDSAVE",$J,MDDD,MDIENS)=^TMP("MDFDA",$J,MDDD,MDIENS)
.K ^TMP("MDFDA",$J,MDDD,MDIENS)
I '$D(^TMP("MDSAVE",$J)) S @RESULTS@(0)="1^No changes to save" Q
D:IENS?1"+1,".NP ; New record
.D UPDATE^DIE("",$NA(^TMP("MDSAVE",$J)),"MDIEN","MDERR")
.I '$D(MDERR) S @RESULTS@(0)="1^New Record Created^"_MDIEN(1) Q
.D ERROR^MDRPCU($NA(^TMP($J)),.MDERR)
.M ^TMP("MDFDA",$J)=^TMP("MDSAVE",$J)
D:IENS'?1"+1,".NP ; Existing record
.D FILE^DIE("",$NA(^TMP("MDSAVE",$J)),"MDERR")
.I '$D(MDERR) S @RESULTS@(0)="1^FDA Saved" Q
.D ERROR^MDRPCU($NA(^TMP($J)),.MDERR)
.M ^TMP("MDFDA",$J)=^TMP("MDSAVE",$J)
K ^TMP("MDSAVE",$J)
I DD<702!(DD>703.1999) D Q
.S @RESULTS@(0)="-1^Non CLINICAL PROCEDURES DD number space"
I DD=702.09&(+$$GET^XPAR("SYS","MD DEVICE SURVEY TRANSMISSION",1)) D COL^MDDEVCL
Q
;
SETFDA ; [Procedure] Validate data and store in FDA
D VAL^DIE(DD,IENS,FLD,"F",.DATA,.MDRET,$NA(^TMP("MDFDA",$J)),"MDERR")
I MDRET="^" D ERROR^MDRPCU($NA(^TMP($J)),.MDERR) Q
S @RESULTS@(0)="1^FDA Set"
Q
;
UNLOCK ; [Procedure] Unlock a record
D UNLOCK^MDRPCU(.RESULTS,DD,IENS) Q
;
VALIDATE ; [Procedure] Validate data for a field
I ($G(DATA)="@"!($G(DATA)=""))&(FLD=.01) D Q
.S @RESULTS@(0)="-1^Record Deletion Not Allowed Here."
I FLD=.01 I $$DUPS^MDRPCU(DD,+IENS,DATA) D Q
.S @RESULTS@(0)="-1",@RESULTS@(1)="Duplicates not allowed"
S:$G(DATA)="@" DATA=""
I $$GET1^DID(DD,FLD,"","TYPE")["WORD" D Q
.S MDGBL=$NA(^TMP("MDFDA",$J,DD,IENS,FLD))
.K @MDGBL
.I $O(DATA(""))="" S @MDGBL="@",@RESULTS@(0)="1^OK" Q
.I $O(DATA(""),-1)=1&($G(DATA(1)))="" S @MDGBL="@",@RESULTS@(0)="1^OK" Q
.S X="" F S X=$O(DATA(X)) Q:X="" D
..S Y=$O(@MDGBL@(""""),-1)+1
..S @MDGBL@(Y)=DATA(X)
.S @MDGBL=$NA(^TMP("MDSAVE",$J,DD,IENS,FLD))
.S RESULTS(0)="1^WP"
D VAL^DIE(DD,IENS,FLD,"EF",$G(DATA),.MDRET,$NA(^TMP("MDFDA",$J)),"MDERR")
I MDRET="^" D ERROR^MDRPCU($NA(^TMP($J)),.MDERR) Q
S @RESULTS@(0)="1^"_MDRET(0)
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMDRPCOR 10381 printed Sep 23, 2025@19:20:08 Page 2
MDRPCOR ; HOIFO/DP - Object RPCs (TMDRecordId) ; [01-10-2003 09:14]
+1 ;;1.0;CLINICAL PROCEDURES;**17,20**;Apr 01, 2004;Build 9
+2 ; Description:
+3 ; This routine manages both the MDVCL components and
+4 ; the TMDRecordID object
+5 ;
+6 ; Integration Agreements:
+7 ; IA# 2054 [Supported] Call to DILF
+8 ; IA# 2055 [Supported] Call to DILFD
+9 ; IA# 2056 [Supported] Call to DIQ
+10 ; IA# 2263 [Supported] Call to XPAR
+11 ; IA# 3568 [Subscription] TIUCP call
+12 ; IA# 3266 [Subscription] Calls to DPTLK1
+13 ; IA# 3267 [Subscription] Call to DPTLK1
+14 ; IA# 10003 [Supported] Call to %DT
+15 ; IA# 10104 [Public] Call to XLFSTR
+16 ;
CHANGES ; [Procedure] Returns number of changes to save
+1 SET MDCHNG=0
SET (MDDD,MDIENS)=""
+2 FOR
SET MDDD=$ORDER(^TMP("MDFDA",$JOB,MDDD))
if MDDD=""
QUIT
Begin DoDot:1
+3 ; Not even the right DD
if $EXTRACT(MDDD,1,$LENGTH(DD))'=DD
QUIT
+4 FOR
SET MDIENS=$ORDER(^TMP("MDFDA",$JOB,MDDD,MDIENS))
if MDIENS=""
QUIT
Begin DoDot:2
+5 if $EXTRACT(MDIENS,$LENGTH(MDIENS)-$LENGTH(IENS)+1,$LENGTH(MDIENS))'=IENS
QUIT
+6 FOR FLD=0:0
SET FLD=$ORDER(^TMP("MDFDA",$JOB,MDDD,MDIENS,FLD))
if 'FLD
QUIT
Begin DoDot:3
+7 SET MDCHNG=MDCHNG+1
End DoDot:3
End DoDot:2
End DoDot:1
+8 SET @RESULTS@(0)=MDCHNG_"^Changes to Save"
+9 QUIT
+10 ;
CHKVER ; [Procedure]
+1 SET @RESULTS@(0)=+$GET(DATA)'<1
+2 QUIT
+3 ;
CLEARFDA ; [Procedure] Discards changes in the FDA
+1 SET MDFDA=$NAME(^TMP("MDFDA",$JOB))
+2 FOR
SET MDFDA=$QUERY(@MDFDA)
if MDFDA=""
QUIT
if $QSUBSCRIPT(MDFDA,2)'=$JOB
QUIT
Begin DoDot:1
+3 SET MDDD=$QSUBSCRIPT(MDFDA,3)
SET MDIENS=$QSUBSCRIPT(MDFDA,4)
+4 IF MDIENS'?@(".E1"""_IENS_"""")
QUIT
+5 IF MDDD'?@("1"""_DD_""".E")
QUIT
+6 KILL ^TMP("MDFDA",$JOB,MDDD,MDIENS)
End DoDot:1
+7 SET @RESULTS@(0)="1^FDA CLEARED"
+8 QUIT
+9 ;
DELREC ; [Procedure] Delete a fileman record
+1 DO VAL^DIE(DD,IENS,.01,"FR","@",.MDRET,"MDDEL","MDERR")
+2 IF MDRET="^"
DO ERROR^MDRPCU($NAME(^TMP($JOB)),.MDERR)
QUIT
+3 DO FILE^DIE("","MDDEL","MDERR")
+4 IF $DATA(MDERR)
DO ERROR^MDRPCU($NAME(^TMP($JOB)),.MDERR)
QUIT
+5 DO RPC(.X,"CLEARFDA",DD,IENS)
+6 SET @RESULTS@(0)="1^Record Deleted"
+7 QUIT
+8 ;
DT ; [Procedure] Convert date/time via %DT
+1 SET DATA=$GET(DATA,"NOW^TS")
+2 SET X=$PIECE(DATA,U,1)
SET %DT=$PIECE(DATA,U,2)
+3 DO ^%DT
+4 IF Y<1
SET @RESULTS@(0)=Y_U_"Invalid date/time input '"_X_"'"
+5 IF '$TEST
SET @RESULTS@(0)=1_U_Y
DO DD^%DT
SET $PIECE(@RESULTS@(0),U,3)=Y
+6 QUIT
+7 ;
EXISTS ; [Procedure] Verify that a record exists
+1 SET X=$$ROOT^DILFD(DD,IENS)
+2 SET @RESULTS@(0)=$DATA(@(X_(+IENS)_",0)"))
+3 QUIT
+4 ;
FILENAME ; [Procedure] Return a filename
+1 IF $$VFILE^DILFD(DD)
SET @RESULTS@(0)="1^"_$$GET1^DID(DD,"","","NAME")
+2 IF '$TEST
SET @RESULTS@(0)="-1^Not a valid file #"
+3 QUIT
+4 ;
GETCODES ; [Procedure] Returns set of codes
+1 SET MDTYPE=$$GET1^DID(DD,FLD,"","TYPE","","MDERR")
+2 IF $DATA(MDERR)
DO ERROR^MDRPCU($NAME(^TMP($JOB)),.MDERR)
QUIT
+3 if MDTYPE="SET"
Begin DoDot:1
+4 SET MDSET=$$GET1^DID(DD,FLD,"","POINTER")
+5 FOR X=1:1:$LENGTH(MDSET,";")-1
Begin DoDot:2
+6 SET @RESULTS@(X)=$PIECE(MDSET,";",X)
End DoDot:2
+7 SET @RESULTS@(0)=+$ORDER(@RESULTS@(""),-1)_"^Set of Codes"
End DoDot:1
+8 if MDTYPE="POINTER"
Begin DoDot:1
+9 SET MDPTR=$$GET1^DID(DD,FLD,"","POINTER")
+10 FOR X=0:0
SET X=$ORDER(@(U_MDPTR_"X)"))
if 'X
QUIT
Begin DoDot:2
+11 SET Y=$ORDER(@RESULTS@(""),-1)+1
+12 SET @RESULTS@(Y)="`"_X_":"_$PIECE(@(U_MDPTR_"X,0)"),U,1)
End DoDot:2
+13 SET @RESULTS@(0)=+$ORDER(@RESULTS@(""),-1)_"^Pointers as set of codes"
End DoDot:1
+14 QUIT
+15 ;
GETDATA ; [Procedure] Returns data for a field
+1 IF $$GET1^DID(DD,FLD,"","TYPE")["WORD"
Begin DoDot:1
+2 IF $DATA(^TMP("MDFDA",$JOB,DD,IENS,FLD))
MERGE ^TMP($JOB)=^TMP("MDFDA",$JOB,DD,IENS,FLD)
+3 IF '$TEST
SET X=$$GET1^DIQ(DD,IENS,FLD,"",$NAME(^TMP($JOB)))
+4 SET @RESULTS@(0)=+$ORDER(@RESULTS@(""),-1)
End DoDot:1
QUIT
+5 IF $$GET1^DID(DD,FLD,"","TYPE")["POINTER"&(DD=703.1)&(FLD=.05)
Begin DoDot:1
+6 SET @RESULTS@(0)=$$GET1^DIQ(DD,IENS,FLD,"I")
QUIT
End DoDot:1
QUIT
+7 IF $DATA(^TMP("MDFDA",$JOB,DD,IENS,FLD))
SET Y=^(FLD)
Begin DoDot:1
+8 ; Internal Format
IF $GET(DATA)
SET @RESULTS@(0)=Y
QUIT
+9 SET @RESULTS@(0)=$$EXTERNAL^DILFD(DD,FLD,"",Y)
End DoDot:1
QUIT
+10 SET @RESULTS@(0)=$$GET1^DIQ(DD,IENS,FLD,$SELECT($GET(DATA):"I",1:""))
+11 QUIT
+12 ;
GETHELP ; [Procedure] Returns fileman help
+1 DO HELP^DIE(DD,IENS,FLD,"D")
+2 if '$ORDER(^TMP("DIHELP",$JOB,0))
DO HELP^DIE(DD,IENS,FLD,"A")
+3 IF '$ORDER(^TMP("DIHELP",$JOB,0))
Begin DoDot:1
+4 SET @RESULTS@(0)=1
+5 SET @RESULTS@(1)="SORRY: No help available"
End DoDot:1
QUIT
+6 MERGE ^TMP($JOB)=^TMP("DIHELP",$JOB)
+7 SET @RESULTS@(0)=+$ORDER(@RESULTS@(""),-1)
+8 QUIT
+9 ;
GETIDS ; [Procedure] Returns list of required ID's
+1 DO FILE^DID(DD,"","REQUIRED IDENTIFIERS;NAME;ENTRIES","MDRET")
+2 SET X=$NAME(MDRET("REQUIRED IDENTIFIERS",0))
+3 FOR
SET X=$QUERY(@X)
if X=""
QUIT
Begin DoDot:1
+4 SET Y=$ORDER(@RESULTS@(""),-1)+1
+5 SET @RESULTS@(Y)=@X_U_$$GET1^DID(DD,@X,"","LABEL")_U_$$GET1^DID(DD,@X,"","TYPE")
End DoDot:1
+6 SET @RESULTS@(0)=+$ORDER(@RESULTS@(""),-1)_U_MDRET("NAME")_U_MDRET("ENTRIES")
+7 QUIT
+8 ;
GETLABEL ; [Procedure] Get field label/title
+1 SET MDLBL=$$GET1^DID(DD,FLD,"",$SELECT($GET(DATA):"TITLE",1:"LABEL"))
+2 if $GET(DATA)&(MDLBL="")
SET MDLBL=$$GET1^DID(DD,FLD,"","LABEL")
+3 SET @RESULTS@(0)=MDLBL_":"
+4 QUIT
+5 ;
GETLST ; [Procedure] Get list of records
+1 SET IENS=$GET(IENS)
SET FLD=$GET(FLD,"@;.01")
+2 if $PIECE(FLD,";",1)'="@"
SET FLD="@;"_FLD
+3 DO LIST^DIC(DD,IENS,FLD,"P",,,,,$GET(DATA))
+4 FOR X=0:0
SET X=$ORDER(^TMP("DILIST",$JOB,X))
if 'X
QUIT
Begin DoDot:1
+5 SET @RESULTS@(X)=DD_";"_^TMP("DILIST",$JOB,X,0)
End DoDot:1
+6 SET @RESULTS@(0)=+$ORDER(@RESULTS@(""),-1)
+7 FOR X=2:1
if $PIECE(^TMP("DILIST",$JOB,0,"MAP"),U,X)=""
QUIT
Begin DoDot:1
+8 SET @RESULTS@(0)=@RESULTS@(0)_U_$$GET1^DID(DD,$PIECE(^TMP("DILIST",$JOB,0,"MAP"),U,X),"","LABEL")
End DoDot:1
+9 QUIT
+10 ;
LOCK ; [Procedure] Lock a record
+1 DO LOCK^MDRPCU(.RESULTS,DD,IENS)
QUIT
+2 ;
LOOKUP ; [Procedure] Lookup on a DD
+1 IF DD=2
DO RPC(.RESULTS,"PTLKUP",DD,,,DATA)
QUIT
+2 DO FIND^DIC(DD,IENS,.01,"P",DATA)
+3 FOR X=0:0
SET X=$ORDER(^TMP("DILIST",$JOB,X))
if 'X
QUIT
Begin DoDot:1
+4 SET @RESULTS@(X)=DD_";"_$PIECE(^TMP("DILIST",$JOB,X,0),U,1,2)
End DoDot:1
+5 IF '$DATA(^TMP($JOB))
SET @RESULTS@(0)="-1^No entries found matching '"_DATA_"'"
+6 IF '$TEST
SET @RESULTS@(0)=+$ORDER(@RESULTS@(""),-1)
+7 QUIT
+8 ;
NEWIEN ; [Procedure] Return next available IEN
+1 SET @RESULTS@(0)=$ORDER(@($$ROOT^DILFD(DD,$GET(IENS))_"""A"")"),-1)+1
+2 QUIT
+3 ;
NEWREC ; [Procedure] Create a new record
+1 IF $GET(DATA)]""
Begin DoDot:1
+2 DO VAL^DIE(DD,"+1,"_IENS,$PIECE(DATA,U,1),"F",$PIECE(DATA,U,2,250),.MDRET,"MDNEW","MDERR")
+3 IF MDRET="^"
DO ERROR^MDRPCU($NAME(^TMP($JOB)),.MDERR)
End DoDot:1
if MDRET="^"
QUIT
+4 SET MDTMP="DATA"
+5 FOR
SET MDTMP=$QUERY(@MDTMP)
if MDTMP=""
QUIT
Begin DoDot:1
+6 DO VAL^DIE(DD,"+1,"_IENS,$PIECE(@MDTMP,U,1),"F",$PIECE(@MDTMP,U,2,250),.MDRET,"MDNEW","MDERR")
+7 IF MDRET="^"
DO ERROR^MDRPCU($NAME(^TMP($JOB)),.MDERR)
End DoDot:1
if MDRET="^"
QUIT
+8 if $DATA(MDNEW)
DO UPDATE^DIE("","MDNEW","MDIEN")
+9 SET @RESULTS@(0)=$GET(MDIEN(1),"-1^Unable to create record")
+10 QUIT
+11 ;
PTLKUP ; [Procedure] Patient lookup handled separately for security
+1 DO FIND^DIC(2,,"@;.01;.02;.03;.09","MP",DATA,45,"B^BS^BS5^SSN")
+2 IF $PIECE($GET(^TMP("DILIST",$JOB,0)),U,3)
Begin DoDot:1
+3 SET @RESULTS@(0)="-1^Too many entries found matching '"_DATA_"', please be more specific."
End DoDot:1
QUIT
+4 FOR MDX=0:0
SET MDX=$ORDER(^TMP("DILIST",$JOB,MDX))
if 'MDX
QUIT
Begin DoDot:1
+5 SET @RESULTS@(MDX)="2;"_$PIECE(^TMP("DILIST",$JOB,MDX,0),U,1,5)
+6 SET MDIENS=+^TMP("DILIST",$JOB,MDX,0)_","
+7 SET $PIECE(@RESULTS@(MDX),U,3)=$$GET1^DIQ(2,MDIENS,.02,"I")
+8 SET $PIECE(@RESULTS@(MDX),U,4)=$$GET1^DIQ(2,MDIENS,.03,"I")
+9 SET $PIECE(@RESULTS@(MDX),U,10)=$$DOB^DPTLK1(+MDIENS)
+10 SET $PIECE(@RESULTS@(MDX),U,11)=$$SSN^DPTLK1(+MDIENS)
End DoDot:1
+11 IF '$DATA(^TMP($JOB))
SET @RESULTS@(0)="-1^No entries found matching '"_DATA_"'"
+12 IF '$TEST
SET @RESULTS@(0)=+$ORDER(@RESULTS@(""),-1)
+13 QUIT
+14 ;
PTRLKUP ; [Procedure] Lookup a pointer field
+1 SET PTRDD=+$PIECE($$GET1^DID(DD,FLD,"","SPECIFIER"),"P",2)
+2 ; Handle TIU Note lookup with TIU API
IF PTRDD=8925.1
Begin DoDot:1
+3 SET DATA=$$UP^XLFSTR(DATA)
+4 DO LNGCP^TIUCP(.MDRET,DATA)
+5 IF '$ORDER(MDRET(0))
SET @RESULTS@(0)=0
QUIT
+6 IF $DATA(MDRET(44))
IF $PIECE($PIECE(MDRET(44),U,2),DATA)=""
SET @RESULTS@(0)=0
QUIT
+7 FOR X=0:0
SET X=$ORDER(MDRET(X))
if 'X
QUIT
if $PIECE($PIECE(MDRET(X),U,2),DATA)=""
Begin DoDot:2
+8 SET @RESULTS@(X)="8925.1;"_MDRET(X)
End DoDot:2
+9 SET @RESULTS@(0)=+$ORDER(@RESULTS@(""),-1)
End DoDot:1
QUIT
+10 DO FIND^DIC(PTRDD,"","","PM",DATA,151,"",$GET(PTRSCRN))
+11 FOR X=0:0
SET X=$ORDER(^TMP("DILIST",$JOB,X))
if 'X
QUIT
Begin DoDot:1
+12 SET @RESULTS@(X)=PTRDD_";"_^TMP("DILIST",$JOB,X,0)
End DoDot:1
+13 SET @RESULTS@(0)=+$ORDER(@RESULTS@(""),-1)
+14 QUIT
+15 ;
RENAME ; [Procedure] Rename a record
+1 IF DATA=""!(DATA="@")
SET @RESULTS@(0)="-1^Deletion Not Supported"
QUIT
+2 IF $$DUPS^MDRPCU(DD,+IENS,DATA)
Begin DoDot:1
+3 SET @RESULTS@(0)="-1"
SET @RESULTS@(1)="Duplicates not allowed"
End DoDot:1
QUIT
+4 DO VAL^DIE(DD,IENS,.01,"EFHR",DATA,.MDRET,"MDRENAME","MDERR")
+5 IF MDRET="^"
DO ERROR^MDRPCU($NAME(^TMP($JOB)),.MDERR)
QUIT
+6 DO FILE^DIE("","MDRENAME")
+7 SET @RESULTS@(0)="1^"_MDRET(0)
+8 ; In case of editing
KILL ^TMP("MDFDA",$JOB,DD,IENS,.01)
+9 QUIT
+10 ;
RPC(RESULTS,OPTION,DD,IENS,FLD,DATA) ; [Procedure] RPC call tag
+1 NEW MDCHNG,MDDD,MDDEL,MDERR,MDFDA,MDGBL,MDIENS,MDIEN,MDLBL,MDNEW,MDPTR,MDRENAME,MDRET,MDSET,MDTYPE,MDUTL,PTRDD,PTRSCRN
+2 SET RESULTS=$NAME(^TMP($JOB))
KILL @RESULTS
+3 if $TEXT(@OPTION)]""
DO @OPTION
+4 if '$DATA(@RESULTS)
DO BADRPC^MDRPCU("MD TMDRECORDID","MDRPCOR",OPTION)
+5 DO CLEAN^DILF
+6 QUIT
+7 ;
SAVEFDA ; [Procedure] Save changes to the VistA database
+1 KILL ^TMP("MDSAVE",$JOB)
+2 SET MDFDA=$NAME(^TMP("MDFDA",$JOB))
+3 FOR
SET MDFDA=$QUERY(@MDFDA)
if MDFDA=""
QUIT
if $QSUBSCRIPT(MDFDA,2)'=$JOB
QUIT
Begin DoDot:1
+4 SET MDDD=$QSUBSCRIPT(MDFDA,3)
SET MDIENS=$QSUBSCRIPT(MDFDA,4)
+5 IF MDIENS'?@(".E1"""_IENS_"""")
QUIT
+6 IF MDDD'?@("1"""_DD_""".E")
QUIT
+7 MERGE ^TMP("MDSAVE",$JOB,MDDD,MDIENS)=^TMP("MDFDA",$JOB,MDDD,MDIENS)
+8 KILL ^TMP("MDFDA",$JOB,MDDD,MDIENS)
End DoDot:1
+9 IF '$DATA(^TMP("MDSAVE",$JOB))
SET @RESULTS@(0)="1^No changes to save"
QUIT
+10 ; New record
if IENS?1"+1,".NP
Begin DoDot:1
+11 DO UPDATE^DIE("",$NAME(^TMP("MDSAVE",$JOB)),"MDIEN","MDERR")
+12 IF '$DATA(MDERR)
SET @RESULTS@(0)="1^New Record Created^"_MDIEN(1)
QUIT
+13 DO ERROR^MDRPCU($NAME(^TMP($JOB)),.MDERR)
+14 MERGE ^TMP("MDFDA",$JOB)=^TMP("MDSAVE",$JOB)
End DoDot:1
+15 ; Existing record
if IENS'?1"+1,".NP
Begin DoDot:1
+16 DO FILE^DIE("",$NAME(^TMP("MDSAVE",$JOB)),"MDERR")
+17 IF '$DATA(MDERR)
SET @RESULTS@(0)="1^FDA Saved"
QUIT
+18 DO ERROR^MDRPCU($NAME(^TMP($JOB)),.MDERR)
+19 MERGE ^TMP("MDFDA",$JOB)=^TMP("MDSAVE",$JOB)
End DoDot:1
+20 KILL ^TMP("MDSAVE",$JOB)
+21 IF DD<702!(DD>703.1999)
Begin DoDot:1
+22 SET @RESULTS@(0)="-1^Non CLINICAL PROCEDURES DD number space"
End DoDot:1
QUIT
+23 IF DD=702.09&(+$$GET^XPAR("SYS","MD DEVICE SURVEY TRANSMISSION",1))
DO COL^MDDEVCL
+24 QUIT
+25 ;
SETFDA ; [Procedure] Validate data and store in FDA
+1 DO VAL^DIE(DD,IENS,FLD,"F",.DATA,.MDRET,$NAME(^TMP("MDFDA",$JOB)),"MDERR")
+2 IF MDRET="^"
DO ERROR^MDRPCU($NAME(^TMP($JOB)),.MDERR)
QUIT
+3 SET @RESULTS@(0)="1^FDA Set"
+4 QUIT
+5 ;
UNLOCK ; [Procedure] Unlock a record
+1 DO UNLOCK^MDRPCU(.RESULTS,DD,IENS)
QUIT
+2 ;
VALIDATE ; [Procedure] Validate data for a field
+1 IF ($GET(DATA)="@"!($GET(DATA)=""))&(FLD=.01)
Begin DoDot:1
+2 SET @RESULTS@(0)="-1^Record Deletion Not Allowed Here."
End DoDot:1
QUIT
+3 IF FLD=.01
IF $$DUPS^MDRPCU(DD,+IENS,DATA)
Begin DoDot:1
+4 SET @RESULTS@(0)="-1"
SET @RESULTS@(1)="Duplicates not allowed"
End DoDot:1
QUIT
+5 if $GET(DATA)="@"
SET DATA=""
+6 IF $$GET1^DID(DD,FLD,"","TYPE")["WORD"
Begin DoDot:1
+7 SET MDGBL=$NAME(^TMP("MDFDA",$JOB,DD,IENS,FLD))
+8 KILL @MDGBL
+9 IF $ORDER(DATA(""))=""
SET @MDGBL="@"
SET @RESULTS@(0)="1^OK"
QUIT
+10 IF $ORDER(DATA(""),-1)=1&($GET(DATA(1)))=""
SET @MDGBL="@"
SET @RESULTS@(0)="1^OK"
QUIT
+11 SET X=""
FOR
SET X=$ORDER(DATA(X))
if X=""
QUIT
Begin DoDot:2
+12 SET Y=$ORDER(@MDGBL@(""""),-1)+1
+13 SET @MDGBL@(Y)=DATA(X)
End DoDot:2
+14 SET @MDGBL=$NAME(^TMP("MDSAVE",$JOB,DD,IENS,FLD))
+15 SET RESULTS(0)="1^WP"
End DoDot:1
QUIT
+16 DO VAL^DIE(DD,IENS,FLD,"EF",$GET(DATA),.MDRET,$NAME(^TMP("MDFDA",$JOB)),"MDERR")
+17 IF MDRET="^"
DO ERROR^MDRPCU($NAME(^TMP($JOB)),.MDERR)
QUIT
+18 SET @RESULTS@(0)="1^"_MDRET(0)
+19 QUIT
+20 ;
