- 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 Mar 13, 2025@20:47:39 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
