RORRP016 ;HCIOFO/SG - RPC: LIST OF ICD-9 CODES ;6/16/06 2:16pm
;;1.5;CLINICAL CASE REGISTRIES;**1,10,23,19,30**;Feb 17, 2006;Build 37
;
; This routine uses the following IAs:
;
; #2051,5388,5773 LIST^DIC (supported)
; #5747 $$CSI^ICDEX (controlled)
; #5747 $$VSTD^ICDEX (controlled)
; #5747 $$VH^ICDEX (controlled)
; #5747 $$UPDX^ICDEX (controlled)
; #5747 $$VSTP^ICDEX (controlled)
; #5699 $$ICDDATA^ICDXCODE (supported)
; #5699 $$ICDDESC^ICDXCODE (supported)
;
;******************************************************************************
;******************************************************************************
; --- ROUTINE MODIFICATION LOG ---
;
;PKG/PATCH DATE DEVELOPER MODIFICATION
;----------- ---------- ----------- ----------------------------------------
;ROR*1.5*19 FEB 2012 K GUPTA Support for ICD-10 Coding System
;
;ROR*1.5*30 OCT 2016 M FERRARESE Changing the dispay for "Sex" to "Birth Sex"
;******************************************************************************
;******************************************************************************
;
Q
;
;***** RETURNS THE LIST OF ICD CODES (DIAGNOSES OR PROCEDURES)
; RPC: [ROR LIST ICD]
;
; .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 description
; F Exclude codes applicable to females only
; I Exclude inactive codes
; K Search in description keywords
; M Exclude codes applicable to males only
; O Return operation/procedure codes from file #80.1
; instead of diagnosis codes from the file #80
; P Exclude codes that are not acceptable
; as primary diagnoses
;
; [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.
;
; [ICDTYPE] TYPE OF ICD SEARCH: ICD9 OR ICD10
;
; The ^TMP("RORRP016",$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 ICD-9 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) ICD
; ^01: IEN
; ^02: Diagnosis or operation/procedure
; ^03: Code
; ^04: Use only with Birth Sex
; ^05: Inactive {0|1}
; ^06: Inactivation Date (FileMan)
;
; @RORESULT@(i+1) ICD Description
;
ICDLIST(RORESULT,DATE,PART,FLAGS,NUMBER,FROM,ICDTYPE) ;
N BUF,RC,RORERRDL,TMP,RORCODSYS
D CLEAR^RORERR("ICDLIST^RORRP016",1)
K RORESULT S RORESULT=$NA(^TMP("RORRP016",$J)) K @RORESULT
;--- Check the parameters
S PART=$G(PART),FLAGS=$G(FLAGS)
S NUMBER=$S($G(NUMBER)>0:+NUMBER,1:"*")
S ICDTYPE=$G(ICDTYPE)
;--- 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)
;--- Compile the list
I FLAGS["O" D
. I ICDTYPE="ICD9" S RORCODSYS="2" I 1
. E I ICDTYPE="ICD10" S RORCODSYS="31"
. ;--- Get the list of operation/procedure codes
. S RC=$$QUERY1(PART,FLAGS,NUMBER,.FROM,RORCODSYS) Q:RC<0
. S RORESULT=$NA(@RORESULT@("DILIST"))
. ;--- Load remaining data and refine the list
. D REFINE1(PART,FLAGS,$G(DATE),RORCODSYS)
E D
. I ICDTYPE="ICD9" S RORCODSYS="1" I 1
. E I ICDTYPE="ICD10" S RORCODSYS="30"
. ;--- Get the list of diagnosis codes
. S RC=$$QUERY(PART,FLAGS,NUMBER,.FROM,RORCODSYS) Q:RC<0
. S RORESULT=$NA(@RORESULT@("DILIST"))
. ;--- Load remaining data and refine the list
. D REFINE(PART,FLAGS,$G(DATE),RORCODSYS)
I RC<0 D RPCSTK^RORERR(.RORESULT,RC) Q
;--- 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 ICD DIAGNOSIS FILE (#80)
QUERY(PART,FLAGS,NR,FROM,CODSYS) ;
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,3)["""_PART_""" ",PART=""
;S:FLAGS["F" SCR=SCR_"I $P(D,U,10)'=""F"" "
;S:FLAGS["M" SCR=SCR_"I $P(D,U,10)'=""M"" "
;S:FLAGS["P" SCR=SCR_"I '$P(D,U,4) "
;S:SCR'="" SCR="S D=$G(^(0)) "_SCR ;Naked Ref: ^ICD9(
S:CODSYS]"" SCR=SCR_"I $$CSI^ICDEX(80,Y)="""_CODSYS_""" "
I FLAGS["D" S:PART'="" SCR=SCR_"I $$UP^XLFSTR($$VSTD^ICDEX(Y))["""_PART_""" ",PART=""
S:FLAGS["F" SCR=SCR_"I $$VSEX^ICDEX(80,Y)'=""F"" "
S:FLAGS["M" SCR=SCR_"I $$VSEX^ICDEX(80,Y)'=""M"" "
S:FLAGS["P" SCR=SCR_"I '$$UPDX^ICDEX(Y) "
;--- Get the list of codes and some data
;S FLDS="@;3;.01;9.5I;IXI",TMP="P"_$S(FLAGS["B":"B",1:"")
;S FLDS="@;.01;9.5I;IXI"
S FLDS="@;.01;IXI"
S TMP="P"_$S(FLAGS["B":"B",1:"")
S XREF=$S(FLAGS["D":"#",FLAGS["K":"D",1:"BA")
D LIST^DIC(80,,FLDS,TMP,NR,.FROM,PART,XREF,SCR,,RORESULT,"RORMSG")
I $G(DIERR) K @RORESULT Q $$DBS^RORERR("RORMSG",-9,,,80)
;--- Add Diagnosis code to RORESULT using API
D GETDIAG(CODSYS)
;--- Success
Q 0
;
;***** QUERIES THE ICD OPERATION/PROCEDURE FILE (#80.1)
QUERY1(PART,FLAGS,NR,FROM,CODSYS) ;
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,4)["""_PART_""" ",PART=""
;S:FLAGS["F" SCR=SCR_"I $P(D,U,10)'=""F"" "
;S:FLAGS["M" SCR=SCR_"I $P(D,U,10)'=""M"" "
;S:SCR'="" SCR="S D=$G(^(0)) "_SCR ;Naked Ref: ^ICD0(
S:CODSYS]"" SCR=SCR_"I $$CSI^ICDEX(80.1,Y)="""_CODSYS_""" "
I FLAGS["D" S:PART'="" SCR=SCR_"I $$UP^XLFSTR($$VSTP^ICDEX(Y))["""_PART_""" ",PART=""
S:FLAGS["F" SCR=SCR_"I $$VSEX^ICDEX(80.1,Y)'=""F"" "
S:FLAGS["M" SCR=SCR_"I $$VSEX^ICDEX(80.1,Y)'=""M"" "
;--- Get the list of codes and some data
;S FLDS="@;4;.01;9.5I;IXI",TMP="P"_$S(FLAGS["B":"B",1:"")
;S FLDS="@;.01;9.5I;IXI"
S FLDS="@;.01;IXI"
S TMP="P"_$S(FLAGS["B":"B",1:"")
S XREF=$S(FLAGS["D":"#",FLAGS["K":"D",1:"BA")
D LIST^DIC(80.1,,FLDS,TMP,NR,.FROM,PART,XREF,SCR,,RORESULT,"RORMSG")
I $G(DIERR) K @RORESULT Q $$DBS^RORERR("RORMSG",-9,,,80.1)
;--- Add Operation/Procedure to RORESULT using API
D GETOPPR(CODSYS)
;--- Success
Q 0
;
;***** REFINES THE LIST OF DIAGNOSES
REFINE(PART,FLAGS,DATE,CODSYS) ;
N BUF,CNT,ICDINFO,MODE,RORDESC,SUBS,TMP
S MODE=($TR(FLAGS,"DK")=FLAGS)
S (CNT,SUBS)=0
F S SUBS=$O(@RORESULT@(SUBS)) Q:SUBS'>0 D
. S BUF=@RORESULT@(SUBS,0)
. ;--- Remove duplicates created by the logic of the "BAA" xref
. I MODE D I '(TMP?1.E1" ") K @RORESULT@(SUBS) Q
. . S TMP=$P(BUF,U,4)
. ;--- Load the additional data
. S ICDINFO=$$ICDDATA^ICDXCODE(CODSYS,+$P(BUF,U),DATE,"I")
. I ICDINFO<0 K @RORESULT@(SUBS) Q
. ;--- Screen active/inactive records
. S TMP=+$P(ICDINFO,U,10) ; Status
. I $S(TMP:FLAGS["A",1:FLAGS["I") K @RORESULT@(SUBS) Q
. S $P(BUF,U,4)=$P(ICDINFO,U,11) ; Birth Sex
. S $P(BUF,U,5)=TMP
. S $P(BUF,U,6)=$S(TMP:$P(ICDINFO,U,12),1:"") ; Inactivation Date
. ;--- Versioned diagnosis
. S TMP=$P(ICDINFO,U,4) S:TMP'="" $P(BUF,U,2)=TMP
. ;--- Store the data
. S CNT=CNT+1,@RORESULT@(SUBS,0)=BUF
. ;--- Versioned description
. S TMP=$$ICDDESC^ICDXCODE(CODSYS,$P(BUF,U,3),DATE,.RORDESC)
. S @RORESULT@(SUBS,1)=$S($G(RORDESC(1))'="":RORDESC(1),1:$P(BUF,U,2))
. K RORDESC
;---
S $P(@RORESULT@(0),U)=CNT
Q
;
;***** REFINES THE LIST OF OPERATION/PROCEDURES
REFINE1(PART,FLAGS,DATE,CODSYS) ;
N BUF,CNT,ICDINFO,MODE,RORDESC,SUBS,TMP
S MODE=($TR(FLAGS,"DK")=FLAGS)
S (CNT,SUBS)=0
F S SUBS=$O(@RORESULT@(SUBS)) Q:SUBS'>0 D
. S BUF=@RORESULT@(SUBS,0)
. ;--- Remove duplicates created by the logic of the "BAA" xref
. I MODE D I '(TMP?1.E1" ") K @RORESULT@(SUBS) Q
. . S TMP=$P(BUF,U,4)
. ;--- Load the additional data
. S ICDINFO=$$ICDDATA^ICDXCODE(CODSYS,+$P(BUF,U),DATE,"I")
. I ICDINFO<0 K @RORESULT@(SUBS) Q
. ;--- Screen active/inactive records
. S TMP=+$P(ICDINFO,U,10) ; Status
. I $S(TMP:FLAGS["A",1:FLAGS["I") K @RORESULT@(SUBS) Q
. S $P(BUF,U,4)=$P(ICDINFO,U,11) ; Birth Sex
. S $P(BUF,U,5)=TMP
. S $P(BUF,U,6)=$S(TMP:$P(ICDINFO,U,12),1:"") ; Inactivation Date
. ;--- Versioned operation/procedure
. S TMP=$P(ICDINFO,U,5) S:TMP'="" $P(BUF,U,2)=TMP
. ;--- Store the data
. S CNT=CNT+1,@RORESULT@(SUBS,0)=BUF
. ;--- Versioned description
. S TMP=$$ICDDESC^ICDXCODE(CODSYS,$P(BUF,U,3),DATE,.RORDESC)
. S @RORESULT@(SUBS,1)=$S($G(RORDESC(1))'="":RORDESC(1),1:$P(BUF,U,2))
. K RORDESC
;---
S $P(@RORESULT@(0),U)=CNT
Q
;
;***** Get Diagnosis code and add to the @RORESULT@("DILIST") array
GETDIAG(CODSYS) ;
N RORI,RORIEN,RORDIAG,ROR1,RORALL,RORNUM S RORI=0
F S RORI=$O(@RORESULT@("DILIST",RORI)) Q:RORI="" D
. S RORIEN=$P(@RORESULT@("DILIST",RORI,0),U,1)
. S RORDIAG=$$VSTD^ICDEX(RORIEN)
. ;get number of pieces in RORESULT
. S RORNUM=$L(@RORESULT@("DILIST",RORI,0),U)
. S ROR1=$P(@RORESULT@("DILIST",RORI,0),U,1) ;1st piece
. S RORALL=$P(@RORESULT@("DILIST",RORI,0),U,2,RORNUM) ;all other pieces
. S @RORESULT@("DILIST",RORI,0)=$G(ROR1)_U_$G(RORDIAG)_U_$G(RORALL)
;Update the 'map' in RORESULT to include field #3
S RORNUM=$L(@RORESULT@("DILIST",0,"MAP"),U) ;number of pieces
S ROR1=$P(@RORESULT@("DILIST",0,"MAP"),U,1) ;first piece
S RORALL=$P(@RORESULT@("DILIST",0,"MAP"),U,2,RORNUM) ;all other pieces
S @RORESULT@("DILIST",0,"MAP")=$G(ROR1)_U_"3"_U_$G(RORALL)
Q
;***** Get Operation/Procedure and add to the RORESULT("DILIST") array
GETOPPR(CODSYS) ;
N RORI,RORIEN,ROROPPR,ROR1,RORALL,RORNUM S RORI=0
F S RORI=$O(@RORESULT@("DILIST",RORI)) Q:RORI="" D
. S RORIEN=$P(@RORESULT@("DILIST",RORI,0),U,1)
. S ROROPPR=$$VSTP^ICDEX(RORIEN)
. ;get number of pieces in RORESULT to reflect field #3
. S RORNUM=$L(@RORESULT@("DILIST",RORI,0),U)
. S ROR1=$P(@RORESULT@("DILIST",RORI,0),U,1) ;1st piece
. S RORALL=$P(@RORESULT@("DILIST",RORI,0),U,2,RORNUM) ;all other pieces
. S @RORESULT@("DILIST",RORI,0)=$G(ROR1)_U_$G(ROROPPR)_U_$G(RORALL)
;Update the 'map' in RORESULT to include field #4
S RORNUM=$L(@RORESULT@("DILIST",0,"MAP"),U) ;number of pieces
S ROR1=$P(@RORESULT@("DILIST",0,"MAP"),U,1) ;first piece
S RORALL=$P(@RORESULT@("DILIST",0,"MAP"),U,2,RORNUM) ;all other pieces
S @RORESULT@("DILIST",0,"MAP")=$G(ROR1)_U_"4"_U_$G(RORALL)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRORRP016 12073 printed Apr 09, 2024@20:49:31 Page 2
RORRP016 ;HCIOFO/SG - RPC: LIST OF ICD-9 CODES ;6/16/06 2:16pm
+1 ;;1.5;CLINICAL CASE REGISTRIES;**1,10,23,19,30**;Feb 17, 2006;Build 37
+2 ;
+3 ; This routine uses the following IAs:
+4 ;
+5 ; #2051,5388,5773 LIST^DIC (supported)
+6 ; #5747 $$CSI^ICDEX (controlled)
+7 ; #5747 $$VSTD^ICDEX (controlled)
+8 ; #5747 $$VH^ICDEX (controlled)
+9 ; #5747 $$UPDX^ICDEX (controlled)
+10 ; #5747 $$VSTP^ICDEX (controlled)
+11 ; #5699 $$ICDDATA^ICDXCODE (supported)
+12 ; #5699 $$ICDDESC^ICDXCODE (supported)
+13 ;
+14 ;******************************************************************************
+15 ;******************************************************************************
+16 ; --- ROUTINE MODIFICATION LOG ---
+17 ;
+18 ;PKG/PATCH DATE DEVELOPER MODIFICATION
+19 ;----------- ---------- ----------- ----------------------------------------
+20 ;ROR*1.5*19 FEB 2012 K GUPTA Support for ICD-10 Coding System
+21 ;
+22 ;ROR*1.5*30 OCT 2016 M FERRARESE Changing the dispay for "Sex" to "Birth Sex"
+23 ;******************************************************************************
+24 ;******************************************************************************
+25 ;
+26 QUIT
+27 ;
+28 ;***** RETURNS THE LIST OF ICD CODES (DIAGNOSES OR PROCEDURES)
+29 ; RPC: [ROR LIST ICD]
+30 ;
+31 ; .RORESULT Reference to a local variable where the results
+32 ; are returned to.
+33 ;
+34 ; [DATE] Date for the code set versioning.
+35 ;
+36 ; [PART] The partial match restriction.
+37 ;
+38 ; [FLAGS] Flags that control the execution (can be combined):
+39 ; A Exclude active codes
+40 ; B Backwards. Traverses the index in the opposite
+41 ; direction of normal traversal
+42 ; D Full search by description
+43 ; F Exclude codes applicable to females only
+44 ; I Exclude inactive codes
+45 ; K Search in description keywords
+46 ; M Exclude codes applicable to males only
+47 ; O Return operation/procedure codes from file #80.1
+48 ; instead of diagnosis codes from the file #80
+49 ; P Exclude codes that are not acceptable
+50 ; as primary diagnoses
+51 ;
+52 ; [NUMBER] Maximum number of entries to return. A value of "*"
+53 ; or no value in this parameter designates all entries.
+54 ;
+55 ; [FROM] The index entry(s) from which to begin the list
+56 ; ^01: FromName
+57 ; ^02: FromIEN
+58 ;
+59 ; For example, a FROM value of "51" would list entries
+60 ; following 51. You can use the 2-nd and 3-rd "^"-
+61 ; pieces of the @RORESULT@(0) node to continue the
+62 ; listing in the subsequent procedure calls.
+63 ;
+64 ; NOTE: The FROM value itself is not included in
+65 ; the resulting list.
+66 ;
+67 ; See description of the LIST^DIC for more details about the
+68 ; PART, NUMBER and FROM parameters.
+69 ;
+70 ; [ICDTYPE] TYPE OF ICD SEARCH: ICD9 OR ICD10
+71 ;
+72 ; The ^TMP("RORRP016",$J) global node is used by this procedure.
+73 ;
+74 ; Return Values:
+75 ;
+76 ; A negative value of the first "^"-piece of the @RORESULT@(0)
+77 ; indicates an error (see the RPCSTK^RORERR procedure for more
+78 ; details).
+79 ;
+80 ; Otherwise, number of ICD-9 codes and the value of the FROM
+81 ; parameter for the next procedure call are returned in the
+82 ; @RORESULT@(0) and the subsequent nodes of the global array
+83 ; contain the codes.
+84 ;
+85 ; @RORESULT@(0) Result Descriptor
+86 ; ^01: Number of codes
+87 ; ^02: FromName
+88 ; ^03: FromIEN
+89 ;
+90 ; @RORESULT@(i) ICD
+91 ; ^01: IEN
+92 ; ^02: Diagnosis or operation/procedure
+93 ; ^03: Code
+94 ; ^04: Use only with Birth Sex
+95 ; ^05: Inactive {0|1}
+96 ; ^06: Inactivation Date (FileMan)
+97 ;
+98 ; @RORESULT@(i+1) ICD Description
+99 ;
ICDLIST(RORESULT,DATE,PART,FLAGS,NUMBER,FROM,ICDTYPE) ;
+1 NEW BUF,RC,RORERRDL,TMP,RORCODSYS
+2 DO CLEAR^RORERR("ICDLIST^RORRP016",1)
+3 KILL RORESULT
SET RORESULT=$NAME(^TMP("RORRP016",$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 SET ICDTYPE=$GET(ICDTYPE)
+8 ;--- Setup the start point
+9 IF $GET(FROM)'=""
Begin DoDot:1
+10 if $PIECE(FROM,U,2)>0
SET FROM("IEN")=+$PIECE(FROM,U,2)
End DoDot:1
SET FROM=$PIECE(FROM,U)
+11 ;--- Compile the list
+12 IF FLAGS["O"
Begin DoDot:1
+13 IF ICDTYPE="ICD9"
SET RORCODSYS="2"
IF 1
+14 IF '$TEST
IF ICDTYPE="ICD10"
SET RORCODSYS="31"
+15 ;--- Get the list of operation/procedure codes
+16 SET RC=$$QUERY1(PART,FLAGS,NUMBER,.FROM,RORCODSYS)
if RC<0
QUIT
+17 SET RORESULT=$NAME(@RORESULT@("DILIST"))
+18 ;--- Load remaining data and refine the list
+19 DO REFINE1(PART,FLAGS,$GET(DATE),RORCODSYS)
End DoDot:1
+20 IF '$TEST
Begin DoDot:1
+21 IF ICDTYPE="ICD9"
SET RORCODSYS="1"
IF 1
+22 IF '$TEST
IF ICDTYPE="ICD10"
SET RORCODSYS="30"
+23 ;--- Get the list of diagnosis codes
+24 SET RC=$$QUERY(PART,FLAGS,NUMBER,.FROM,RORCODSYS)
if RC<0
QUIT
+25 SET RORESULT=$NAME(@RORESULT@("DILIST"))
+26 ;--- Load remaining data and refine the list
+27 DO REFINE(PART,FLAGS,$GET(DATE),RORCODSYS)
End DoDot:1
+28 IF RC<0
DO RPCSTK^RORERR(.RORESULT,RC)
QUIT
+29 ;--- Success
+30 SET TMP=$GET(@RORESULT@(0))
SET BUF=+$PIECE(TMP,U)
+31 if $PIECE(TMP,U,3)
SET $PIECE(BUF,U,2,3)=$GET(FROM)_U_$GET(FROM("IEN"))
+32 KILL @RORESULT@(0)
SET @RORESULT@(0)=BUF
+33 QUIT
+34 ;
+35 ;***** QUERIES THE ICD DIAGNOSIS FILE (#80)
QUERY(PART,FLAGS,NR,FROM,CODSYS) ;
+1 NEW FLDS,RORMSG,SCR,TMP,XREF
+2 ;--- Compile the screen logic (be careful with naked references)
+3 SET SCR=""
+4 ;I FLAGS["D" S:PART'="" SCR=SCR_"I $P(D,U,3)["""_PART_""" ",PART=""
+5 ;S:FLAGS["F" SCR=SCR_"I $P(D,U,10)'=""F"" "
+6 ;S:FLAGS["M" SCR=SCR_"I $P(D,U,10)'=""M"" "
+7 ;S:FLAGS["P" SCR=SCR_"I '$P(D,U,4) "
+8 ;S:SCR'="" SCR="S D=$G(^(0)) "_SCR ;Naked Ref: ^ICD9(
+9 if CODSYS]""
SET SCR=SCR_"I $$CSI^ICDEX(80,Y)="""_CODSYS_""" "
+10 IF FLAGS["D"
if PART'=""
SET SCR=SCR_"I $$UP^XLFSTR($$VSTD^ICDEX(Y))["""_PART_""" "
SET PART=""
+11 if FLAGS["F"
SET SCR=SCR_"I $$VSEX^ICDEX(80,Y)'=""F"" "
+12 if FLAGS["M"
SET SCR=SCR_"I $$VSEX^ICDEX(80,Y)'=""M"" "
+13 if FLAGS["P"
SET SCR=SCR_"I '$$UPDX^ICDEX(Y) "
+14 ;--- Get the list of codes and some data
+15 ;S FLDS="@;3;.01;9.5I;IXI",TMP="P"_$S(FLAGS["B":"B",1:"")
+16 ;S FLDS="@;.01;9.5I;IXI"
+17 SET FLDS="@;.01;IXI"
+18 SET TMP="P"_$SELECT(FLAGS["B":"B",1:"")
+19 SET XREF=$SELECT(FLAGS["D":"#",FLAGS["K":"D",1:"BA")
+20 DO LIST^DIC(80,,FLDS,TMP,NR,.FROM,PART,XREF,SCR,,RORESULT,"RORMSG")
+21 IF $GET(DIERR)
KILL @RORESULT
QUIT $$DBS^RORERR("RORMSG",-9,,,80)
+22 ;--- Add Diagnosis code to RORESULT using API
+23 DO GETDIAG(CODSYS)
+24 ;--- Success
+25 QUIT 0
+26 ;
+27 ;***** QUERIES THE ICD OPERATION/PROCEDURE FILE (#80.1)
QUERY1(PART,FLAGS,NR,FROM,CODSYS) ;
+1 NEW FLDS,RORMSG,SCR,TMP,XREF
+2 ;--- Compile the screen logic (be careful with naked references)
+3 SET SCR=""
+4 ;I FLAGS["D" S:PART'="" SCR=SCR_"I $P(D,U,4)["""_PART_""" ",PART=""
+5 ;S:FLAGS["F" SCR=SCR_"I $P(D,U,10)'=""F"" "
+6 ;S:FLAGS["M" SCR=SCR_"I $P(D,U,10)'=""M"" "
+7 ;S:SCR'="" SCR="S D=$G(^(0)) "_SCR ;Naked Ref: ^ICD0(
+8 if CODSYS]""
SET SCR=SCR_"I $$CSI^ICDEX(80.1,Y)="""_CODSYS_""" "
+9 IF FLAGS["D"
if PART'=""
SET SCR=SCR_"I $$UP^XLFSTR($$VSTP^ICDEX(Y))["""_PART_""" "
SET PART=""
+10 if FLAGS["F"
SET SCR=SCR_"I $$VSEX^ICDEX(80.1,Y)'=""F"" "
+11 if FLAGS["M"
SET SCR=SCR_"I $$VSEX^ICDEX(80.1,Y)'=""M"" "
+12 ;--- Get the list of codes and some data
+13 ;S FLDS="@;4;.01;9.5I;IXI",TMP="P"_$S(FLAGS["B":"B",1:"")
+14 ;S FLDS="@;.01;9.5I;IXI"
+15 SET FLDS="@;.01;IXI"
+16 SET TMP="P"_$SELECT(FLAGS["B":"B",1:"")
+17 SET XREF=$SELECT(FLAGS["D":"#",FLAGS["K":"D",1:"BA")
+18 DO LIST^DIC(80.1,,FLDS,TMP,NR,.FROM,PART,XREF,SCR,,RORESULT,"RORMSG")
+19 IF $GET(DIERR)
KILL @RORESULT
QUIT $$DBS^RORERR("RORMSG",-9,,,80.1)
+20 ;--- Add Operation/Procedure to RORESULT using API
+21 DO GETOPPR(CODSYS)
+22 ;--- Success
+23 QUIT 0
+24 ;
+25 ;***** REFINES THE LIST OF DIAGNOSES
REFINE(PART,FLAGS,DATE,CODSYS) ;
+1 NEW BUF,CNT,ICDINFO,MODE,RORDESC,SUBS,TMP
+2 SET MODE=($TRANSLATE(FLAGS,"DK")=FLAGS)
+3 SET (CNT,SUBS)=0
+4 FOR
SET SUBS=$ORDER(@RORESULT@(SUBS))
if SUBS'>0
QUIT
Begin DoDot:1
+5 SET BUF=@RORESULT@(SUBS,0)
+6 ;--- Remove duplicates created by the logic of the "BAA" xref
+7 IF MODE
Begin DoDot:2
+8 SET TMP=$PIECE(BUF,U,4)
End DoDot:2
IF '(TMP?1.E1" ")
KILL @RORESULT@(SUBS)
QUIT
+9 ;--- Load the additional data
+10 SET ICDINFO=$$ICDDATA^ICDXCODE(CODSYS,+$PIECE(BUF,U),DATE,"I")
+11 IF ICDINFO<0
KILL @RORESULT@(SUBS)
QUIT
+12 ;--- Screen active/inactive records
+13 ; Status
SET TMP=+$PIECE(ICDINFO,U,10)
+14 IF $SELECT(TMP:FLAGS["A",1:FLAGS["I")
KILL @RORESULT@(SUBS)
QUIT
+15 ; Birth Sex
SET $PIECE(BUF,U,4)=$PIECE(ICDINFO,U,11)
+16 SET $PIECE(BUF,U,5)=TMP
+17 ; Inactivation Date
SET $PIECE(BUF,U,6)=$SELECT(TMP:$PIECE(ICDINFO,U,12),1:"")
+18 ;--- Versioned diagnosis
+19 SET TMP=$PIECE(ICDINFO,U,4)
if TMP'=""
SET $PIECE(BUF,U,2)=TMP
+20 ;--- Store the data
+21 SET CNT=CNT+1
SET @RORESULT@(SUBS,0)=BUF
+22 ;--- Versioned description
+23 SET TMP=$$ICDDESC^ICDXCODE(CODSYS,$PIECE(BUF,U,3),DATE,.RORDESC)
+24 SET @RORESULT@(SUBS,1)=$SELECT($GET(RORDESC(1))'="":RORDESC(1),1:$PIECE(BUF,U,2))
+25 KILL RORDESC
End DoDot:1
+26 ;---
+27 SET $PIECE(@RORESULT@(0),U)=CNT
+28 QUIT
+29 ;
+30 ;***** REFINES THE LIST OF OPERATION/PROCEDURES
REFINE1(PART,FLAGS,DATE,CODSYS) ;
+1 NEW BUF,CNT,ICDINFO,MODE,RORDESC,SUBS,TMP
+2 SET MODE=($TRANSLATE(FLAGS,"DK")=FLAGS)
+3 SET (CNT,SUBS)=0
+4 FOR
SET SUBS=$ORDER(@RORESULT@(SUBS))
if SUBS'>0
QUIT
Begin DoDot:1
+5 SET BUF=@RORESULT@(SUBS,0)
+6 ;--- Remove duplicates created by the logic of the "BAA" xref
+7 IF MODE
Begin DoDot:2
+8 SET TMP=$PIECE(BUF,U,4)
End DoDot:2
IF '(TMP?1.E1" ")
KILL @RORESULT@(SUBS)
QUIT
+9 ;--- Load the additional data
+10 SET ICDINFO=$$ICDDATA^ICDXCODE(CODSYS,+$PIECE(BUF,U),DATE,"I")
+11 IF ICDINFO<0
KILL @RORESULT@(SUBS)
QUIT
+12 ;--- Screen active/inactive records
+13 ; Status
SET TMP=+$PIECE(ICDINFO,U,10)
+14 IF $SELECT(TMP:FLAGS["A",1:FLAGS["I")
KILL @RORESULT@(SUBS)
QUIT
+15 ; Birth Sex
SET $PIECE(BUF,U,4)=$PIECE(ICDINFO,U,11)
+16 SET $PIECE(BUF,U,5)=TMP
+17 ; Inactivation Date
SET $PIECE(BUF,U,6)=$SELECT(TMP:$PIECE(ICDINFO,U,12),1:"")
+18 ;--- Versioned operation/procedure
+19 SET TMP=$PIECE(ICDINFO,U,5)
if TMP'=""
SET $PIECE(BUF,U,2)=TMP
+20 ;--- Store the data
+21 SET CNT=CNT+1
SET @RORESULT@(SUBS,0)=BUF
+22 ;--- Versioned description
+23 SET TMP=$$ICDDESC^ICDXCODE(CODSYS,$PIECE(BUF,U,3),DATE,.RORDESC)
+24 SET @RORESULT@(SUBS,1)=$SELECT($GET(RORDESC(1))'="":RORDESC(1),1:$PIECE(BUF,U,2))
+25 KILL RORDESC
End DoDot:1
+26 ;---
+27 SET $PIECE(@RORESULT@(0),U)=CNT
+28 QUIT
+29 ;
+30 ;***** Get Diagnosis code and add to the @RORESULT@("DILIST") array
GETDIAG(CODSYS) ;
+1 NEW RORI,RORIEN,RORDIAG,ROR1,RORALL,RORNUM
SET RORI=0
+2 FOR
SET RORI=$ORDER(@RORESULT@("DILIST",RORI))
if RORI=""
QUIT
Begin DoDot:1
+3 SET RORIEN=$PIECE(@RORESULT@("DILIST",RORI,0),U,1)
+4 SET RORDIAG=$$VSTD^ICDEX(RORIEN)
+5 ;get number of pieces in RORESULT
+6 SET RORNUM=$LENGTH(@RORESULT@("DILIST",RORI,0),U)
+7 ;1st piece
SET ROR1=$PIECE(@RORESULT@("DILIST",RORI,0),U,1)
+8 ;all other pieces
SET RORALL=$PIECE(@RORESULT@("DILIST",RORI,0),U,2,RORNUM)
+9 SET @RORESULT@("DILIST",RORI,0)=$GET(ROR1)_U_$GET(RORDIAG)_U_$GET(RORALL)
End DoDot:1
+10 ;Update the 'map' in RORESULT to include field #3
+11 ;number of pieces
SET RORNUM=$LENGTH(@RORESULT@("DILIST",0,"MAP"),U)
+12 ;first piece
SET ROR1=$PIECE(@RORESULT@("DILIST",0,"MAP"),U,1)
+13 ;all other pieces
SET RORALL=$PIECE(@RORESULT@("DILIST",0,"MAP"),U,2,RORNUM)
+14 SET @RORESULT@("DILIST",0,"MAP")=$GET(ROR1)_U_"3"_U_$GET(RORALL)
+15 QUIT
+16 ;***** Get Operation/Procedure and add to the RORESULT("DILIST") array
GETOPPR(CODSYS) ;
+1 NEW RORI,RORIEN,ROROPPR,ROR1,RORALL,RORNUM
SET RORI=0
+2 FOR
SET RORI=$ORDER(@RORESULT@("DILIST",RORI))
if RORI=""
QUIT
Begin DoDot:1
+3 SET RORIEN=$PIECE(@RORESULT@("DILIST",RORI,0),U,1)
+4 SET ROROPPR=$$VSTP^ICDEX(RORIEN)
+5 ;get number of pieces in RORESULT to reflect field #3
+6 SET RORNUM=$LENGTH(@RORESULT@("DILIST",RORI,0),U)
+7 ;1st piece
SET ROR1=$PIECE(@RORESULT@("DILIST",RORI,0),U,1)
+8 ;all other pieces
SET RORALL=$PIECE(@RORESULT@("DILIST",RORI,0),U,2,RORNUM)
+9 SET @RORESULT@("DILIST",RORI,0)=$GET(ROR1)_U_$GET(ROROPPR)_U_$GET(RORALL)
End DoDot:1
+10 ;Update the 'map' in RORESULT to include field #4
+11 ;number of pieces
SET RORNUM=$LENGTH(@RORESULT@("DILIST",0,"MAP"),U)
+12 ;first piece
SET ROR1=$PIECE(@RORESULT@("DILIST",0,"MAP"),U,1)
+13 ;all other pieces
SET RORALL=$PIECE(@RORESULT@("DILIST",0,"MAP"),U,2,RORNUM)
+14 SET @RORESULT@("DILIST",0,"MAP")=$GET(ROR1)_U_"4"_U_$GET(RORALL)
+15 QUIT
