RORRP042 ;HCIOFO/SG - RPC: CPT CODES ; 11/10/05 9:21am
;;1.5;CLINICAL CASE REGISTRIES;;Feb 17, 2006
;
; This routine uses the following IAs:
;
; #1995 $$CPT^ICPTCOD (supported)
; #2815 Access to the file #81 (supported)
;
Q
;
;***** RETURNS THE LIST OF CPT CODES
; RPC: [ROR LIST CPT]
;
; .RORESULT Reference to a local variable where the results
; are returned to.
;
; [DATE] Date for the code set versioning.
;
; [PART] The partial match restriction.
;
; [FLAGS] Flags that control the execution (can be combined):
; A Exclude active codes
; B Backwards. Traverses the index in the opposite
; direction of normal traversal
; D Full search by short name
; I Exclude inactive codes
; K Search in description keywords
;
; [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
; ^01: FromName
; ^02: FromIEN
;
; For example, a FROM value of "51" would list entries
; following 51. You can use the 2-nd and 3-rd "^"-
; pieces of the @RORESULT@(0) node to continue the
; listing in the subsequent procedure calls.
;
; NOTE: The FROM value itself is not included in
; the resulting list.
;
; See description of the LIST^DIC for more details about the
; PART, NUMBER and FROM parameters.
;
; The ^TMP("RORRP042",$J) global node is used by this procedure.
;
; Return Values:
;
; A negative value of the first "^"-piece of the @RORESULT@(0)
; indicates an error (see the RPCSTK^RORERR procedure for more
; details).
;
; Otherwise, number of CPT codes and the value of the FROM
; parameter for the next procedure call are returned in the
; @RORESULT@(0) and the subsequent nodes of the global array
; contain the codes.
;
; @RORESULT@(0) Result Descriptor
; ^01: Number of codes
; ^02: FromName
; ^03: FromIEN
;
; @RORESULT@(i) CPT
; ^01: IEN
; ^02: Short Name
; ^03: Code
; ^04: reserved
; ^05: Inactive {0|1}
; ^06: Inactivation Date (FileMan)
;
CPTLIST(RORESULT,DATE,PART,FLAGS,NUMBER,FROM) ;
N BUF,RC,RORERRDL,TMP
D CLEAR^RORERR("CPTLIST^RORRP042",1)
K RORESULT S RORESULT=$NA(^TMP("RORRP042",$J)) K @RORESULT
;--- Check the parameters
S PART=$G(PART),FLAGS=$G(FLAGS)
S NUMBER=$S($G(NUMBER)>0:+NUMBER,1:"*")
;--- Setup the start point
I $G(FROM)'="" D S FROM=$P(FROM,U)
. S:$P(FROM,U,2)>0 FROM("IEN")=+$P(FROM,U,2)
;--- Get the list of CPT codes
S RC=$$QUERY(PART,FLAGS,NUMBER,.FROM)
I RC<0 D RPCSTK^RORERR(.RORESULT,RC) Q
S RORESULT=$NA(@RORESULT@("DILIST"))
;--- Load remaining data and refine the list
D REFINE($G(DATE),FLAGS)
;--- Success
S TMP=$G(@RORESULT@(0)),BUF=+$P(TMP,U)
S:$P(TMP,U,3) $P(BUF,U,2,3)=$G(FROM)_U_$G(FROM("IEN"))
K @RORESULT@(0) S @RORESULT@(0)=BUF
Q
;
;***** QUERIES THE CPT FILE (#81)
QUERY(PART,FLAGS,NR,FROM) ;
N FLDS,RORMSG,SCR,TMP,XREF
;--- Compile the screen logic (be careful with naked references)
S SCR=""
I FLAGS["D" S:PART'="" SCR=SCR_"I $P(D,U,2)["""_PART_""" ",PART=""
S:SCR'="" SCR="S D=$G(^(0)) "_SCR
;--- Get the list of codes and some data
S FLDS="@;.01;.01",TMP="P"_$S(FLAGS["B":"B",1:"")
S XREF=$S(FLAGS["D":"#",FLAGS["K":"C",1:"B")
D LIST^DIC(81,,FLDS,TMP,NR,.FROM,PART,XREF,SCR,,RORESULT,"RORMSG")
I $G(DIERR) K @RORESULT Q $$DBS^RORERR("RORMSG",-9,,,80)
;--- Success
Q 0
;
;***** REFINES THE LIST OF CPT CODES
REFINE(DATE,FLAGS) ;
N BUF,CNT,CPTINFO,RORDESC,SUBS,TMP
S (CNT,SUBS)=0
F S SUBS=$O(@RORESULT@(SUBS)) Q:SUBS'>0 D
. S BUF=@RORESULT@(SUBS,0)
. S CPTINFO=$$CPT^ICPTCOD(+$P(BUF,U),DATE)
. I CPTINFO<0 K @RORESULT@(SUBS) Q
. ;--- Screen active/inactive records
. S TMP=+$P(CPTINFO,U,7) ; Status
. I $S(TMP:FLAGS["A",1:FLAGS["I") K @RORESULT@(SUBS) Q
. S $P(BUF,U,5)=TMP
. S $P(BUF,U,6)=$S(TMP:$P(CPTINFO,U,8),1:"") ; Inactivation Date
. ;--- Versioned short name
. S TMP=$P(CPTINFO,U,3) S:TMP'="" $P(BUF,U,2)=TMP
. ;--- Store the data
. S CNT=CNT+1,@RORESULT@(SUBS,0)=BUF
;---
S $P(@RORESULT@(0),U)=CNT
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRORRP042 4708 printed Nov 22, 2024@16:53:34 Page 2
RORRP042 ;HCIOFO/SG - RPC: CPT CODES ; 11/10/05 9:21am
+1 ;;1.5;CLINICAL CASE REGISTRIES;;Feb 17, 2006
+2 ;
+3 ; This routine uses the following IAs:
+4 ;
+5 ; #1995 $$CPT^ICPTCOD (supported)
+6 ; #2815 Access to the file #81 (supported)
+7 ;
+8 QUIT
+9 ;
+10 ;***** RETURNS THE LIST OF CPT CODES
+11 ; RPC: [ROR LIST CPT]
+12 ;
+13 ; .RORESULT Reference to a local variable where the results
+14 ; are returned to.
+15 ;
+16 ; [DATE] Date for the code set versioning.
+17 ;
+18 ; [PART] The partial match restriction.
+19 ;
+20 ; [FLAGS] Flags that control the execution (can be combined):
+21 ; A Exclude active codes
+22 ; B Backwards. Traverses the index in the opposite
+23 ; direction of normal traversal
+24 ; D Full search by short name
+25 ; I Exclude inactive codes
+26 ; K Search in description keywords
+27 ;
+28 ; [NUMBER] Maximum number of entries to return. A value of "*"
+29 ; or no value in this parameter designates all entries.
+30 ;
+31 ; [FROM] The index entry(s) from which to begin the list
+32 ; ^01: FromName
+33 ; ^02: FromIEN
+34 ;
+35 ; For example, a FROM value of "51" would list entries
+36 ; following 51. You can use the 2-nd and 3-rd "^"-
+37 ; pieces of the @RORESULT@(0) node to continue the
+38 ; listing in the subsequent procedure calls.
+39 ;
+40 ; NOTE: The FROM value itself is not included in
+41 ; the resulting list.
+42 ;
+43 ; See description of the LIST^DIC for more details about the
+44 ; PART, NUMBER and FROM parameters.
+45 ;
+46 ; The ^TMP("RORRP042",$J) global node is used by this procedure.
+47 ;
+48 ; Return Values:
+49 ;
+50 ; A negative value of the first "^"-piece of the @RORESULT@(0)
+51 ; indicates an error (see the RPCSTK^RORERR procedure for more
+52 ; details).
+53 ;
+54 ; Otherwise, number of CPT codes and the value of the FROM
+55 ; parameter for the next procedure call are returned in the
+56 ; @RORESULT@(0) and the subsequent nodes of the global array
+57 ; contain the codes.
+58 ;
+59 ; @RORESULT@(0) Result Descriptor
+60 ; ^01: Number of codes
+61 ; ^02: FromName
+62 ; ^03: FromIEN
+63 ;
+64 ; @RORESULT@(i) CPT
+65 ; ^01: IEN
+66 ; ^02: Short Name
+67 ; ^03: Code
+68 ; ^04: reserved
+69 ; ^05: Inactive {0|1}
+70 ; ^06: Inactivation Date (FileMan)
+71 ;
CPTLIST(RORESULT,DATE,PART,FLAGS,NUMBER,FROM) ;
+1 NEW BUF,RC,RORERRDL,TMP
+2 DO CLEAR^RORERR("CPTLIST^RORRP042",1)
+3 KILL RORESULT
SET RORESULT=$NAME(^TMP("RORRP042",$JOB))
KILL @RORESULT
+4 ;--- Check the parameters
+5 SET PART=$GET(PART)
SET FLAGS=$GET(FLAGS)
+6 SET NUMBER=$SELECT($GET(NUMBER)>0:+NUMBER,1:"*")
+7 ;--- Setup the start point
+8 IF $GET(FROM)'=""
Begin DoDot:1
+9 if $PIECE(FROM,U,2)>0
SET FROM("IEN")=+$PIECE(FROM,U,2)
End DoDot:1
SET FROM=$PIECE(FROM,U)
+10 ;--- Get the list of CPT codes
+11 SET RC=$$QUERY(PART,FLAGS,NUMBER,.FROM)
+12 IF RC<0
DO RPCSTK^RORERR(.RORESULT,RC)
QUIT
+13 SET RORESULT=$NAME(@RORESULT@("DILIST"))
+14 ;--- Load remaining data and refine the list
+15 DO REFINE($GET(DATE),FLAGS)
+16 ;--- Success
+17 SET TMP=$GET(@RORESULT@(0))
SET BUF=+$PIECE(TMP,U)
+18 if $PIECE(TMP,U,3)
SET $PIECE(BUF,U,2,3)=$GET(FROM)_U_$GET(FROM("IEN"))
+19 KILL @RORESULT@(0)
SET @RORESULT@(0)=BUF
+20 QUIT
+21 ;
+22 ;***** QUERIES THE CPT FILE (#81)
QUERY(PART,FLAGS,NR,FROM) ;
+1 NEW FLDS,RORMSG,SCR,TMP,XREF
+2 ;--- Compile the screen logic (be careful with naked references)
+3 SET SCR=""
+4 IF FLAGS["D"
if PART'=""
SET SCR=SCR_"I $P(D,U,2)["""_PART_""" "
SET PART=""
+5 if SCR'=""
SET SCR="S D=$G(^(0)) "_SCR
+6 ;--- Get the list of codes and some data
+7 SET FLDS="@;.01;.01"
SET TMP="P"_$SELECT(FLAGS["B":"B",1:"")
+8 SET XREF=$SELECT(FLAGS["D":"#",FLAGS["K":"C",1:"B")
+9 DO LIST^DIC(81,,FLDS,TMP,NR,.FROM,PART,XREF,SCR,,RORESULT,"RORMSG")
+10 IF $GET(DIERR)
KILL @RORESULT
QUIT $$DBS^RORERR("RORMSG",-9,,,80)
+11 ;--- Success
+12 QUIT 0
+13 ;
+14 ;***** REFINES THE LIST OF CPT CODES
REFINE(DATE,FLAGS) ;
+1 NEW BUF,CNT,CPTINFO,RORDESC,SUBS,TMP
+2 SET (CNT,SUBS)=0
+3 FOR
SET SUBS=$ORDER(@RORESULT@(SUBS))
if SUBS'>0
QUIT
Begin DoDot:1
+4 SET BUF=@RORESULT@(SUBS,0)
+5 SET CPTINFO=$$CPT^ICPTCOD(+$PIECE(BUF,U),DATE)
+6 IF CPTINFO<0
KILL @RORESULT@(SUBS)
QUIT
+7 ;--- Screen active/inactive records
+8 ; Status
SET TMP=+$PIECE(CPTINFO,U,7)
+9 IF $SELECT(TMP:FLAGS["A",1:FLAGS["I")
KILL @RORESULT@(SUBS)
QUIT
+10 SET $PIECE(BUF,U,5)=TMP
+11 ; Inactivation Date
SET $PIECE(BUF,U,6)=$SELECT(TMP:$PIECE(CPTINFO,U,8),1:"")
+12 ;--- Versioned short name
+13 SET TMP=$PIECE(CPTINFO,U,3)
if TMP'=""
SET $PIECE(BUF,U,2)=TMP
+14 ;--- Store the data
+15 SET CNT=CNT+1
SET @RORESULT@(SUBS,0)=BUF
End DoDot:1
+16 ;---
+17 SET $PIECE(@RORESULT@(0),U)=CNT
+18 QUIT
