RORRP040 ;HCIOFO/SG - RPC: LOCAL REGISTRY FIELDS ; 8/25/05 12:23pm
;;1.5;CLINICAL CASE REGISTRIES;;Feb 17, 2006
;
Q
;
;***** LOADS THE LIST OF LOCAL FIELD DEFINITIONS
; RPC: [ROR LIST LOCAL FIELDS]
;
; .RESULTS Reference to a local variable where the results
; are returned to.
;
; REGIEN Registry IEN
;
; FLAGS Flags that control processing:
; I Include inactive field definitions
;
; [LOCK] Lock the local fields before loading the data and
; leave them locked.
;
; Return Values:
;
; A negative value of the first "^"-piece of the RESULTS(0) node
; indicates an error (see the RPCSTK^RORERR procedure for details).
;
; If the local field table cannot be locked then the second
; "^"-piece of the @RESULTS@(0) will be greater than 0 and the
; node will contain the lock descriptor.
;
; @RESULTS@(0) Result Descriptor
; ^01: Number of local fields
; ^02: Lock Descriptor (see the
; ... LOCK^RORLOCK for details)
;
; The subsequent nodes will contain local field definitions.
;
; See the description of the ROR LIST LOCAL FIELDS remote procedure
; for more details.
;
LFLIST(RESULTS,REGIEN,FLAGS,LOCK) ;
N CNT,IEN,IENS,LOCKRC,NAME,RC,ROOT,RORBUF,RORERRDL,RORMSG,TMP
D CLEAR^RORERR("LFLIST^RORRP040",1)
K RESULTS S RESULTS=$$ALLOC^RORTMP()
;
;=== Check the parameters
S RC=0 D I RC<0 D RPCSTK^RORERR(.RESULTS,RC) Q
. ;--- Registry IEN
. I $G(REGIEN)'>0 D Q
. . S RC=$$ERROR^RORERR(-88,,,,"REGIEN",$G(REGIEN))
. S REGIEN=+REGIEN
. ;--- Flags
. S FLAGS=$G(FLAGS)
;
;=== Lock the ROR LOCAL FIELD file
I $G(LOCK) D I LOCKRC<0 D RPCSTK^RORERR(.RESULTS,LOCKRC) Q
. S LOCKRC=$$LOCK^RORLOCK(799.53)
;
;=== Load the list of field definitions
S DT=$$DT^XLFDT
S ROOT=$$ROOT^DILFD(799.53,,1)
S NAME="",(CNT,RC)=0
F S NAME=$O(@ROOT@("KEY",REGIEN,NAME)) Q:NAME="" D Q:RC<0
. S IEN=0
. F S IEN=$O(@ROOT@("KEY",REGIEN,NAME,IEN)) Q:IEN'>0 D Q:RC<0
. . S IENS=IEN_"," K RORBUF,RORMSG
. . D GETS^DIQ(799.53,IENS,".01;.02;1","I","RORBUF","RORMSG")
. . I $G(DIERR) S RC=$$DBS^RORERR("RORMSG",-9,,,798.53) Q
. . ;--- Skip inactive field definition if necessary
. . I FLAGS'["I" D I TMP>0 Q:TMP'>DT
. . . S TMP=+$G(RORBUF(799.53,IENS,.02,"I"))
. . ;--- Add the definition to the list
. . S CNT=CNT+1,RORBUF=IEN
. . S $P(RORBUF,U,2)=$G(RORBUF(799.53,IENS,.01,"I"))
. . S $P(RORBUF,U,3)=$G(RORBUF(799.53,IENS,.02,"I"))
. . S $P(RORBUF,U,4)=$G(RORBUF(799.53,IENS,1,"I"))
. . S @RESULTS@(CNT)=RORBUF
I RC<0 D RPCSTK^RORERR(.RESULTS,RC) Q
;
;=== Success
S @RESULTS@(0)=CNT_U_$G(LOCKRC)
Q
;
;***** UPDATES THE LIST OF LOCAL FIELD DEFINITIONS
; RPC: [ROR UPDATE LOCAL FIELDS]
;
; .RESULTS Reference to a local variable
;
; REGIEN Registry IEN
;
; [CANCEL] Cancel the update and unlock the local fields
;
; [.LFLST] Reference to a local variable that contains
; a list of local fields
; .LFLST(
;
; i) Local Field Descriptor
; ^01: IEN
; ^02: Name
; ^03: Inactivation Date (FileMan)
; ^04: Description
;
; See the description of the ROR UPDATE LOCAL FIELDS remote procedure
; for more details.
;
; Return Values:
;
; A negative value of the first "^"-piece of the RESULTS(0) node
; indicates an error (see the RPCSTK^RORERR procedure for details).
;
; Otherwise, zero is returned in the RESULTS(0).
;
LFLUPD(RESULTS,REGIEN,CANCEL,LFLST) ;
N ECNT,I,IEN,RC,RORERRDL,TMP
K RESULTS
D CLEAR^RORERR("LFLUPD^RORRP040",1)
S (ECNT,RC)=0
;
;=== Check the parameters
S RC=0 D I RC<0 D RPCSTK^RORERR(.RESULTS,RC) Q
. ;--- Registry IEN
. I $G(REGIEN)'>0 D Q
. . S RC=$$ERROR^RORERR(-88,,,,"REGIEN",$G(REGIEN))
. S REGIEN=+REGIEN
. ;--- List of local fields
. S I=0
. F S I=$O(LFLST(I)) Q:I'>0 D
. . S IEN=+$P(LFLST(I),U) S:IEN>0 LFLST("AI",IEN)=I
;
D:'$G(CANCEL)
. N DA,DIK,IENS,NAME,RORFDA,RORMSG,XREF
. ;--- Delete the old records
. S DIK=$$ROOT^DILFD(799.53)
. S XREF=DIK_"""KEY"","_REGIEN_")"
. S NAME=""
. F S NAME=$O(@XREF@(NAME)) Q:NAME="" D
. . S DA=""
. . F S DA=$O(@XREF@(NAME,DA)) Q:DA="" D
. . . D:'$D(LFLST("AI",DA)) LVDEL(DA),^DIK
. ;--- Store the new records
. S NODE=$$CREF^DILF(DIK)
. S I=0
. F S I=$O(LFLST(I)) Q:I'>0 D
. . S IEN=+$P(LFLST(I),U)
. . S IENS=$S(IEN'>0:"+1,",$D(@NODE@(IEN)):IEN_",",1:"+1,")
. . K RORFDA,RORMSG
. . S RORFDA(799.53,IENS,.01)=$P(LFLST(I),U,2) ; NAME
. . S RORFDA(799.53,IENS,.02)=$P(LFLST(I),U,3) ; DATE OF INACTIV.
. . S RORFDA(799.53,IENS,.03)=REGIEN ; REGISTRY
. . S RORFDA(799.53,IENS,1)=$P(LFLST(I),U,4) ; DESCRIPTION
. . I $E(IENS,1)="+" D
. . . D UPDATE^DIE(,"RORFDA",,"RORMSG")
. . E D FILE^DIE(,"RORFDA","RORMSG")
. . I $G(DIERR) D S ECNT=ECNT+1
. . . D DBS^RORERR("RORMSG",-9,,,799.53,IENS)
;
;=== Unlock the file and check for errors
D UNLOCK^RORLOCK(799.53)
I ECNT>0 D RPCSTK^RORERR(.RESULTS,-9) Q
;--- Success
S RESULTS(0)=0
Q
;
;***** DELETES THE LOCAL FIELD FROM THE PATIENTS' RECORDS
;
; LFIEN IEN of the local field (file #799.53)
;
LVDEL(LFIEN) ;
N DA,DIK,XREF
S XREF=$$ROOT^DILFD(798)_"""ALF"","_LFIEN_")"
S DA(1)=""
F S DA(1)=$O(@XREF@(DA(1))) Q:DA(1)="" D
. S DA="",DIK=$$ROOT^DILFD(798.02,","_DA(1)_",")
. F S DA=$O(@XREF@(DA(1),DA)) Q:DA="" D ^DIK
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRORRP040 5665 printed Sep 23, 2025@19:19:19 Page 2
RORRP040 ;HCIOFO/SG - RPC: LOCAL REGISTRY FIELDS ; 8/25/05 12:23pm
+1 ;;1.5;CLINICAL CASE REGISTRIES;;Feb 17, 2006
+2 ;
+3 QUIT
+4 ;
+5 ;***** LOADS THE LIST OF LOCAL FIELD DEFINITIONS
+6 ; RPC: [ROR LIST LOCAL FIELDS]
+7 ;
+8 ; .RESULTS Reference to a local variable where the results
+9 ; are returned to.
+10 ;
+11 ; REGIEN Registry IEN
+12 ;
+13 ; FLAGS Flags that control processing:
+14 ; I Include inactive field definitions
+15 ;
+16 ; [LOCK] Lock the local fields before loading the data and
+17 ; leave them locked.
+18 ;
+19 ; Return Values:
+20 ;
+21 ; A negative value of the first "^"-piece of the RESULTS(0) node
+22 ; indicates an error (see the RPCSTK^RORERR procedure for details).
+23 ;
+24 ; If the local field table cannot be locked then the second
+25 ; "^"-piece of the @RESULTS@(0) will be greater than 0 and the
+26 ; node will contain the lock descriptor.
+27 ;
+28 ; @RESULTS@(0) Result Descriptor
+29 ; ^01: Number of local fields
+30 ; ^02: Lock Descriptor (see the
+31 ; ... LOCK^RORLOCK for details)
+32 ;
+33 ; The subsequent nodes will contain local field definitions.
+34 ;
+35 ; See the description of the ROR LIST LOCAL FIELDS remote procedure
+36 ; for more details.
+37 ;
LFLIST(RESULTS,REGIEN,FLAGS,LOCK) ;
+1 NEW CNT,IEN,IENS,LOCKRC,NAME,RC,ROOT,RORBUF,RORERRDL,RORMSG,TMP
+2 DO CLEAR^RORERR("LFLIST^RORRP040",1)
+3 KILL RESULTS
SET RESULTS=$$ALLOC^RORTMP()
+4 ;
+5 ;=== Check the parameters
+6 SET RC=0
Begin DoDot:1
+7 ;--- Registry IEN
+8 IF $GET(REGIEN)'>0
Begin DoDot:2
+9 SET RC=$$ERROR^RORERR(-88,,,,"REGIEN",$GET(REGIEN))
End DoDot:2
QUIT
+10 SET REGIEN=+REGIEN
+11 ;--- Flags
+12 SET FLAGS=$GET(FLAGS)
End DoDot:1
IF RC<0
DO RPCSTK^RORERR(.RESULTS,RC)
QUIT
+13 ;
+14 ;=== Lock the ROR LOCAL FIELD file
+15 IF $GET(LOCK)
Begin DoDot:1
+16 SET LOCKRC=$$LOCK^RORLOCK(799.53)
End DoDot:1
IF LOCKRC<0
DO RPCSTK^RORERR(.RESULTS,LOCKRC)
QUIT
+17 ;
+18 ;=== Load the list of field definitions
+19 SET DT=$$DT^XLFDT
+20 SET ROOT=$$ROOT^DILFD(799.53,,1)
+21 SET NAME=""
SET (CNT,RC)=0
+22 FOR
SET NAME=$ORDER(@ROOT@("KEY",REGIEN,NAME))
if NAME=""
QUIT
Begin DoDot:1
+23 SET IEN=0
+24 FOR
SET IEN=$ORDER(@ROOT@("KEY",REGIEN,NAME,IEN))
if IEN'>0
QUIT
Begin DoDot:2
+25 SET IENS=IEN_","
KILL RORBUF,RORMSG
+26 DO GETS^DIQ(799.53,IENS,".01;.02;1","I","RORBUF","RORMSG")
+27 IF $GET(DIERR)
SET RC=$$DBS^RORERR("RORMSG",-9,,,798.53)
QUIT
+28 ;--- Skip inactive field definition if necessary
+29 IF FLAGS'["I"
Begin DoDot:3
+30 SET TMP=+$GET(RORBUF(799.53,IENS,.02,"I"))
End DoDot:3
IF TMP>0
if TMP'>DT
QUIT
+31 ;--- Add the definition to the list
+32 SET CNT=CNT+1
SET RORBUF=IEN
+33 SET $PIECE(RORBUF,U,2)=$GET(RORBUF(799.53,IENS,.01,"I"))
+34 SET $PIECE(RORBUF,U,3)=$GET(RORBUF(799.53,IENS,.02,"I"))
+35 SET $PIECE(RORBUF,U,4)=$GET(RORBUF(799.53,IENS,1,"I"))
+36 SET @RESULTS@(CNT)=RORBUF
End DoDot:2
if RC<0
QUIT
End DoDot:1
if RC<0
QUIT
+37 IF RC<0
DO RPCSTK^RORERR(.RESULTS,RC)
QUIT
+38 ;
+39 ;=== Success
+40 SET @RESULTS@(0)=CNT_U_$GET(LOCKRC)
+41 QUIT
+42 ;
+43 ;***** UPDATES THE LIST OF LOCAL FIELD DEFINITIONS
+44 ; RPC: [ROR UPDATE LOCAL FIELDS]
+45 ;
+46 ; .RESULTS Reference to a local variable
+47 ;
+48 ; REGIEN Registry IEN
+49 ;
+50 ; [CANCEL] Cancel the update and unlock the local fields
+51 ;
+52 ; [.LFLST] Reference to a local variable that contains
+53 ; a list of local fields
+54 ; .LFLST(
+55 ;
+56 ; i) Local Field Descriptor
+57 ; ^01: IEN
+58 ; ^02: Name
+59 ; ^03: Inactivation Date (FileMan)
+60 ; ^04: Description
+61 ;
+62 ; See the description of the ROR UPDATE LOCAL FIELDS remote procedure
+63 ; for more details.
+64 ;
+65 ; Return Values:
+66 ;
+67 ; A negative value of the first "^"-piece of the RESULTS(0) node
+68 ; indicates an error (see the RPCSTK^RORERR procedure for details).
+69 ;
+70 ; Otherwise, zero is returned in the RESULTS(0).
+71 ;
LFLUPD(RESULTS,REGIEN,CANCEL,LFLST) ;
+1 NEW ECNT,I,IEN,RC,RORERRDL,TMP
+2 KILL RESULTS
+3 DO CLEAR^RORERR("LFLUPD^RORRP040",1)
+4 SET (ECNT,RC)=0
+5 ;
+6 ;=== Check the parameters
+7 SET RC=0
Begin DoDot:1
+8 ;--- Registry IEN
+9 IF $GET(REGIEN)'>0
Begin DoDot:2
+10 SET RC=$$ERROR^RORERR(-88,,,,"REGIEN",$GET(REGIEN))
End DoDot:2
QUIT
+11 SET REGIEN=+REGIEN
+12 ;--- List of local fields
+13 SET I=0
+14 FOR
SET I=$ORDER(LFLST(I))
if I'>0
QUIT
Begin DoDot:2
+15 SET IEN=+$PIECE(LFLST(I),U)
if IEN>0
SET LFLST("AI",IEN)=I
End DoDot:2
End DoDot:1
IF RC<0
DO RPCSTK^RORERR(.RESULTS,RC)
QUIT
+16 ;
+17 if '$GET(CANCEL)
Begin DoDot:1
+18 NEW DA,DIK,IENS,NAME,RORFDA,RORMSG,XREF
+19 ;--- Delete the old records
+20 SET DIK=$$ROOT^DILFD(799.53)
+21 SET XREF=DIK_"""KEY"","_REGIEN_")"
+22 SET NAME=""
+23 FOR
SET NAME=$ORDER(@XREF@(NAME))
if NAME=""
QUIT
Begin DoDot:2
+24 SET DA=""
+25 FOR
SET DA=$ORDER(@XREF@(NAME,DA))
if DA=""
QUIT
Begin DoDot:3
+26 if '$DATA(LFLST("AI",DA))
DO LVDEL(DA)
DO ^DIK
End DoDot:3
End DoDot:2
+27 ;--- Store the new records
+28 SET NODE=$$CREF^DILF(DIK)
+29 SET I=0
+30 FOR
SET I=$ORDER(LFLST(I))
if I'>0
QUIT
Begin DoDot:2
+31 SET IEN=+$PIECE(LFLST(I),U)
+32 SET IENS=$SELECT(IEN'>0:"+1,",$DATA(@NODE@(IEN)):IEN_",",1:"+1,")
+33 KILL RORFDA,RORMSG
+34 ; NAME
SET RORFDA(799.53,IENS,.01)=$PIECE(LFLST(I),U,2)
+35 ; DATE OF INACTIV.
SET RORFDA(799.53,IENS,.02)=$PIECE(LFLST(I),U,3)
+36 ; REGISTRY
SET RORFDA(799.53,IENS,.03)=REGIEN
+37 ; DESCRIPTION
SET RORFDA(799.53,IENS,1)=$PIECE(LFLST(I),U,4)
+38 IF $EXTRACT(IENS,1)="+"
Begin DoDot:3
+39 DO UPDATE^DIE(,"RORFDA",,"RORMSG")
End DoDot:3
+40 IF '$TEST
DO FILE^DIE(,"RORFDA","RORMSG")
+41 IF $GET(DIERR)
Begin DoDot:3
+42 DO DBS^RORERR("RORMSG",-9,,,799.53,IENS)
End DoDot:3
SET ECNT=ECNT+1
End DoDot:2
End DoDot:1
+43 ;
+44 ;=== Unlock the file and check for errors
+45 DO UNLOCK^RORLOCK(799.53)
+46 IF ECNT>0
DO RPCSTK^RORERR(.RESULTS,-9)
QUIT
+47 ;--- Success
+48 SET RESULTS(0)=0
+49 QUIT
+50 ;
+51 ;***** DELETES THE LOCAL FIELD FROM THE PATIENTS' RECORDS
+52 ;
+53 ; LFIEN IEN of the local field (file #799.53)
+54 ;
LVDEL(LFIEN) ;
+1 NEW DA,DIK,XREF
+2 SET XREF=$$ROOT^DILFD(798)_"""ALF"","_LFIEN_")"
+3 SET DA(1)=""
+4 FOR
SET DA(1)=$ORDER(@XREF@(DA(1)))
if DA(1)=""
QUIT
Begin DoDot:1
+5 SET DA=""
SET DIK=$$ROOT^DILFD(798.02,","_DA(1)_",")
+6 FOR
SET DA=$ORDER(@XREF@(DA(1),DA))
if DA=""
QUIT
DO ^DIK
End DoDot:1
+7 QUIT
