- 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 Feb 18, 2025@23:10:30 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 ;