ICDEXD5 ;SLC/KER - ICD Extractor - DRG APIs (cont) ;04/21/2014
;;18.0;DRG Grouper;**57**;Oct 20, 2000;Build 7
;
; Global Variables
; ^DG(45.86) ICR 5821
; ^DGPT( ICR 5822
; ^ICD("ADS") N/A
; ^ICD("B") N/A
; ^TMP("DRGD") SACC 2.3.2.5.1
;
; External References
; $$DT^XLFDT ICR 10103
; $$NOW^XLFDT ICR 10103
;
Q
DRG(CODE,CDT) ; Returns a string of information from the DRG file (#80.2)
;
; Input:
;
; CODE DRG code, internal or external format (Required)
; CDT Date, FileMan format (default = TODAY)
; If CDT < 10/1/1978, use 10/1/1978
; If CDT > DT, validate with In/Activation Dates
; If CDT is year only, use first of the year
; If CDT is year and month, use first of the month
;
; Output:
;
; Returns an 22 piece string delimited by the
; up-arrow (^) the pieces are:
;
; 1 DRG name (field #.01)
; 2 Weight (field #2)
; 3 Low Trim (days) (field #3)
; 4 High Trim (days) (field #4)
; 5 MDC (field #5)
; 6 Surgery Flag (field #.06)
; 7 <null>
; 8 Avg Length of Stay (days) (field 10)
; 9 Local Low Trim Days (field #11)
; 10 Local High Trim Days (field #12)
; 11 <null>
; 12 Local Breakeven (field #13)
; 13 Activation Date (.01 of the 66 multiple)
; 14 Status (.03 of the 66 multiple)
; 15 Inactivation Date (.01 of the 66 multiple)
; 16 Effective date (.01 of the 66 multiple)
; 17 Internal Entry Number (IEN)
; 18 Effective date (.01 of the 66 multiple)
; 19 Reference (field #900)
; 20 Weight (Non Affil) (field #7)
; 21 Weight (Int Affil) (field #7.5)
; 22 Message
;
; or
;
; -1^Error Description
;
N D0,DCS,DFY,DFYINF,DCSINF,DMC1,D1,FYDT,FYMD,ICDFY,ICDIMP,STR
S CDT=$P(CDT,".",1) S:CDT'?7N CDT=DT S CDT=$$DTBR^ICDEX(CDT,2)
I $G(CODE)="" S STR="-1^NO CODE SELECTED",$P(STR,"^",14)=0 G DRGQ
S CDT=CDT+.001
S CODE=$G(CODE),CODE=$S(CODE:+CODE,1:$$DRGN^ICDEX(CODE)) ; GET ien
I CODE<1!'$D(^ICD(CODE)) S STR="-1^NO SUCH ENTRY",$P(STR,"^",14)=0 G DRGQ
S D0=^ICD(CODE,0)
; Get FY in YYY0000 format for the effective date
S FYDT=$$EFM^ICDEX($$FY^ICDEX(CDT))+.001
S DFY=$O(^ICD(CODE,"FY",FYDT),-1) S:DFY>0 DFYINF=^(DFY,0) I DFY'>0 D
. S DFYINF=U_$P(D0,U,2,4)_U_U_$P(D0,U,9)_U_$P(D0,U,12)_U_$P(D0,U,7)_U_$P(D0,U,8)_U_$P(D0,U,11)
S DCS=$O(^ICD(CODE,66,"B",CDT),-1),D1=$S(DCS'="":$O(^ICD(CODE,66,"B",DCS,0)),1:0) S DCSINF=$S(D1>0:^ICD(CODE,66,D1,0),1:"")
; If CSV does not exist, default to info
; at .01 level with status = inactive
I DCSINF="" S DCSINF=U_U_"0"_U_U_$P(D0,U,5,6)
; Resolve using "B" cross reference and fiscal year
; If ICDFY is not resolved set it to current fiscal year
S ICDFY=$O(^ICD(CODE,2,"B",CDT+.01),-1),DMC1=""
S DMC1=$O(^ICD(CODE,2,"B",+$G(ICDFY),DMC1)),DMC1=$P($G(^ICD(CODE,2,+DMC1,0)),U,3)
S STR=$P(D0,U)_U_$P(DFYINF,U,2,4)_U_$P(DCSINF,U,5,6)_U_U_$P(DFYINF,U,9)_U_$P(DFYINF,U,6,7)
S STR=STR_U_U_$P(D0,U,12)_U_$P(D0,U,13)_U_$P(DCSINF,U,3)_U_$P(D0,U,15)_U_$P(DCSINF,U)_U_CODE_U_DCS_U_$P(DMC1,U)_U_$P(DFYINF,U,8)_U_$P(DFYINF,U,10)
;
DRGQ ; DRG Quit on Error
Q STR
Q
DRGDES(IEN,CDT,ARY,LEN) ; Returns DRG Description in Array
;
; Input:
;
; IEN Internal Entry Number of DRG file 80.2
; CDT Date to screen against (default = TODAY)
; .ARY Output Array passed by reference
; LEN Length of each array node
; Missing Defaults to 79
; Less than 25 Defaults to 25
; Output:
;
; $$DRGD Number of lines in description output array
;
; ARY Description in array of length specified
;
N ICDI,ICDED,ICDID,ICDD,ICDL,ICDN,ICDT,N
K ARY S ICDL=$G(LEN) S:+ICDL'>0 ICDL=79 S:ICDL<25 ICDL=25
S ICDI=+($G(IEN)) S:ICDI'>0 ICDI=$$DRGN^ICDEX(IEN)
I +($G(IEN))'>0!('$D(^ICD(IEN))) S N="-1^DRG ENTRY NOT FOUND" G DRGDQ
S ICDD=$S($G(CDT)="":$$DT^XLFDT,1:$$DTBR^ICDEX(CDT,2))
S ICDED=$O(^ICD(+IEN,68,"B",(ICDD+.001)),-1)
S ICDID=$O(^ICD(+IEN,68,"B",+ICDED," "),-1)
S ICDN=0 F S ICDN=$O(^ICD(+IEN,68,+ICDID,ICDN)) Q:+ICDN'>0 D
. N ICDC S ICDT=$$TM($G(^ICD(+ICDI,68,+ICDID,1,+ICDN,0))) Q:'$L(ICDT)
. S ICDC=$O(ARY(" "),-1)+1,ARY(ICDC)=ICDT,ARY(0)=ICDC
D:+($G(ARY(0)))>0 PAR^ICDEX(.ARY,+($G(ICDL)))
S:+($O(ARY(" "),-1))>0 ARY(0)=+($O(ARY(" "),-1))
Q $G(ARY(0))
DRGD(CODE,OUTARR,CDT) ; returns CPT description in array
;
; Input:
;
; CODE ICD Code, Internal or External Format (required)
; ARY Output Array Name for description
; e.g. "ABC" or "ABC("TEST")"
; Default = ^TMP("DRGD",$J)
; CDT Date to screen against (default = TODAY)
; If CDT < 10/1/1978, use 10/1/1978
; If CDT > DT, use DT
; If CDT is year only, use first of the year
; If CDT is year/month only, use first of the month
;
; Output:
;
; $$DRGD Number of lines in description output array
;
; ARY Description in array
;
; @ARY(1:n) - Description (lines 1-n) (field 68)
; @ARY(n+1) - Blank
; @ARY(n+1) - Message: CODE TEXT MAY BE INACCURATE
;
; or
;
; -1^Error Description
;
; ** NOTE - USER MUST INITIALIZE ^TMP("DRGD",$J), IF USED **
;
N ARR,END,I,N,CTV,IEN
I $G(CODE)="" S N="-1^NO CODE SELECTED" G DRGDQ
I $G(OUTARR)="" S OUTARR="^TMP(""DRGD"",$J,"
I OUTARR'["(" S OUTARR=OUTARR_"("
I OUTARR[")" S OUTARR=$P(OUTARR,")")
S END=$E(OUTARR,$L(OUTARR)) I END'="("&(END'=",") S OUTARR=OUTARR_","
K:OUTARR="^TMP(""DRGD"",$J," ^TMP("DRGD",$J)
S CODE=$G(CODE),IEN=$S(CODE:+CODE,1:$$DRGN^ICDEX(CODE)),I=0,N=0
I +IEN<1!('$D(^ICD(IEN))) S N="-1^NO SUCH CODE" G DRGDQ
S CDT=$S($G(CDT)="":$$DT^XLFDT,1:$$DTBR^ICDEX(CDT,2))
D VLTDR(+IEN,CDT,.CTV) S (N,I)=0 F S I=$O(CTV(I)) Q:+I=0 D
. S N=N+1,ARR=OUTARR_N_")",@ARR=$$TM($G(CTV(I)))
I +N>0 S N=N+1,ARR=OUTARR_N_")",@ARR=" ",N=N+1,ARR=OUTARR_N_")",@ARR=$$MSG^ICDEX(CDT,2)
I +N'>0 S N="-1^VERSIONED DESCRIPTION NOT FOUND FOR "_CODE
DRGDQ ; DRG Description Quit
Q N
Q
GETDATE(IEN) ; Calculate Effective Date from the PTF
;
;
; Input:
;
; IEN Internal Entry Number of the PTF file #45
;
; Output:
;
; $$GETDATE Returns the correct "EFFECTIVE DATE"
; for a patient to uses retrieving and
; calculating DRG/ICD/CPT data (default
; TODAY)
;
; Derived from:
; Census Date ^DGPT 0;13
; Discharge Date ^DG(45.86 0;1
; Surgery Date ^DGPT(D0,"S" 0;1
; Movement Date ^DGPT(D0,"M" 0;10
;
N ICDI,ICDE,ICDP,ICDT S ICDT=$$NOW^XLFDT
S ICDI=+($G(IEN)) Q:'$D(^DGPT(ICDI,0)) ICDT
S ICDP=$P($G(^DGPT(ICDI,0)),U,13) I ICDP'="" D Q:ICDE'="" ICDE
. S ICDE=$P($G(^DG(45.86,ICDP,0)),U,1)
S ICDE=$P($G(^DGPT(ICDI,70)),U,1) Q:ICDE'="" ICDE
S ICDE=$P($G(^DGPT(ICDI,"S",1,0)),U,1) Q:ICDE'="" ICDE
S ICDE=$P($G(^DGPT(ICDI,"M",1,0)),U,10)
S:'$L(ICDE) ICDE=ICDT
Q ICDE
VLTDR(IEN,CDT,ARY) ; Versioned Description - Long Text
;
; Input:
;
; IEN Internal Entry Number file 80.2
; CDT Effective/Versioning date to be used
; .ARY Array for output, passed by reference
;
; Output:
;
; ARY() Local array containing versioned description
;
N ICD0,ICDC,ICDI,ICDSTD,ICDSTI,ICDVDT,ICDTXT,ICDD,ICDT,ICDE
S ICDI=+($G(IEN)) Q:+ICDI'>0 Q:'$D(^ICD(+ICDI))
S ICDVDT=$G(CDT) S:'$L(ICDVDT)!(+ICDVDT'>0) ICDVDT=$$DT^XLFDT Q:$P(ICDVDT,".",1)'?7N
S ICD0=$G(^ICD(+ICDI,0)),ICDC=$P(ICD0,"^",1) Q:'$L(ICDC)
S ICDSTD=$O(^ICD("ADS",(ICDC_" "),(ICDVDT+.000001)),-1)
I +ICDSTD>0 D Q:+($O(ARY(0)))>0
. S ICDSTI=$O(^ICD("ADS",(ICDC_" "),ICDSTD,+ICDI," "),-1)
. S (ICDD,ICDT)=0 F S ICDD=$O(^ICD(+ICDI,68,ICDSTI,1,ICDD)) Q:+ICDD=0 D
. . S ICDT=ICDT+1,ARY(ICDT)=$G(^ICD(+ICDI,68,+ICDSTI,1,+ICDD,0)),ARY(0)=ICDT
S ICDSTD=$O(^ICD(+ICDI,68,"B"," "),-1) I +ICDSTD>0 D Q:+($O(ARY(0)))>0
. S ICDSTI=$O(^ICD(+ICDI,68,"B",ICDSTD,0))
. S (ICDD,ICDT)=0 F S ICDD=$O(^ICD(+ICDI,68,ICDSTI,1,ICDD)) Q:+ICDD=0 D
. . S ICDT=ICDT+1,ARY(ICDT)=$G(^ICD(+ICDI,68,+ICDSTI,1,+ICDD,0)),ARY(0)=ICDT
K ARY S (ICDD,ICDT)=0 F S ICDD=$O(^ICD(ICDI,1,ICDD)) Q:+ICDD=0 D
. S ICDT=ICDT+1,ARY(ICDT)=$G(^ICD(ICDI,1,ICDD,0)),ARY(0)=ICDT
Q
TM(X) ; Trim Spaces
S X=$G(X) Q:X="" X F Q:$E(X,1)'=" " S X=$E(X,2,$L(X))
F Q:$E(X,$L(X))'=" " S X=$E(X,1,($L(X)-1))
F Q:X'[" " S X=$P(X," ",1)_" "_$P(X," ",2,229)
Q X
DRGN(CODE) ; Return the IEN of DRG
;
; Input:
;
; CODE DRG code
;
; Output:
;
; $$DRGN IEN of DRG code
;
; or
;
; -1 on error
;
Q:$G(CODE)="" -1
N COD S COD=+$O(^ICD("B",CODE,0))
Q $S(COD>0:COD,1:-1)
Q
DRGC(IEN) ; DRG Code
;
; Input:
;
; IEN Internal Entry Number file 80.2
;
; Output:
;
; $$DRGC Code (field .01)
;
; Replaces ICR 370
;
S IEN=+($G(IEN)) Q:'$D(^ICD(+IEN,0)) ""
Q $P($G(^ICD(+IEN,0)),"^",1)
DRGW(IEN) ; DRG Weighted Work Unit (WWU)
;
; Input:
;
; IEN Internal Entry Number file 80.2
;
; Output:
;
; $$WT Weight
;
; Replaces ICR 48
;
S IEN=+($G(IEN)) Q:'$D(^ICD(+IEN,0)) ""
Q $P($G(^ICD(+IEN,0)),"^",2)
CARD(X) ; Implants/Insertion Cardio Device (EN1^ICDDRG5)
N SO S X="^" S:$D(ICDOP(" 00.50")) $P(X,"^",2)=1 S:$D(ICDOP(" 00.52"))&($D(ICDOP(" 00.53"))) $P(X,"^",2)=1
I $D(ICDOP(" 37.70"))!($D(ICDOP(" 37.71")))!($D(ICDOP(" 37.73"))) D Q X
. N SO F SO="37.80","37.81","37.82","37.85","37.86","37.87" S:$D(ICDOP((" "_SO))) $P(X,"^",2)=1
I $D(ICDOP(" 37.72")) D Q X
. S:$D(ICDOP(" 37.80"))!($D(ICDOP(" 37.83"))) $P(X,"^",2)=1
I $D(ICDOP(" 37.74")) D Q X
. N SO F SO="37.80","37.81","37.82","37.83","37.85","37.86","37.87" S:$D(ICDOP((" "_SO))) $P(X,"^",2)=1
I $D(ICDOP(" 37.76")) D Q X
. N SO F SO="37.80","37.85","37.86","37.87" S:$D(ICDOP((" "_SO))) $P(X,"^",2)=1
I $D(ICDOP(" 00.53")) D
. N SO F SO="37.70","37.71","37.72","37.73","37.74","37.76" S:$D(ICDOP((" "_SO))) $P(X,"^",2)=1
N SO F SO="00.54","37.95","37.96","37.97","37.98","00.52" S:$D(ICDOP((" "_SO))) $P(X,"^",1)=1
Q X
SPIN(X) ; Paired Spinal Fusion Codes (EN1^ICDDRG8)
N SP,ICDA,ICDB S (ICDA,ICDB,X)=0
F SO="81.02","81.04","81.06","81.32","81.34","81.36" S:$D(ICDOP((" "_SO))) ICDA=1
F SO="81.03","81.05","81.07","81.08","81.33","81.35","81.37","81.38" S:$D(ICDOP((" "_SO))) ICDB=1
S:ICDA&(ICDB) X=1
Q X
ICDEXD5 ;SLC/KER - ICD Extractor - DRG APIs (cont) ;04/21/2014
+1 ;;18.0;DRG Grouper;**57**;Oct 20, 2000;Build 7
+2 ;
+3 ; Global Variables
+4 ; ^DG(45.86) ICR 5821
+5 ; ^DGPT( ICR 5822
+6 ; ^ICD("ADS") N/A
+7 ; ^ICD("B") N/A
+8 ; ^TMP("DRGD") SACC 2.3.2.5.1
+9 ;
+10 ; External References
+11 ; $$DT^XLFDT ICR 10103
+12 ; $$NOW^XLFDT ICR 10103
+13 ;
+14 QUIT
DRG(CODE,CDT) ; Returns a string of information from the DRG file (#80.2)
+1 ;
+2 ; Input:
+3 ;
+4 ; CODE DRG code, internal or external format (Required)
+5 ; CDT Date, FileMan format (default = TODAY)
+6 ; If CDT < 10/1/1978, use 10/1/1978
+7 ; If CDT > DT, validate with In/Activation Dates
+8 ; If CDT is year only, use first of the year
+9 ; If CDT is year and month, use first of the month
+10 ;
+11 ; Output:
+12 ;
+13 ; Returns an 22 piece string delimited by the
+14 ; up-arrow (^) the pieces are:
+15 ;
+16 ; 1 DRG name (field #.01)
+17 ; 2 Weight (field #2)
+18 ; 3 Low Trim (days) (field #3)
+19 ; 4 High Trim (days) (field #4)
+20 ; 5 MDC (field #5)
+21 ; 6 Surgery Flag (field #.06)
+22 ; 7 <null>
+23 ; 8 Avg Length of Stay (days) (field 10)
+24 ; 9 Local Low Trim Days (field #11)
+25 ; 10 Local High Trim Days (field #12)
+26 ; 11 <null>
+27 ; 12 Local Breakeven (field #13)
+28 ; 13 Activation Date (.01 of the 66 multiple)
+29 ; 14 Status (.03 of the 66 multiple)
+30 ; 15 Inactivation Date (.01 of the 66 multiple)
+31 ; 16 Effective date (.01 of the 66 multiple)
+32 ; 17 Internal Entry Number (IEN)
+33 ; 18 Effective date (.01 of the 66 multiple)
+34 ; 19 Reference (field #900)
+35 ; 20 Weight (Non Affil) (field #7)
+36 ; 21 Weight (Int Affil) (field #7.5)
+37 ; 22 Message
+38 ;
+39 ; or
+40 ;
+41 ; -1^Error Description
+42 ;
+43 NEW D0,DCS,DFY,DFYINF,DCSINF,DMC1,D1,FYDT,FYMD,ICDFY,ICDIMP,STR
+44 SET CDT=$PIECE(CDT,".",1)
IF CDT'?7N
SET CDT=DT
SET CDT=$$DTBR^ICDEX(CDT,2)
+45 IF $GET(CODE)=""
SET STR="-1^NO CODE SELECTED"
SET $PIECE(STR,"^",14)=0
GOTO DRGQ
+46 SET CDT=CDT+.001
+47 ; GET ien
SET CODE=$GET(CODE)
SET CODE=$SELECT(CODE:+CODE,1:$$DRGN^ICDEX(CODE))
+48 IF CODE<1!'$DATA(^ICD(CODE))
SET STR="-1^NO SUCH ENTRY"
SET $PIECE(STR,"^",14)=0
GOTO DRGQ
+49 SET D0=^ICD(CODE,0)
+50 ; Get FY in YYY0000 format for the effective date
+51 SET FYDT=$$EFM^ICDEX($$FY^ICDEX(CDT))+.001
+52 SET DFY=$ORDER(^ICD(CODE,"FY",FYDT),-1)
IF DFY>0
SET DFYINF=^(DFY,0)
IF DFY'>0
Begin DoDot:1
+53 SET DFYINF=U_$PIECE(D0,U,2,4)_U_U_$PIECE(D0,U,9)_U_$PIECE(D0,U,12)_U_$PIECE(D0,U,7)_U_$PIECE(D0,U,8)_U_$PIECE(D0,U,11)
End DoDot:1
+54 SET DCS=$ORDER(^ICD(CODE,66,"B",CDT),-1)
SET D1=$SELECT(DCS'="":$ORDER(^ICD(CODE,66,"B",DCS,0)),1:0)
SET DCSINF=$SELECT(D1>0:^ICD(CODE,66,D1,0),1:"")
+55 ; If CSV does not exist, default to info
+56 ; at .01 level with status = inactive
+57 IF DCSINF=""
SET DCSINF=U_U_"0"_U_U_$PIECE(D0,U,5,6)
+58 ; Resolve using "B" cross reference and fiscal year
+59 ; If ICDFY is not resolved set it to current fiscal year
+60 SET ICDFY=$ORDER(^ICD(CODE,2,"B",CDT+.01),-1)
SET DMC1=""
+61 SET DMC1=$ORDER(^ICD(CODE,2,"B",+$GET(ICDFY),DMC1))
SET DMC1=$PIECE($GET(^ICD(CODE,2,+DMC1,0)),U,3)
+62 SET STR=$PIECE(D0,U)_U_$PIECE(DFYINF,U,2,4)_U_$PIECE(DCSINF,U,5,6)_U_U_$PIECE(DFYINF,U,9)_U_$PIECE(DFYINF,U,6,7)
+63 SET STR=STR_U_U_$PIECE(D0,U,12)_U_$PIECE(D0,U,13)_U_$PIECE(DCSINF,U,3)_U_$PIECE(D0,U,15)_U_$PIECE(DCSINF,U)_U_CODE_U_DCS_U_$PIECE(DMC1,U)_U_$PIECE(DFYINF,U,8)_U_$PIECE(DFYINF,U,10)
+64 ;
DRGQ ; DRG Quit on Error
+1 QUIT STR
+2 QUIT
DRGDES(IEN,CDT,ARY,LEN) ; Returns DRG Description in Array
+1 ;
+2 ; Input:
+3 ;
+4 ; IEN Internal Entry Number of DRG file 80.2
+5 ; CDT Date to screen against (default = TODAY)
+6 ; .ARY Output Array passed by reference
+7 ; LEN Length of each array node
+8 ; Missing Defaults to 79
+9 ; Less than 25 Defaults to 25
+10 ; Output:
+11 ;
+12 ; $$DRGD Number of lines in description output array
+13 ;
+14 ; ARY Description in array of length specified
+15 ;
+16 NEW ICDI,ICDED,ICDID,ICDD,ICDL,ICDN,ICDT,N
+17 KILL ARY
SET ICDL=$GET(LEN)
IF +ICDL'>0
SET ICDL=79
IF ICDL<25
SET ICDL=25
+18 SET ICDI=+($GET(IEN))
IF ICDI'>0
SET ICDI=$$DRGN^ICDEX(IEN)
+19 IF +($GET(IEN))'>0!('$DATA(^ICD(IEN)))
SET N="-1^DRG ENTRY NOT FOUND"
GOTO DRGDQ
+20 SET ICDD=$SELECT($GET(CDT)="":$$DT^XLFDT,1:$$DTBR^ICDEX(CDT,2))
+21 SET ICDED=$ORDER(^ICD(+IEN,68,"B",(ICDD+.001)),-1)
+22 SET ICDID=$ORDER(^ICD(+IEN,68,"B",+ICDED," "),-1)
+23 SET ICDN=0
FOR
SET ICDN=$ORDER(^ICD(+IEN,68,+ICDID,ICDN))
IF +ICDN'>0
QUIT
Begin DoDot:1
+24 NEW ICDC
SET ICDT=$$TM($GET(^ICD(+ICDI,68,+ICDID,1,+ICDN,0)))
IF '$LENGTH(ICDT)
QUIT
+25 SET ICDC=$ORDER(ARY(" "),-1)+1
SET ARY(ICDC)=ICDT
SET ARY(0)=ICDC
End DoDot:1
+26 IF +($GET(ARY(0)))>0
DO PAR^ICDEX(.ARY,+($GET(ICDL)))
+27 IF +($ORDER(ARY(" "),-1))>0
SET ARY(0)=+($ORDER(ARY(" "),-1))
+28 QUIT $GET(ARY(0))
DRGD(CODE,OUTARR,CDT) ; returns CPT description in array
+1 ;
+2 ; Input:
+3 ;
+4 ; CODE ICD Code, Internal or External Format (required)
+5 ; ARY Output Array Name for description
+6 ; e.g. "ABC" or "ABC("TEST")"
+7 ; Default = ^TMP("DRGD",$J)
+8 ; CDT Date to screen against (default = TODAY)
+9 ; If CDT < 10/1/1978, use 10/1/1978
+10 ; If CDT > DT, use DT
+11 ; If CDT is year only, use first of the year
+12 ; If CDT is year/month only, use first of the month
+13 ;
+14 ; Output:
+15 ;
+16 ; $$DRGD Number of lines in description output array
+17 ;
+18 ; ARY Description in array
+19 ;
+20 ; @ARY(1:n) - Description (lines 1-n) (field 68)
+21 ; @ARY(n+1) - Blank
+22 ; @ARY(n+1) - Message: CODE TEXT MAY BE INACCURATE
+23 ;
+24 ; or
+25 ;
+26 ; -1^Error Description
+27 ;
+28 ; ** NOTE - USER MUST INITIALIZE ^TMP("DRGD",$J), IF USED **
+29 ;
+30 NEW ARR,END,I,N,CTV,IEN
+31 IF $GET(CODE)=""
SET N="-1^NO CODE SELECTED"
GOTO DRGDQ
+32 IF $GET(OUTARR)=""
SET OUTARR="^TMP(""DRGD"",$J,"
+33 IF OUTARR'["("
SET OUTARR=OUTARR_"("
+34 IF OUTARR[")"
SET OUTARR=$PIECE(OUTARR,")")
+35 SET END=$EXTRACT(OUTARR,$LENGTH(OUTARR))
IF END'="("&(END'=",")
SET OUTARR=OUTARR_","
+36 IF OUTARR="^TMP(""DRGD"",$J,"
KILL ^TMP("DRGD",$JOB)
+37 SET CODE=$GET(CODE)
SET IEN=$SELECT(CODE:+CODE,1:$$DRGN^ICDEX(CODE))
SET I=0
SET N=0
+38 IF +IEN<1!('$DATA(^ICD(IEN)))
SET N="-1^NO SUCH CODE"
GOTO DRGDQ
+39 SET CDT=$SELECT($GET(CDT)="":$$DT^XLFDT,1:$$DTBR^ICDEX(CDT,2))
+40 DO VLTDR(+IEN,CDT,.CTV)
SET (N,I)=0
FOR
SET I=$ORDER(CTV(I))
IF +I=0
QUIT
Begin DoDot:1
+41 SET N=N+1
SET ARR=OUTARR_N_")"
SET @ARR=$$TM($GET(CTV(I)))
End DoDot:1
+42 IF +N>0
SET N=N+1
SET ARR=OUTARR_N_")"
SET @ARR=" "
SET N=N+1
SET ARR=OUTARR_N_")"
SET @ARR=$$MSG^ICDEX(CDT,2)
+43 IF +N'>0
SET N="-1^VERSIONED DESCRIPTION NOT FOUND FOR "_CODE
DRGDQ ; DRG Description Quit
+1 QUIT N
+2 QUIT
GETDATE(IEN) ; Calculate Effective Date from the PTF
+1 ;
+2 ;
+3 ; Input:
+4 ;
+5 ; IEN Internal Entry Number of the PTF file #45
+6 ;
+7 ; Output:
+8 ;
+9 ; $$GETDATE Returns the correct "EFFECTIVE DATE"
+10 ; for a patient to uses retrieving and
+11 ; calculating DRG/ICD/CPT data (default
+12 ; TODAY)
+13 ;
+14 ; Derived from:
+15 ; Census Date ^DGPT 0;13
+16 ; Discharge Date ^DG(45.86 0;1
+17 ; Surgery Date ^DGPT(D0,"S" 0;1
+18 ; Movement Date ^DGPT(D0,"M" 0;10
+19 ;
+20 NEW ICDI,ICDE,ICDP,ICDT
SET ICDT=$$NOW^XLFDT
+21 SET ICDI=+($GET(IEN))
IF '$DATA(^DGPT(ICDI,0))
QUIT ICDT
+22 SET ICDP=$PIECE($GET(^DGPT(ICDI,0)),U,13)
IF ICDP'=""
Begin DoDot:1
+23 SET ICDE=$PIECE($GET(^DG(45.86,ICDP,0)),U,1)
End DoDot:1
IF ICDE'=""
QUIT ICDE
+24 SET ICDE=$PIECE($GET(^DGPT(ICDI,70)),U,1)
IF ICDE'=""
QUIT ICDE
+25 SET ICDE=$PIECE($GET(^DGPT(ICDI,"S",1,0)),U,1)
IF ICDE'=""
QUIT ICDE
+26 SET ICDE=$PIECE($GET(^DGPT(ICDI,"M",1,0)),U,10)
+27 IF '$LENGTH(ICDE)
SET ICDE=ICDT
+28 QUIT ICDE
VLTDR(IEN,CDT,ARY) ; Versioned Description - Long Text
+1 ;
+2 ; Input:
+3 ;
+4 ; IEN Internal Entry Number file 80.2
+5 ; CDT Effective/Versioning date to be used
+6 ; .ARY Array for output, passed by reference
+7 ;
+8 ; Output:
+9 ;
+10 ; ARY() Local array containing versioned description
+11 ;
+12 NEW ICD0,ICDC,ICDI,ICDSTD,ICDSTI,ICDVDT,ICDTXT,ICDD,ICDT,ICDE
+13 SET ICDI=+($GET(IEN))
IF +ICDI'>0
QUIT
IF '$DATA(^ICD(+ICDI))
QUIT
+14 SET ICDVDT=$GET(CDT)
IF '$LENGTH(ICDVDT)!(+ICDVDT'>0)
SET ICDVDT=$$DT^XLFDT
IF $PIECE(ICDVDT,".",1)'?7N
QUIT
+15 SET ICD0=$GET(^ICD(+ICDI,0))
SET ICDC=$PIECE(ICD0,"^",1)
IF '$LENGTH(ICDC)
QUIT
+16 SET ICDSTD=$ORDER(^ICD("ADS",(ICDC_" "),(ICDVDT+.000001)),-1)
+17 IF +ICDSTD>0
Begin DoDot:1
+18 SET ICDSTI=$ORDER(^ICD("ADS",(ICDC_" "),ICDSTD,+ICDI," "),-1)
+19 SET (ICDD,ICDT)=0
FOR
SET ICDD=$ORDER(^ICD(+ICDI,68,ICDSTI,1,ICDD))
IF +ICDD=0
QUIT
Begin DoDot:2
+20 SET ICDT=ICDT+1
SET ARY(ICDT)=$GET(^ICD(+ICDI,68,+ICDSTI,1,+ICDD,0))
SET ARY(0)=ICDT
End DoDot:2
End DoDot:1
IF +($ORDER(ARY(0)))>0
QUIT
+21 SET ICDSTD=$ORDER(^ICD(+ICDI,68,"B"," "),-1)
IF +ICDSTD>0
Begin DoDot:1
+22 SET ICDSTI=$ORDER(^ICD(+ICDI,68,"B",ICDSTD,0))
+23 SET (ICDD,ICDT)=0
FOR
SET ICDD=$ORDER(^ICD(+ICDI,68,ICDSTI,1,ICDD))
IF +ICDD=0
QUIT
Begin DoDot:2
+24 SET ICDT=ICDT+1
SET ARY(ICDT)=$GET(^ICD(+ICDI,68,+ICDSTI,1,+ICDD,0))
SET ARY(0)=ICDT
End DoDot:2
End DoDot:1
IF +($ORDER(ARY(0)))>0
QUIT
+25 KILL ARY
SET (ICDD,ICDT)=0
FOR
SET ICDD=$ORDER(^ICD(ICDI,1,ICDD))
IF +ICDD=0
QUIT
Begin DoDot:1
+26 SET ICDT=ICDT+1
SET ARY(ICDT)=$GET(^ICD(ICDI,1,ICDD,0))
SET ARY(0)=ICDT
End DoDot:1
+27 QUIT
TM(X) ; Trim Spaces
+1 SET X=$GET(X)
IF X=""
QUIT X
FOR
IF $EXTRACT(X,1)'=" "
QUIT
SET X=$EXTRACT(X,2,$LENGTH(X))
+2 FOR
IF $EXTRACT(X,$LENGTH(X))'=" "
QUIT
SET X=$EXTRACT(X,1,($LENGTH(X)-1))
+3 FOR
IF X'[" "
QUIT
SET X=$PIECE(X," ",1)_" "_$PIECE(X," ",2,229)
+4 QUIT X
DRGN(CODE) ; Return the IEN of DRG
+1 ;
+2 ; Input:
+3 ;
+4 ; CODE DRG code
+5 ;
+6 ; Output:
+7 ;
+8 ; $$DRGN IEN of DRG code
+9 ;
+10 ; or
+11 ;
+12 ; -1 on error
+13 ;
+14 IF $GET(CODE)=""
QUIT -1
+15 NEW COD
SET COD=+$ORDER(^ICD("B",CODE,0))
+16 QUIT $SELECT(COD>0:COD,1:-1)
+17 QUIT
DRGC(IEN) ; DRG Code
+1 ;
+2 ; Input:
+3 ;
+4 ; IEN Internal Entry Number file 80.2
+5 ;
+6 ; Output:
+7 ;
+8 ; $$DRGC Code (field .01)
+9 ;
+10 ; Replaces ICR 370
+11 ;
+12 SET IEN=+($GET(IEN))
IF '$DATA(^ICD(+IEN,0))
QUIT ""
+13 QUIT $PIECE($GET(^ICD(+IEN,0)),"^",1)
DRGW(IEN) ; DRG Weighted Work Unit (WWU)
+1 ;
+2 ; Input:
+3 ;
+4 ; IEN Internal Entry Number file 80.2
+5 ;
+6 ; Output:
+7 ;
+8 ; $$WT Weight
+9 ;
+10 ; Replaces ICR 48
+11 ;
+12 SET IEN=+($GET(IEN))
IF '$DATA(^ICD(+IEN,0))
QUIT ""
+13 QUIT $PIECE($GET(^ICD(+IEN,0)),"^",2)
CARD(X) ; Implants/Insertion Cardio Device (EN1^ICDDRG5)
+1 NEW SO
SET X="^"
IF $DATA(ICDOP(" 00.50"))
SET $PIECE(X,"^",2)=1
IF $DATA(ICDOP(" 00.52"))&($DATA(ICDOP(" 00.53")))
SET $PIECE(X,"^",2)=1
+2 IF $DATA(ICDOP(" 37.70"))!($DATA(ICDOP(" 37.71")))!($DATA(ICDOP(" 37.73")))
Begin DoDot:1
+3 NEW SO
FOR SO="37.80","37.81","37.82","37.85","37.86","37.87"
IF $DATA(ICDOP((" "_SO)))
SET $PIECE(X,"^",2)=1
End DoDot:1
QUIT X
+4 IF $DATA(ICDOP(" 37.72"))
Begin DoDot:1
+5 IF $DATA(ICDOP(" 37.80"))!($DATA(ICDOP(" 37.83")))
SET $PIECE(X,"^",2)=1
End DoDot:1
QUIT X
+6 IF $DATA(ICDOP(" 37.74"))
Begin DoDot:1
+7 NEW SO
FOR SO="37.80","37.81","37.82","37.83","37.85","37.86","37.87"
IF $DATA(ICDOP((" "_SO)))
SET $PIECE(X,"^",2)=1
End DoDot:1
QUIT X
+8 IF $DATA(ICDOP(" 37.76"))
Begin DoDot:1
+9 NEW SO
FOR SO="37.80","37.85","37.86","37.87"
IF $DATA(ICDOP((" "_SO)))
SET $PIECE(X,"^",2)=1
End DoDot:1
QUIT X
+10 IF $DATA(ICDOP(" 00.53"))
Begin DoDot:1
+11 NEW SO
FOR SO="37.70","37.71","37.72","37.73","37.74","37.76"
IF $DATA(ICDOP((" "_SO)))
SET $PIECE(X,"^",2)=1
End DoDot:1
+12 NEW SO
FOR SO="00.54","37.95","37.96","37.97","37.98","00.52"
IF $DATA(ICDOP((" "_SO)))
SET $PIECE(X,"^",1)=1
+13 QUIT X
SPIN(X) ; Paired Spinal Fusion Codes (EN1^ICDDRG8)
+1 NEW SP,ICDA,ICDB
SET (ICDA,ICDB,X)=0
+2 FOR SO="81.02","81.04","81.06","81.32","81.34","81.36"
IF $DATA(ICDOP((" "_SO)))
SET ICDA=1
+3 FOR SO="81.03","81.05","81.07","81.08","81.33","81.35","81.37","81.38"
IF $DATA(ICDOP((" "_SO)))
SET ICDB=1
+4 IF ICDA&(ICDB)
SET X=1
+5 QUIT X
