RORPUT01 ;HCIOFO/SG - EDIT LOINC AND DRUG CODE MULTIPLES ; 5/19/06 11:48am
;;1.5;CLINICAL CASE REGISTRIES;**1**;Feb 17, 2006;Build 24
;
Q
;
;***** ADDS THE RECORDS TO THE MULTIPLE
;
; REGIEN Registry IEN
; SUBFILE Subfile number
; LSTREF Reference to a list or the list itself (see the
; $$COMPNEXT^RORPUT01 function for more details).
;
; Return Values:
; <0 Error code
; 0 Ok
;
ADD(REGIEN,SUBFILE,LSTREF) ;
N BUF,IENS,ITEM,LI,NEXT,RC,RORFDA,RORMSG,TLI
S NEXT=$$COMPNEXT(LSTREF) Q:NEXT<0 NEXT
S IENS="?+1,"_(+REGIEN)_",",RC=0
F TLI=1:1 X NEXT Q:$G(BUF)'[";;" D Q:RC<0
. S BUF=$P(BUF,";;",2)
. D MES^RORKIDS(BUF)
. S BUF=$TR(BUF," ")
. F LI=1:1 S ITEM=$P(BUF,",",LI) Q:ITEM="" D Q:RC<0
. . S RORFDA(SUBFILE,IENS,.01)=ITEM
. . D UPDATE^DIE(,"RORFDA",,"RORMSG")
. . S:$G(DIERR) RC=$$DBS^RORERR("RORMSG",-9,,,SUBFILE,IENS)
Q RC
;
;***** RESTORES THE CDC DEFINITION
;
; Return Values:
; <0 Error code
; 0 Ok
;
CDCDEF() ;
N RC,RESULTS,RORBUF
D BMES^RORKIDS("Restoring the CDC definition...")
;--- Restore the definition from the transport global
M RORBUF=@XPDGREF@("RORCDCDEF")
S RORBUF="HIV CDC Form Template"
D SETPARM^RORRP038(.RESULTS,"ICRCDCDEF","PKG",.RORBUF)
Q:$G(RESULTS(0))<0 +RESULTS(0)
;--- Success
D MES^RORKIDS("The definition has been restored successfully.")
Q 0
;
;***** COMPILES THE 'NEXT' LOGIC
;
; PARAM Parameter defining the list of codes. It should be
; either a list of codes separated by commas or a full
; reference (TAG^ROUTINE) to a routine label after
; which the list is located. In the latter case, the
; list itself should look like this:
;
; ;
; ;***** SHORT DESCRIPTION OF THE LIST
; LABEL ;
; ;; Code1, Code2, ...
; ;; CodeN, ...
; ;
;
; There should be at least one line that does not
; contain ";;" after the list (or no lines at all).
;
; Return Values:
; <0 Error code
; "" The list is empty
; '="" A string that should be XECUTE'd to get the next
; buffer with the list data
;
COMPNEXT(PARAM) ;
N I,N,NEXT,RC Q:PARAM?." " ""
;--- Reference to a routine label
I PARAM?1.8UN1"^"1.8UN D Q NEXT
. S NEXT="S BUF=$T("_$P(PARAM,U)_"+TLI"_U_$P(PARAM,U,2)_")"
;--- List of codes separated by commas
S N=$L(PARAM,","),RC=0
F I=1:1:N I '($P(PARAM,",",I)?." "1.N." ") S RC=-88 Q
I RC<0,I=N S:$P(PARAM,",",N)?." " RC=0,N=N-1
I N>0,RC'<0 D Q NEXT
. S NEXT="S BUF=$P("""_";;"_$P(PARAM,",",1,N)_""",U,TLI)"
;--- Invalid parameter
Q $$ERROR^RORERR(-88,,,,"List of Codes",PARAM)
;
;***** ADDS ITEMS TO 'EXTRACTED RESULT' MULTIPLE OF FILE #798.1
;
; [RORREG] Registry IEN and registry name separated by the '^'
; (RegistryIEN^RegistryName).
;
; [RORLNCAD] Either a list of LOINC codes (without check digits)
; separated by commas or a full reference (TAG^ROUTINE)
; to a routine label after which the list is located.
;
; All spaces are removed from the lines of the list.
; See the $$COMPNEXT^RORPUT01 function for more
; details.
;
; If some of these parameters are omitted or equal to an empty
; strings, their values must be defined as the RORPARM("KIDS")
; sub-nodes of the same name.
;
; Return Values:
; <0 Error code
; 0 Ok
;
LOINCADD(RORREG,RORLNCAD) ;
N RC
D BMES^RORKIDS("Adding new LOINC codes to the EXTRACTED RESULT multiple...")
;--- Get the parameters
S:'$G(RORREG) RORREG=$$PARAM^RORKIDS("RORREG")
S:$G(RORLNCAD)="" RORLNCAD=$$PARAM^RORKIDS("RORLNCAD")
;--- Add new LOINC codes
S RC=$$ADD(+RORREG,798.112,RORLNCAD) Q:RC<0 RC
;--- Success
D MES^RORKIDS("The LOINC list has been updated successfully.")
Q 0
;
;***** REMOVES ITEMS FROM 'EXTRACTED RESULT' MULTIPLE OF FILE #798.1
;
; [RORREG] Registry IEN and registry name separated by the '^'
; (RegistryIEN^RegistryName).
;
; [RORLNCRM] Either a list of LOINC codes (without check digits)
; separated by commas or a full reference (TAG^ROUTINE)
; to a routine label after which the list is located.
;
; All spaces are removed from the lines of the list.
; See the $$COMPNEXT^RORPUT01 function for more
; details.
;
; If some of these parameters are omitted or equal to an empty
; strings, their values must be defined as the RORPARM("KIDS")
; sub-nodes of the same name.
;
; Return Values:
; <0 Error code
; 0 Ok
;
LOINCREM(RORREG,RORLNCRM) ;
N BUF,DA,DIK,IENS,IR,LCI,LOINC,NEXT,RC,RORBUF,RORMSG,TLI
D BMES^RORKIDS("Removing obsolete codes from the EXTRACTED RESULT multiple...")
;--- Get the parameters
S:'$G(RORREG) RORREG=$$PARAM^RORKIDS("RORREG")
S:$G(RORLNCRM)="" RORLNCRM=$$PARAM^RORKIDS("RORLNCRM")
;--- Delete unnecessary LOINC codes
S RC=$$REMOVE(+RORREG,798.112,RORLNCRM) Q:RC<0 RC
;--- Success
D MES^RORKIDS("The LOINC list has been updated successfully.")
Q 0
;
;***** REMOVES THE RECORDS FROM THE MULTIPLE
;
; REGIEN Registry IEN
; SUBFILE Subfile number
; LSTREF Reference to a list or the list itself (see the
; $$COMPNEXT^RORPUT01 function for more details).
;
; Return Values:
; <0 Error code
; 0 Ok
;
REMOVE(REGIEN,SUBFILE,LSTREF) ;
N BUF,DA,DIK,IENS,IR,ITEM,LI,NEXT,RC,RORBUF,RORMSG,TLI
S NEXT=$$COMPNEXT(LSTREF) Q:NEXT<0 NEXT
S IENS=","_(+REGIEN)_",",RC=0
F TLI=1:1 X NEXT Q:$G(BUF)'[";;" D Q:RC<0
. S BUF=$P(BUF,";;",2)
. D MES^RORKIDS(BUF)
. S BUF=$TR(BUF," ")
. F LI=1:1 S ITEM=$P(BUF,",",LI) Q:ITEM="" D Q:RC<0
. . K RORBUF
. . D FIND^DIC(SUBFILE,IENS,"@","QX",ITEM,,"B",,,"RORBUF","RORMSG")
. . I $G(DIERR) S RC=$$DBS^RORERR("RORMSG",-9,,,SUBFILE,IENS) Q
. . S IR="",DIK=$$ROOT^DILFD(SUBFILE,IENS),DA(1)=+REGIEN
. . F S IR=$O(RORBUF("DILIST",2,IR)) Q:IR="" D
. . . S DA=RORBUF("DILIST",2,IR) D ^DIK
Q RC
;
;***** UPDATES (POPULATES) THE LOCAL REGISTRY
;
; [RORREG] Registry IEN and registry name separated by the '^'
; (RegistryIEN^RegistryName).
; [MAXNTSK] Maximum number of registry update subtasks
; [SUSPEND] Suspend update (sub)tasks during the peak hours
; (StartTime^EndTime)
;
; If some of these parameters are omitted or equal to an empty
; strings, their values must be defined as the RORPARM("KIDS")
; sub-nodes of the same name.
;
; Return Values:
; <0 Error code
; 0 Ok
;
UPDATE(RORREG,MAXNTSK,SUSPEND) ;
N EC,REGLST
D BMES^RORKIDS("Updating the local registry...")
;--- Get the parameters
S:'$G(RORREG) RORREG=$$PARAM^RORKIDS("RORREG")
S:RORREG REGLST($P(RORREG,U,2))=+RORREG
S:$G(MAXNTSK)="" MAXNTSK=$$PARAM^RORKIDS("MAXNTSK")
S:$G(SUSPEND)="" SUSPEND=$$PARAM^RORKIDS("SUSPEND")
;--- Update the registry
S RC=$$UPDATE^RORUPD(.REGLST,,MAXNTSK,SUSPEND) Q:RC<0 RC
;--- Success
D MES^RORKIDS("Registry update completed.")
Q 0
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRORPUT01 7434 printed Apr 09, 2024@20:47:17 Page 2
RORPUT01 ;HCIOFO/SG - EDIT LOINC AND DRUG CODE MULTIPLES ; 5/19/06 11:48am
+1 ;;1.5;CLINICAL CASE REGISTRIES;**1**;Feb 17, 2006;Build 24
+2 ;
+3 QUIT
+4 ;
+5 ;***** ADDS THE RECORDS TO THE MULTIPLE
+6 ;
+7 ; REGIEN Registry IEN
+8 ; SUBFILE Subfile number
+9 ; LSTREF Reference to a list or the list itself (see the
+10 ; $$COMPNEXT^RORPUT01 function for more details).
+11 ;
+12 ; Return Values:
+13 ; <0 Error code
+14 ; 0 Ok
+15 ;
ADD(REGIEN,SUBFILE,LSTREF) ;
+1 NEW BUF,IENS,ITEM,LI,NEXT,RC,RORFDA,RORMSG,TLI
+2 SET NEXT=$$COMPNEXT(LSTREF)
if NEXT<0
QUIT NEXT
+3 SET IENS="?+1,"_(+REGIEN)_","
SET RC=0
+4 FOR TLI=1:1
XECUTE NEXT
if $GET(BUF)'[";;"
QUIT
Begin DoDot:1
+5 SET BUF=$PIECE(BUF,";;",2)
+6 DO MES^RORKIDS(BUF)
+7 SET BUF=$TRANSLATE(BUF," ")
+8 FOR LI=1:1
SET ITEM=$PIECE(BUF,",",LI)
if ITEM=""
QUIT
Begin DoDot:2
+9 SET RORFDA(SUBFILE,IENS,.01)=ITEM
+10 DO UPDATE^DIE(,"RORFDA",,"RORMSG")
+11 if $GET(DIERR)
SET RC=$$DBS^RORERR("RORMSG",-9,,,SUBFILE,IENS)
End DoDot:2
if RC<0
QUIT
End DoDot:1
if RC<0
QUIT
+12 QUIT RC
+13 ;
+14 ;***** RESTORES THE CDC DEFINITION
+15 ;
+16 ; Return Values:
+17 ; <0 Error code
+18 ; 0 Ok
+19 ;
CDCDEF() ;
+1 NEW RC,RESULTS,RORBUF
+2 DO BMES^RORKIDS("Restoring the CDC definition...")
+3 ;--- Restore the definition from the transport global
+4 MERGE RORBUF=@XPDGREF@("RORCDCDEF")
+5 SET RORBUF="HIV CDC Form Template"
+6 DO SETPARM^RORRP038(.RESULTS,"ICRCDCDEF","PKG",.RORBUF)
+7 if $GET(RESULTS(0))<0
QUIT +RESULTS(0)
+8 ;--- Success
+9 DO MES^RORKIDS("The definition has been restored successfully.")
+10 QUIT 0
+11 ;
+12 ;***** COMPILES THE 'NEXT' LOGIC
+13 ;
+14 ; PARAM Parameter defining the list of codes. It should be
+15 ; either a list of codes separated by commas or a full
+16 ; reference (TAG^ROUTINE) to a routine label after
+17 ; which the list is located. In the latter case, the
+18 ; list itself should look like this:
+19 ;
+20 ; ;
+21 ; ;***** SHORT DESCRIPTION OF THE LIST
+22 ; LABEL ;
+23 ; ;; Code1, Code2, ...
+24 ; ;; CodeN, ...
+25 ; ;
+26 ;
+27 ; There should be at least one line that does not
+28 ; contain ";;" after the list (or no lines at all).
+29 ;
+30 ; Return Values:
+31 ; <0 Error code
+32 ; "" The list is empty
+33 ; '="" A string that should be XECUTE'd to get the next
+34 ; buffer with the list data
+35 ;
COMPNEXT(PARAM) ;
+1 NEW I,N,NEXT,RC
if PARAM?." "
QUIT ""
+2 ;--- Reference to a routine label
+3 IF PARAM?1.8UN1"^"1.8UN
Begin DoDot:1
+4 SET NEXT="S BUF=$T("_$PIECE(PARAM,U)_"+TLI"_U_$PIECE(PARAM,U,2)_")"
End DoDot:1
QUIT NEXT
+5 ;--- List of codes separated by commas
+6 SET N=$LENGTH(PARAM,",")
SET RC=0
+7 FOR I=1:1:N
IF '($PIECE(PARAM,",",I)?." "1.N." ")
SET RC=-88
QUIT
+8 IF RC<0
IF I=N
if $PIECE(PARAM,",",N)?." "
SET RC=0
SET N=N-1
+9 IF N>0
IF RC'<0
Begin DoDot:1
+10 SET NEXT="S BUF=$P("""_";;"_$PIECE(PARAM,",",1,N)_""",U,TLI)"
End DoDot:1
QUIT NEXT
+11 ;--- Invalid parameter
+12 QUIT $$ERROR^RORERR(-88,,,,"List of Codes",PARAM)
+13 ;
+14 ;***** ADDS ITEMS TO 'EXTRACTED RESULT' MULTIPLE OF FILE #798.1
+15 ;
+16 ; [RORREG] Registry IEN and registry name separated by the '^'
+17 ; (RegistryIEN^RegistryName).
+18 ;
+19 ; [RORLNCAD] Either a list of LOINC codes (without check digits)
+20 ; separated by commas or a full reference (TAG^ROUTINE)
+21 ; to a routine label after which the list is located.
+22 ;
+23 ; All spaces are removed from the lines of the list.
+24 ; See the $$COMPNEXT^RORPUT01 function for more
+25 ; details.
+26 ;
+27 ; If some of these parameters are omitted or equal to an empty
+28 ; strings, their values must be defined as the RORPARM("KIDS")
+29 ; sub-nodes of the same name.
+30 ;
+31 ; Return Values:
+32 ; <0 Error code
+33 ; 0 Ok
+34 ;
LOINCADD(RORREG,RORLNCAD) ;
+1 NEW RC
+2 DO BMES^RORKIDS("Adding new LOINC codes to the EXTRACTED RESULT multiple...")
+3 ;--- Get the parameters
+4 if '$GET(RORREG)
SET RORREG=$$PARAM^RORKIDS("RORREG")
+5 if $GET(RORLNCAD)=""
SET RORLNCAD=$$PARAM^RORKIDS("RORLNCAD")
+6 ;--- Add new LOINC codes
+7 SET RC=$$ADD(+RORREG,798.112,RORLNCAD)
if RC<0
QUIT RC
+8 ;--- Success
+9 DO MES^RORKIDS("The LOINC list has been updated successfully.")
+10 QUIT 0
+11 ;
+12 ;***** REMOVES ITEMS FROM 'EXTRACTED RESULT' MULTIPLE OF FILE #798.1
+13 ;
+14 ; [RORREG] Registry IEN and registry name separated by the '^'
+15 ; (RegistryIEN^RegistryName).
+16 ;
+17 ; [RORLNCRM] Either a list of LOINC codes (without check digits)
+18 ; separated by commas or a full reference (TAG^ROUTINE)
+19 ; to a routine label after which the list is located.
+20 ;
+21 ; All spaces are removed from the lines of the list.
+22 ; See the $$COMPNEXT^RORPUT01 function for more
+23 ; details.
+24 ;
+25 ; If some of these parameters are omitted or equal to an empty
+26 ; strings, their values must be defined as the RORPARM("KIDS")
+27 ; sub-nodes of the same name.
+28 ;
+29 ; Return Values:
+30 ; <0 Error code
+31 ; 0 Ok
+32 ;
LOINCREM(RORREG,RORLNCRM) ;
+1 NEW BUF,DA,DIK,IENS,IR,LCI,LOINC,NEXT,RC,RORBUF,RORMSG,TLI
+2 DO BMES^RORKIDS("Removing obsolete codes from the EXTRACTED RESULT multiple...")
+3 ;--- Get the parameters
+4 if '$GET(RORREG)
SET RORREG=$$PARAM^RORKIDS("RORREG")
+5 if $GET(RORLNCRM)=""
SET RORLNCRM=$$PARAM^RORKIDS("RORLNCRM")
+6 ;--- Delete unnecessary LOINC codes
+7 SET RC=$$REMOVE(+RORREG,798.112,RORLNCRM)
if RC<0
QUIT RC
+8 ;--- Success
+9 DO MES^RORKIDS("The LOINC list has been updated successfully.")
+10 QUIT 0
+11 ;
+12 ;***** REMOVES THE RECORDS FROM THE MULTIPLE
+13 ;
+14 ; REGIEN Registry IEN
+15 ; SUBFILE Subfile number
+16 ; LSTREF Reference to a list or the list itself (see the
+17 ; $$COMPNEXT^RORPUT01 function for more details).
+18 ;
+19 ; Return Values:
+20 ; <0 Error code
+21 ; 0 Ok
+22 ;
REMOVE(REGIEN,SUBFILE,LSTREF) ;
+1 NEW BUF,DA,DIK,IENS,IR,ITEM,LI,NEXT,RC,RORBUF,RORMSG,TLI
+2 SET NEXT=$$COMPNEXT(LSTREF)
if NEXT<0
QUIT NEXT
+3 SET IENS=","_(+REGIEN)_","
SET RC=0
+4 FOR TLI=1:1
XECUTE NEXT
if $GET(BUF)'[";;"
QUIT
Begin DoDot:1
+5 SET BUF=$PIECE(BUF,";;",2)
+6 DO MES^RORKIDS(BUF)
+7 SET BUF=$TRANSLATE(BUF," ")
+8 FOR LI=1:1
SET ITEM=$PIECE(BUF,",",LI)
if ITEM=""
QUIT
Begin DoDot:2
+9 KILL RORBUF
+10 DO FIND^DIC(SUBFILE,IENS,"@","QX",ITEM,,"B",,,"RORBUF","RORMSG")
+11 IF $GET(DIERR)
SET RC=$$DBS^RORERR("RORMSG",-9,,,SUBFILE,IENS)
QUIT
+12 SET IR=""
SET DIK=$$ROOT^DILFD(SUBFILE,IENS)
SET DA(1)=+REGIEN
+13 FOR
SET IR=$ORDER(RORBUF("DILIST",2,IR))
if IR=""
QUIT
Begin DoDot:3
+14 SET DA=RORBUF("DILIST",2,IR)
DO ^DIK
End DoDot:3
End DoDot:2
if RC<0
QUIT
End DoDot:1
if RC<0
QUIT
+15 QUIT RC
+16 ;
+17 ;***** UPDATES (POPULATES) THE LOCAL REGISTRY
+18 ;
+19 ; [RORREG] Registry IEN and registry name separated by the '^'
+20 ; (RegistryIEN^RegistryName).
+21 ; [MAXNTSK] Maximum number of registry update subtasks
+22 ; [SUSPEND] Suspend update (sub)tasks during the peak hours
+23 ; (StartTime^EndTime)
+24 ;
+25 ; If some of these parameters are omitted or equal to an empty
+26 ; strings, their values must be defined as the RORPARM("KIDS")
+27 ; sub-nodes of the same name.
+28 ;
+29 ; Return Values:
+30 ; <0 Error code
+31 ; 0 Ok
+32 ;
UPDATE(RORREG,MAXNTSK,SUSPEND) ;
+1 NEW EC,REGLST
+2 DO BMES^RORKIDS("Updating the local registry...")
+3 ;--- Get the parameters
+4 if '$GET(RORREG)
SET RORREG=$$PARAM^RORKIDS("RORREG")
+5 if RORREG
SET REGLST($PIECE(RORREG,U,2))=+RORREG
+6 if $GET(MAXNTSK)=""
SET MAXNTSK=$$PARAM^RORKIDS("MAXNTSK")
+7 if $GET(SUSPEND)=""
SET SUSPEND=$$PARAM^RORKIDS("SUSPEND")
+8 ;--- Update the registry
+9 SET RC=$$UPDATE^RORUPD(.REGLST,,MAXNTSK,SUSPEND)
if RC<0
QUIT RC
+10 ;--- Success
+11 DO MES^RORKIDS("Registry update completed.")
+12 QUIT 0
