- 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 Feb 18, 2025@23:09:43 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