Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: MDRPCOR

MDRPCOR.m

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