RORRP019 ;HCIOFO/SG - RPC: LIST OF PATIENTS ; 5/26/06 12:03pm
;;1.5;CLINICAL CASE REGISTRIES;**1**;Feb 17, 2006;Build 24
;
Q
;
;***** RETURNS THE LIST OF PATIENTS (EITHER FROM #798 OR #2)
; RPC: [ROR LIST PATIENTS]
;
; .RESULTS Reference to a local variable where the results
; are returned to.
;
; REGIEN Registry IEN
;
; [DATE] If the value of this parameter is greater than 0
; and the 'C' flag is defined, then patients who
; were confrmed in the registry before this date,
; will be skipped.
;
; [PART] The search pattern (partial match restriction).
; If this parameter is a number preceded by the '`',
; then a list containing only the patient with this
; IEN is compiled.
;
; [FLAGS] Flags that control the execution (can be combined):
; 2 Search in the PATIENT file. By default, the
; ROR REGISTRY RECORD and ROR PATIENT files are
; queried. This flag overrides the 'C' and 'P'
; flags.
; B Backwards. Traverses the index in the opposite
; direction of normal traversal.
; C Include confirmed patients
; O Add values of the optional fields
; P Include pending patients
;
; [NUMBER] Maximum number of entries to return. A value of "*"
; or no value in this parameter designates all entries.
;
; [FROM] The index entry(s) from which to begin the list.
; You should use the pieces of the @RESULTS@(0) node
; (starting from the second one) to continue the
; listing in the subsequent procedure calls.
;
; NOTE: The FROM value itself is not included in
; the resulting list.
;
; The ^TMP("DILIST",$J) global node is used by the procedure.
;
; See description of the LIST^DIC for more details about the
; PART, NUMBER and FROM parameters.
;
; Return Values:
;
; A negative value of the first "^"-piece of the RESULTS(0)
; indicates an error (see the RPCSTK^RORERR procedure for more
; details).
;
; Otherwise, number of patients and the value of the FROM
; parameter for the next procedure call are returned in the
; @RESULTS@(0) and the subsequent nodes of the global array
; contain the patients.
;
; @RESULTS@(0) Result Descriptor
; ^01: Number of patients
; ^02: Values that comprise the FROM
; ^nn: parameter for the subsequent call
;
; @RESULTS@(i) Patient
; ... See the $$LOAD2^RORRP020 (RORDEM)
;
; @RESULTS@(i+1) Optional fields (these nodes are created only
; if the FLAGS parameter contains the 'O' flag)
; ^01: "O" (letter O)
; ... See the $$LOAD798^RORRP020
;
PTLIST(RESULTS,REGIEN,DATE,PART,FLAGS,NUMBER,FROM) ;
N BUF,I,RC,RORERRDL,RORMSG,TMP
D CLEAR^RORERR("PTLIST^RORRP019",1)
K RESULTS S RESULTS=$NA(^TMP("DILIST",$J)) K @RESULTS
;
;=== 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 and date
. S FLAGS=$$UP^XLFSTR($G(FLAGS)),DATE=+$G(DATE)
. S TMP=$TR(FLAGS,"CP")
. ;- The '2' flag overrides all flags related to the CCR files.
. I FLAGS["2" S FLAGS=TMP
. ;- By default, all registry patients are included
. ;- (except those who are marked for deletion).
. E I TMP=FLAGS S FLAGS=FLAGS_"CP"
. ;- If the date is provided, then make sure that confirmed
. ;- registry patients are included in the search (the 'C' flag).
. E S:DATE>0 FLAGS=FLAGS_"C"
. ;--- Others
. S PART=$G(PART),FROM=$G(FROM)
. S NUMBER=$S($G(NUMBER)>0:+NUMBER,1:"*")
;
;=== Setup the starting point
F I=1:1 S TMP=$P(FROM,U,I) Q:TMP="" S FROM(I)=TMP
S FROM=$G(FROM(1))
;
;=== Query the file
S RC=0 D
. ;--- Decode coded SSN of a registry patient
. I PART?1"#"1.11N.1"P" D
. . S PART=$$XOR^RORUTL03($P(PART,"#",2))
. . S TMP=$S(PART["P":10,1:9)
. . S:$L(PART)<TMP PART=$TR($J(PART,TMP)," ","0")
. . S FLAGS=$TR(FLAGS,"2CP")_"CP"
. ;--- Load a single patient with the provided IEN
. I PART?1"`"1.N D Q
. . I FLAGS'["2" Q:$$PRRIEN^RORUTL01($P(PART,"`",2),REGIEN)'>0
. . D FIND^DIC(2,,"@","P",PART,"*","#",,,,"RORMSG")
. . S:$G(DIERR) RC=$$DBS^RORERR("RORMSG",-9,,,2)
. ;--- List of patients from PATIENT file (#2)
. I FLAGS["2" D Q
. . S RC=$$LST2(REGIEN,PART,FLAGS,NUMBER,.FROM)
. ;--- List of registry patients
. S RC=$$LST798(REGIEN,DATE,PART,FLAGS,NUMBER,.FROM)
;
;=== Check for the error(s)
I RC<0 D D RPCSTK^RORERR(.RESULTS,RC) Q
. K ^TMP("DILIST",$J)
;
;=== Post-processing
S RC=$$POSTPROC^RORRP020(RESULTS,REGIEN,FLAGS)
I RC<0 D RPCSTK^RORERR(.RESULTS,RC) Q
;
;=== Success
S TMP=$G(^TMP("DILIST",$J,0)),BUF=+$P(TMP,U)
K ^TMP("DILIST",$J,0)
I $P(TMP,U,3) S I=0 D
. F S I=$O(FROM(I)) Q:I'>0 S TMP=FROM(I) S:TMP'="" BUF=BUF_U_TMP
S @RESULTS@(0)=BUF
Q
;
;***** QUERIES THE 'PATIENT' FILE (#2)
;
; RORREG Registry IEN
;
; PART The partial match restriction
;
; FLAGS Flags that control the execution
;
; NUMBER Maximum number of entries to return
;
; .FROM Reference to a local variable that contains the
; starting point for the LIST^DIC. The new point is
; returned in this variable as well.
;
; Return Values:
; <0 Error code
; 0 Ok
;
LST2(RORREG,PART,FLAGS,NUMBER,FROM) ;
N RC,RORMSG,SCR,TMP,XREF
;--- Select the cross-reference
S XREF=$S(PART?4N:"BS",PART?1U4N:"BS5",PART?9N.1"P":"SSN",1:"B")
;--- Compile the screen logic (be careful with naked references)
S SCR="I '$$SKIPEMPL^RORUTL02(+Y,.RORREG)"
;--- Get the list of patients
S TMP="P"_$S(FLAGS["B":"B",1:"")_$S(XREF="B":"M",1:"")
D LIST^DIC(2,,"@",TMP,NUMBER,.FROM,PART,XREF,SCR,,,"RORMSG")
S:$G(DIERR) RC=$$DBS^RORERR("RORMSG",-9,,,2)
;---
Q $S($G(RC)<0:RC,1:0)
;
;***** QUERIES THE CCR FILES (#798 OR #798.4)
;
; REGIEN Registry IEN
;
; RORDT Ignore patients who were confirmed in the registry
; before the provided date (if the FLAGS parameter
; contains the "C" flag)
;
; PART The partial match restriction
;
; FLAGS Flags that control the execution
;
; NUMBER Maximum number of entries to return
;
; .FROM Reference to a local variable that contains the
; starting point for the LIST^DIC. The new point is
; returned in this variable as well.
;
; Return Values:
; <0 Error code
; 0 Ok
;
LST798(REGIEN,RORDT,PART,FLAGS,NUMBER,FROM) ;
N APART,RC,RORMSG,RORPS,SCR,TMP,XREF
S RC=0
;--- Analyze the parameters
S:FLAGS["C" RORPS(0)="" ; Confirmed
S:FLAGS["P" RORPS(4)="" ; Pending
S XREF=$S(PART?4N:"BS",PART?1U4N:"BS5",PART?9N.1"P":"SSN",1:"")
;--- Select the appropriate CCR file and perform the query
I XREF'="" D
. S SCR="S D=$O(^RORDATA(798,""KEY"",+Y,"_REGIEN_",0)) "
. S SCR=SCR_"I D>0 S D=$G(^RORDATA(798,D,0)) "
. S SCR=SCR_"I $D(RORPS(+$P(D,U,5))) "
. ;--- If the confirmation threshold is provided, add the
. ; screen code and check if there is at least one record
. ;--- that conforms the confirmation date criterion
. I RORDT>0 D Q:'$D(SCR)
. . I FLAGS["B" D Q
. . . S SCR=SCR_"I $P(D,U,4)'>RORDT "
. . . K:$O(^RORDATA(798,"ARCP",REGIEN_"#",""))>RORDT SCR
. . ;---
. . S SCR=SCR_"I $P(D,U,4)'<RORDT "
. . K:$O(^RORDATA(798,"ARCP",REGIEN_"#",""),-1)<RORDT SCR
. ;--- Query the ROR PATIENT file
. S TMP="P"_$S(FLAGS["B":"B",1:"")
. D LIST^DIC(798.4,,"@",TMP,NUMBER,.FROM,PART,XREF,SCR,,,"RORMSG")
. S:$G(DIERR) RC=$$DBS^RORERR("RORMSG",-9,,,798.4)
E D
. S APART(1)=REGIEN_"#"
. S FROM(1)=$S(FLAGS["B":"~",1:" ")
. S SCR="S D=+$P($G(^(0)),U,5) I $D(RORPS(D)) "
. ;---
. I RORDT>0 S XREF="ARCP",APART(3)=PART D:$G(FROM(2))=""
. . S FROM(2)=$$FMADD^XLFDT(RORDT,,,,$S(FLAGS["B":1,1:-1))
. E S XREF="ARP",APART(2)=PART
. ;--- Query the ROR REGISTRY RECORD file
. S TMP="P"_$S(FLAGS["B":"B",1:"")
. D LIST^DIC(798,,"@;.01I",TMP,NUMBER,.FROM,.APART,XREF,SCR,,,"RORMSG")
. S:$G(DIERR) RC=$$DBS^RORERR("RORMSG",-9,,,798)
;---
Q $S($G(RC)<0:RC,1:0)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRORRP019 8737 printed Sep 02, 2024@18:28:23 Page 2
RORRP019 ;HCIOFO/SG - RPC: LIST OF PATIENTS ; 5/26/06 12:03pm
+1 ;;1.5;CLINICAL CASE REGISTRIES;**1**;Feb 17, 2006;Build 24
+2 ;
+3 QUIT
+4 ;
+5 ;***** RETURNS THE LIST OF PATIENTS (EITHER FROM #798 OR #2)
+6 ; RPC: [ROR LIST PATIENTS]
+7 ;
+8 ; .RESULTS Reference to a local variable where the results
+9 ; are returned to.
+10 ;
+11 ; REGIEN Registry IEN
+12 ;
+13 ; [DATE] If the value of this parameter is greater than 0
+14 ; and the 'C' flag is defined, then patients who
+15 ; were confrmed in the registry before this date,
+16 ; will be skipped.
+17 ;
+18 ; [PART] The search pattern (partial match restriction).
+19 ; If this parameter is a number preceded by the '`',
+20 ; then a list containing only the patient with this
+21 ; IEN is compiled.
+22 ;
+23 ; [FLAGS] Flags that control the execution (can be combined):
+24 ; 2 Search in the PATIENT file. By default, the
+25 ; ROR REGISTRY RECORD and ROR PATIENT files are
+26 ; queried. This flag overrides the 'C' and 'P'
+27 ; flags.
+28 ; B Backwards. Traverses the index in the opposite
+29 ; direction of normal traversal.
+30 ; C Include confirmed patients
+31 ; O Add values of the optional fields
+32 ; P Include pending patients
+33 ;
+34 ; [NUMBER] Maximum number of entries to return. A value of "*"
+35 ; or no value in this parameter designates all entries.
+36 ;
+37 ; [FROM] The index entry(s) from which to begin the list.
+38 ; You should use the pieces of the @RESULTS@(0) node
+39 ; (starting from the second one) to continue the
+40 ; listing in the subsequent procedure calls.
+41 ;
+42 ; NOTE: The FROM value itself is not included in
+43 ; the resulting list.
+44 ;
+45 ; The ^TMP("DILIST",$J) global node is used by the procedure.
+46 ;
+47 ; See description of the LIST^DIC for more details about the
+48 ; PART, NUMBER and FROM parameters.
+49 ;
+50 ; Return Values:
+51 ;
+52 ; A negative value of the first "^"-piece of the RESULTS(0)
+53 ; indicates an error (see the RPCSTK^RORERR procedure for more
+54 ; details).
+55 ;
+56 ; Otherwise, number of patients and the value of the FROM
+57 ; parameter for the next procedure call are returned in the
+58 ; @RESULTS@(0) and the subsequent nodes of the global array
+59 ; contain the patients.
+60 ;
+61 ; @RESULTS@(0) Result Descriptor
+62 ; ^01: Number of patients
+63 ; ^02: Values that comprise the FROM
+64 ; ^nn: parameter for the subsequent call
+65 ;
+66 ; @RESULTS@(i) Patient
+67 ; ... See the $$LOAD2^RORRP020 (RORDEM)
+68 ;
+69 ; @RESULTS@(i+1) Optional fields (these nodes are created only
+70 ; if the FLAGS parameter contains the 'O' flag)
+71 ; ^01: "O" (letter O)
+72 ; ... See the $$LOAD798^RORRP020
+73 ;
PTLIST(RESULTS,REGIEN,DATE,PART,FLAGS,NUMBER,FROM) ;
+1 NEW BUF,I,RC,RORERRDL,RORMSG,TMP
+2 DO CLEAR^RORERR("PTLIST^RORRP019",1)
+3 KILL RESULTS
SET RESULTS=$NAME(^TMP("DILIST",$JOB))
KILL @RESULTS
+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 and date
+12 SET FLAGS=$$UP^XLFSTR($GET(FLAGS))
SET DATE=+$GET(DATE)
+13 SET TMP=$TRANSLATE(FLAGS,"CP")
+14 ;- The '2' flag overrides all flags related to the CCR files.
+15 IF FLAGS["2"
SET FLAGS=TMP
+16 ;- By default, all registry patients are included
+17 ;- (except those who are marked for deletion).
+18 IF '$TEST
IF TMP=FLAGS
SET FLAGS=FLAGS_"CP"
+19 ;- If the date is provided, then make sure that confirmed
+20 ;- registry patients are included in the search (the 'C' flag).
+21 IF '$TEST
if DATE>0
SET FLAGS=FLAGS_"C"
+22 ;--- Others
+23 SET PART=$GET(PART)
SET FROM=$GET(FROM)
+24 SET NUMBER=$SELECT($GET(NUMBER)>0:+NUMBER,1:"*")
End DoDot:1
IF RC<0
DO RPCSTK^RORERR(.RESULTS,RC)
QUIT
+25 ;
+26 ;=== Setup the starting point
+27 FOR I=1:1
SET TMP=$PIECE(FROM,U,I)
if TMP=""
QUIT
SET FROM(I)=TMP
+28 SET FROM=$GET(FROM(1))
+29 ;
+30 ;=== Query the file
+31 SET RC=0
Begin DoDot:1
+32 ;--- Decode coded SSN of a registry patient
+33 IF PART?1"#"1.11N.1"P"
Begin DoDot:2
+34 SET PART=$$XOR^RORUTL03($PIECE(PART,"#",2))
+35 SET TMP=$SELECT(PART["P":10,1:9)
+36 if $LENGTH(PART)<TMP
SET PART=$TRANSLATE($JUSTIFY(PART,TMP)," ","0")
+37 SET FLAGS=$TRANSLATE(FLAGS,"2CP")_"CP"
End DoDot:2
+38 ;--- Load a single patient with the provided IEN
+39 IF PART?1"`"1.N
Begin DoDot:2
+40 IF FLAGS'["2"
if $$PRRIEN^RORUTL01($PIECE(PART,"`",2),REGIEN)'>0
QUIT
+41 DO FIND^DIC(2,,"@","P",PART,"*","#",,,,"RORMSG")
+42 if $GET(DIERR)
SET RC=$$DBS^RORERR("RORMSG",-9,,,2)
End DoDot:2
QUIT
+43 ;--- List of patients from PATIENT file (#2)
+44 IF FLAGS["2"
Begin DoDot:2
+45 SET RC=$$LST2(REGIEN,PART,FLAGS,NUMBER,.FROM)
End DoDot:2
QUIT
+46 ;--- List of registry patients
+47 SET RC=$$LST798(REGIEN,DATE,PART,FLAGS,NUMBER,.FROM)
End DoDot:1
+48 ;
+49 ;=== Check for the error(s)
+50 IF RC<0
Begin DoDot:1
+51 KILL ^TMP("DILIST",$JOB)
End DoDot:1
DO RPCSTK^RORERR(.RESULTS,RC)
QUIT
+52 ;
+53 ;=== Post-processing
+54 SET RC=$$POSTPROC^RORRP020(RESULTS,REGIEN,FLAGS)
+55 IF RC<0
DO RPCSTK^RORERR(.RESULTS,RC)
QUIT
+56 ;
+57 ;=== Success
+58 SET TMP=$GET(^TMP("DILIST",$JOB,0))
SET BUF=+$PIECE(TMP,U)
+59 KILL ^TMP("DILIST",$JOB,0)
+60 IF $PIECE(TMP,U,3)
SET I=0
Begin DoDot:1
+61 FOR
SET I=$ORDER(FROM(I))
if I'>0
QUIT
SET TMP=FROM(I)
if TMP'=""
SET BUF=BUF_U_TMP
End DoDot:1
+62 SET @RESULTS@(0)=BUF
+63 QUIT
+64 ;
+65 ;***** QUERIES THE 'PATIENT' FILE (#2)
+66 ;
+67 ; RORREG Registry IEN
+68 ;
+69 ; PART The partial match restriction
+70 ;
+71 ; FLAGS Flags that control the execution
+72 ;
+73 ; NUMBER Maximum number of entries to return
+74 ;
+75 ; .FROM Reference to a local variable that contains the
+76 ; starting point for the LIST^DIC. The new point is
+77 ; returned in this variable as well.
+78 ;
+79 ; Return Values:
+80 ; <0 Error code
+81 ; 0 Ok
+82 ;
LST2(RORREG,PART,FLAGS,NUMBER,FROM) ;
+1 NEW RC,RORMSG,SCR,TMP,XREF
+2 ;--- Select the cross-reference
+3 SET XREF=$SELECT(PART?4N:"BS",PART?1U4N:"BS5",PART?9N.1"P":"SSN",1:"B")
+4 ;--- Compile the screen logic (be careful with naked references)
+5 SET SCR="I '$$SKIPEMPL^RORUTL02(+Y,.RORREG)"
+6 ;--- Get the list of patients
+7 SET TMP="P"_$SELECT(FLAGS["B":"B",1:"")_$SELECT(XREF="B":"M",1:"")
+8 DO LIST^DIC(2,,"@",TMP,NUMBER,.FROM,PART,XREF,SCR,,,"RORMSG")
+9 if $GET(DIERR)
SET RC=$$DBS^RORERR("RORMSG",-9,,,2)
+10 ;---
+11 QUIT $SELECT($GET(RC)<0:RC,1:0)
+12 ;
+13 ;***** QUERIES THE CCR FILES (#798 OR #798.4)
+14 ;
+15 ; REGIEN Registry IEN
+16 ;
+17 ; RORDT Ignore patients who were confirmed in the registry
+18 ; before the provided date (if the FLAGS parameter
+19 ; contains the "C" flag)
+20 ;
+21 ; PART The partial match restriction
+22 ;
+23 ; FLAGS Flags that control the execution
+24 ;
+25 ; NUMBER Maximum number of entries to return
+26 ;
+27 ; .FROM Reference to a local variable that contains the
+28 ; starting point for the LIST^DIC. The new point is
+29 ; returned in this variable as well.
+30 ;
+31 ; Return Values:
+32 ; <0 Error code
+33 ; 0 Ok
+34 ;
LST798(REGIEN,RORDT,PART,FLAGS,NUMBER,FROM) ;
+1 NEW APART,RC,RORMSG,RORPS,SCR,TMP,XREF
+2 SET RC=0
+3 ;--- Analyze the parameters
+4 ; Confirmed
if FLAGS["C"
SET RORPS(0)=""
+5 ; Pending
if FLAGS["P"
SET RORPS(4)=""
+6 SET XREF=$SELECT(PART?4N:"BS",PART?1U4N:"BS5",PART?9N.1"P":"SSN",1:"")
+7 ;--- Select the appropriate CCR file and perform the query
+8 IF XREF'=""
Begin DoDot:1
+9 SET SCR="S D=$O(^RORDATA(798,""KEY"",+Y,"_REGIEN_",0)) "
+10 SET SCR=SCR_"I D>0 S D=$G(^RORDATA(798,D,0)) "
+11 SET SCR=SCR_"I $D(RORPS(+$P(D,U,5))) "
+12 ;--- If the confirmation threshold is provided, add the
+13 ; screen code and check if there is at least one record
+14 ;--- that conforms the confirmation date criterion
+15 IF RORDT>0
Begin DoDot:2
+16 IF FLAGS["B"
Begin DoDot:3
+17 SET SCR=SCR_"I $P(D,U,4)'>RORDT "
+18 if $ORDER(^RORDATA(798,"ARCP",REGIEN_"#",""))>RORDT
KILL SCR
End DoDot:3
QUIT
+19 ;---
+20 SET SCR=SCR_"I $P(D,U,4)'<RORDT "
+21 if $ORDER(^RORDATA(798,"ARCP",REGIEN_"#",""),-1)<RORDT
KILL SCR
End DoDot:2
if '$DATA(SCR)
QUIT
+22 ;--- Query the ROR PATIENT file
+23 SET TMP="P"_$SELECT(FLAGS["B":"B",1:"")
+24 DO LIST^DIC(798.4,,"@",TMP,NUMBER,.FROM,PART,XREF,SCR,,,"RORMSG")
+25 if $GET(DIERR)
SET RC=$$DBS^RORERR("RORMSG",-9,,,798.4)
End DoDot:1
+26 IF '$TEST
Begin DoDot:1
+27 SET APART(1)=REGIEN_"#"
+28 SET FROM(1)=$SELECT(FLAGS["B":"~",1:" ")
+29 SET SCR="S D=+$P($G(^(0)),U,5) I $D(RORPS(D)) "
+30 ;---
+31 IF RORDT>0
SET XREF="ARCP"
SET APART(3)=PART
if $GET(FROM(2))=""
Begin DoDot:2
+32 SET FROM(2)=$$FMADD^XLFDT(RORDT,,,,$SELECT(FLAGS["B":1,1:-1))
End DoDot:2
+33 IF '$TEST
SET XREF="ARP"
SET APART(2)=PART
+34 ;--- Query the ROR REGISTRY RECORD file
+35 SET TMP="P"_$SELECT(FLAGS["B":"B",1:"")
+36 DO LIST^DIC(798,,"@;.01I",TMP,NUMBER,.FROM,.APART,XREF,SCR,,,"RORMSG")
+37 if $GET(DIERR)
SET RC=$$DBS^RORERR("RORMSG",-9,,,798)
End DoDot:1
+38 ;---
+39 QUIT $SELECT($GET(RC)<0:RC,1:0)
