ICD1831K ; ALB/ECF - FY 2007 UPDATE; 10/23/07 2:50 pm;
;;18.0;DRG Grouper;**31**;Oct 13,2000;Build 7
Q
;
DRG(ICDTMP) ;post-install driver for file ICD Operation/Procedure
; file(#80.1) DRG updates
;This procedure loops through the ICD OPERATION/PROCDURE file (80.1)
;to create a DRG GROUPER EFFECTIVE DATE entry for FY08
; Input:
; ICDTMP - Temp file of error msg's
; Output:
; ICDTMP - Temp file of error msg's
; ICDTOT - Total MS-DRG codes filed
; ICDERTOT - Total error records - cannot file
;
N ICDI,ICDCRCD,ICDFOK,ICDNWCD,ICDTOT,ICDX,ICDY,ICDVAL,ICDETOT,ICDYY,ICDZZ
S U="^"
;
D BMES^XPDUTL(">>> Adding FY08 DRG Grouper updates to ICD OP/PR file (#80.1)...")
;Error log
S ICDTMP=$G(ICDTMP)
I ICDTMP']"" S ICDTMP=$NA(^TMP("ICDDGFY2008OP",$J)) D
. K @ICDTMP
. S @ICDTMP@(0)="PATCH #? FY08 ICD DIAG DRG UPDATE^"_$$NOW^XLFDT
;
;Skip inactive
S (ICDETOT,ICDI,ICDTOT,ICDYY)=0
;
F S ICDI=$O(^ICD0(ICDI)) Q:ICDI=""!(ICDI'?.N) D
.;quit if no zero node
.Q:$G(^ICD0(ICDI,0))=""
.;quit if zero node corrupt
.Q:$P($G(^ICD0(ICDI,0)),U)']""
.S ICDVAL=$P($G(^ICD0(ICDI,0)),U)
.Q:ICDVAL=""
.;quit if code is inactive
.S ICDZZ=$$ICDOP^ICDCODE(ICDVAL,3071001) Q:$P($G(ICDZZ),U,10)=0
.;check if already created in case patch being re-installed
.Q:$D(^ICD0(ICDI,2,"B",3071001))
.;
.;Get ien of latest Grouper Effective Date
.S ICDX=$O(^ICD0(ICDI,2,"B",9999999),-1)
.;No Grp Eff Dt means this is a new code
.I ICDX']"" D
..;Call API
..K ICDNCDAR
..D NEW801^ICD1831L(ICDVAL,.ICDNCDAR)
..Q:'$D(ICDNCDAR)
..;Build code array for UPDDIAG()
..K ICDCONAR
..D GETNCRCD(ICDI,.ICDNCDAR,.ICDCONAR)
..Q:'$D(ICDCONAR(0))
..D UPDDIAG(ICDI,.ICDCONAR,.ICDTOT)
.;
.I ICDX]"" D
..;Old codes to convert
..;Call will be $$CONV801^ICD1831L(<ien of code>)for each MDC/DRG set
..S ICDLEDI=$O(^ICD0(ICDI,2,"B",ICDX,0))
..S (ICDFYMI,ICDY)=0
..;Loop through MDCs for this ICD PROC - DRG EFF DATE
..F S ICDFYMI=$O(^ICD0(ICDI,2,ICDLEDI,1,ICDFYMI)) Q:ICDFYMI=""!(ICDFYMI'?.N) D
...K ICDNWCD,ICDNWCDA
...S ICDDGCD=$$GETCRCD(ICDI,ICDLEDI,ICDFYMI) ;Build code string for conversion API
...;If no code string for this MDC, nothing to convert
...Q:ICDDGCD']""
...;Code string is ok, pass to conversion function
...S ICDNWCD=$$CONV801^ICD1831L(ICDDGCD)
...;Return codes are in string ICDCRCD <.01>^<MDC ien>^<DRG ien)^<DRG ien>.........
...;Filer requires an array - at least a zero node is needed
...I ICDNWCD]"" K ICDNWCDA S ICDNWCDA(0)=ICDNWCD
...;Now process the array of code strings for this ICD Proc IEN
...Q:ICDNWCDA(0)']""
...;pass new codes to update procedure
...;D UPDDIAG(ICDI,"X",.ICDNWCDA,.ICDTOT)
...D UPDDIAG(ICDI,.ICDNWCDA,.ICDTOT)
...K ICDNWCDA
.
;Back to top level - processing is over - do final tasks
K ICDCONAR,ICDDGCD,ICDETOT,ICDFYMI,ICDNCDAR,ICDNWCDA
;HANDLE ERRORS
;No errors present
;
S (ICDTOT,ICDYY)=0
F S ICDYY=$O(^TMP("ICDFILEOK",$J,ICDYY)) Q:ICDYY="" I ^TMP("ICDFILEOK",$J,ICDYY)=1 S ICDTOT=ICDTOT+1
I '$D(@ICDTMP@("ERROR")) D
. D MES^XPDUTL(">>> ICD PROCEDURE File DRG Updates Completed...")
. D MES^XPDUTL(" ...Total Codes Edited: "_ICDTOT)
. D MES^XPDUTL("")
Q
;Errors present
;
I $D(@ICDTMP@("ERROR")) D
. F S ICDXX=$O(^TMP("ICDDGFY2008OP",$J,"ERROR",ICDXX)) Q:ICDXX="" D
..S ICDETOT=ICDETOT+1
. D MES^XPDUTL(">>> ...Total Errors "_ICDETOT_" ERRORS")
. D MES^XPDUTL("")
. D MES^XPDUTL("Error are in ^TMP(""ICDDGFY2008OP"",$J)")
;
K ICDCRCD,ICDVAL,ICDZZ
K ^TMP("ICDFILEOK")
Q
;
;END OF DRIVER
;Start of helper functions and procedures
;
GETCRCD(ICDIEN,ICDDGIEN,ICDMDIEN) ;
;Create input string for conversion API - only for non-New DRGs
;
;INPUT ICDIEN = ien in file 80.1 ICD OPERATION/PROCEDURE
; ICDDGIEN = ien of last DRG GROUPER EFFECTIVE DATE
; ICDMDIEN = ien of Major Diagnostic Category
;OUTPUT ICDCRDCS = string of codes formatted for API
;
N ICDCRCDS,ICDXS
;
S (ICDCRCD)=""
S (ICDX)=0
;
;START STRING WITH THE .01 FIELD
S ICDCRCDS=$P(^ICD0(ICDI,0),U)
;
;Add MDC ien to string
S ICDCRCDS=ICDCRCDS_"^"_$P($G(^ICD0(ICDIEN,2,ICDDGIEN,1,ICDMDIEN,0)),U)
;
;Loop thru DRGs this ICD procedure, this eff date, this MDC
;
F S ICDX=$O(^ICD0(ICDIEN,2,ICDDGIEN,1,ICDMDIEN,1,ICDX)) Q:ICDX=""!(ICDX'?.N) D
.Q:$G(^ICD0(ICDIEN,2,ICDDGIEN,1,ICDMDIEN,1,ICDX,0))=""
.S ICDCRCDS=ICDCRCDS_"^"_$P($G(^ICD0(ICDIEN,2,ICDDGIEN,1,ICDMDIEN,1,ICDX,0)),U)
Q ICDCRCDS
;
GETNCRCD(ICDIENP,ICDOAR,ICDCAR) ;
;Quit if input not correct, passing back a null zero node
I '$D(ICDIENP) S ICDCAR(0)="" Q
;
N ICDK,ICDJ,ICDL
S (ICDJ,ICDK,ICDL)=0
F S ICDJ=$O(ICDOAR(ICDJ)) Q:ICDJ="" D
.S ICDCAR(ICDL)=ICDIENP_"^"_ICDJ_"^"
.F S ICDK=$O(ICDOAR(ICDJ,ICDK)) Q:ICDK="" D
..S ICDCAR(ICDL)=ICDCAR(ICDL)_ICDK_"^"
.S ICDL=ICDL+1
Q
;
;
UPDDIAG(ICDIP,ICDNWCDA,ICDTOTP) ;
;File 80.1 updater
;
N ICDX1
; F ICDZ=1:1:3 I $P(ICDIAGP,U,ICDZ)']"" D Q
; .S @ICDTMP@("ERROR",ICDIP,"80.1")="Missing field "_ICDZ_" filing "_ICDIAGP
;
;Quit if complete data not passed
Q:'$D(ICDIP)
Q:'$D(ICDNWCDA(0))
Q:$P($G(ICDNWCDA(0)),U,1)']""
Q:$P($G(ICDNWCDA(0)),U,2)']""
Q:$P($G(ICDNWCDA(0)),U,3)']""
;
S ^TMP("ICDFILEOK",$J,ICDIP)=1
;
K FDA(1831)
;
;Passed in array will trigger DRG Effective Date Multiple ONLY IF NEEDED
;
I '$D(^ICD0(ICDIP,2,"B",3071001)) D
.;DRG GROUPER EFFECTIVE DATE MULTIPLE
.S FDA(1831,80.1,"?1,",.01)="`"_ICDIP
.S FDA(1831,80.171,"+2,?1,",.01)=3071001
.D UPDATE^DIE("","FDA(1831)")
.K FDA(1831)
;
S ICDX1=""
;
F S ICDX1=$O(ICDNWCDA(ICDX1)) Q:ICDX1="" D
.;ADD MDC MULTIPLE only if there are DRG codes for the MDC
.I $P(ICDNWCDA(ICDX1),U,2)]"" D K FDA
..Q:$P(ICDNWCDA(ICDX1),U,3)']""
..S FDA(1831,80.1,"?1,",.01)="`"_ICDIP
..S FDA(1831,80.171,"?2,?1,",.01)=3071001
..S FDA(1831,80.1711,"+3,?2,?1,",.01)=$P(ICDNWCDA(ICDX1),U,2)
..D UPDATE^DIE("","FDA(1831)")
.K FDA(1831)
.;
.;ADD DRG MULTIPLES - first code in Piece 3
.I $P(ICDNWCDA(ICDX1),U,3)]"" D
..S FDA(1831,80.1,"?1,",.01)="`"_ICDIP
..S FDA(1831,80.171,"?2,?1,",.01)=3071001
..S FDA(1831,80.1711,"?3,?2,?1,",.01)=$P(ICDNWCDA(ICDX1),U,2)
..S FDA(1831,80.17111,"+4,?3,?2,?1,",.01)=$P(ICDNWCDA(ICDX1),U,3)
..D UPDATE^DIE("","FDA(1831)")
.K FDA(1831)
.;
.;ADD DRG MULTIPLES - second code in piece 4
.I $P(ICDNWCDA(ICDX1),U,4)]"" D
..S FDA(1831,80.1,"?1,",.01)="`"_ICDIP
..S FDA(1831,80.171,"?2,?1,",.01)=3071001
..S FDA(1831,80.1711,"?3,?2,?1,",.01)=$P(ICDNWCDA(ICDX1),U,2)
..S FDA(1831,80.17111,"+5,?3,?2,?1,",.01)=$P(ICDNWCDA(ICDX1),U,4)
..D UPDATE^DIE("","FDA(1831)")
.K FDA(1831)
.;
.I $P(ICDNWCDA(ICDX1),U,5)]"" D
..S FDA(1831,80.1,"?1,",.01)="`"_ICDIP
..S FDA(1831,80.171,"?2,?1,",.01)=3071001
..S FDA(1831,80.1711,"?3,?2,?1,",.01)=$P(ICDNWCDA(ICDX1),U,2)
..S FDA(1831,80.17111,"+6,?3,?2,?1,",.01)=$P(ICDNWCDA(ICDX1),U,5)
..D UPDATE^DIE("","FDA(1831)")
.K FDA(1831)
.;
.I $P(ICDNWCDA(ICDX1),U,6)]"" D
..S FDA(1831,80.1,"?1,",.01)="`"_ICDIP
..S FDA(1831,80.171,"?2,?1,",.01)=3071001
..S FDA(1831,80.1711,"?3,?2,?1,",.01)=$P(ICDNWCDA(ICDX1),U,2)
..S FDA(1831,80.17111,"+7,?3,?2,?1,",.01)=$P(ICDNWCDA(ICDX1),U,6)
..D UPDATE^DIE("","FDA(1831)")
.K FDA(1831)
.;
.I $P(ICDNWCDA(ICDX1),U,7)]"" D
..S FDA(1831,80.1,"?1,",.01)="`"_ICDIP
..S FDA(1831,80.171,"?2,?1,",.01)=3071001
..S FDA(1831,80.1711,"?3,?2,?1,",.01)=$P(ICDNWCDA(ICDX1),U,2)
..S FDA(1831,80.17111,"+8,?3,?2,?1,",.01)=$P(ICDNWCDA(ICDX1),U,7)
..D UPDATE^DIE("","FDA(1831)")
.K FDA(1831)
.;
.I $P(ICDNWCDA(ICDX1),U,8)]"" D
..S FDA(1831,80.1,"?1,",.01)="`"_ICDIP
..S FDA(1831,80.171,"?2,?1,",.01)=3071001
..S FDA(1831,80.1711,"?3,?2,?1,",.01)=$P(ICDNWCDA(ICDX1),U,2)
..S FDA(1831,80.17111,"+9,?3,?2,?1,",.01)=$P(ICDNWCDA(ICDX1),U,8)
..D UPDATE^DIE("","FDA(1831)")
.K FDA(1831)
.;
.I $P(ICDNWCDA(ICDX1),U,9)]"" D
..S FDA(1831,80.1,"?1,",.01)="`"_ICDIP
..S FDA(1831,80.171,"?2,?1,",.01)=3071001
..S FDA(1831,80.1711,"?3,?2,?1,",.01)=$P(ICDNWCDA(ICDX1),U,2)
..S FDA(1831,80.17111,"+10,?3,?2,?1,",.01)=$P(ICDNWCDA(ICDX1),U,9)
..D UPDATE^DIE("","FDA(1831)")
.K FDA(1831)
.;
.I $P(ICDNWCDA(ICDX1),U,10)]"" D
..S FDA(1831,80.1,"?1,",.01)="`"_ICDIP
..S FDA(1831,80.171,"?2,?1,",.01)=3071001
..S FDA(1831,80.1711,"?3,?2,?1,",.01)=$P(ICDNWCDA(ICDX1),U,2)
..S FDA(1831,80.17111,"+11,?3,?2,?1,",.01)=$P(ICDNWCDA(ICDX1),U,10)
..D UPDATE^DIE("","FDA(1831)")
.K FDA(1831)
.;
.I $P(ICDNWCDA(ICDX1),U,11)]"" D
..S FDA(1831,80.1,"?1,",.01)="`"_ICDIP
..S FDA(1831,80.171,"?2,?1,",.01)=3071001
..S FDA(1831,80.1711,"?3,?2,?1,",.01)=$P(ICDNWCDA(ICDX1),U,2)
..S FDA(1831,80.17111,"+12,?3,?2,?1,",.01)=$P(ICDNWCDA(ICDX1),U,11)
..D UPDATE^DIE("","FDA(1831)")
.K FDA(1831)
.;
.I $P(ICDNWCDA(ICDX1),U,12)]"" D
..S FDA(1831,80.1,"?1,",.01)="`"_ICDIP
..S FDA(1831,80.171,"?2,?1,",.01)=3071001
..S FDA(1831,80.1711,"?3,?2,?1,",.01)=$P(ICDNWCDA(ICDX1),U,2)
..S FDA(1831,80.17111,"+13,?3,?2,?1,",.01)=$P(ICDNWCDA(ICDX1),U,12)
..D UPDATE^DIE("","FDA(1831)")
.K FDA(1831)
.;
.I $P(ICDNWCDA(ICDX1),U,13)]"" D
..S FDA(1831,80.1,"?1,",.01)="`"_ICDIP
..S FDA(1831,80.171,"?2,?1,",.01)=3071001
..S FDA(1831,80.1711,"?3,?2,?1,",.01)=$P(ICDNWCDA(ICDX1),U,2)
..S FDA(1831,80.17111,"+14,?3,?2,?1,",.01)=$P(ICDNWCDA(ICDX1),U,13)
..D UPDATE^DIE("","FDA(1831)")
.K FDA(1831)
.;
.I $D(^TMP("DIERR",$J)) S @ICDTMP@("ERROR",ICDIP,"80.1")="CAN'T FILE CODES FOR IEN"_$P(ICDNWCDA(ICDX1),U)_" CODES "_$P(ICDNWCDA(ICDX1),3,99)
.I $D(^TMP("DIERR",$J,ICDIP)) S ^TMP("ICDFILEOK",$J,ICDIP)=0
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HICD1831K 9716 printed Sep 23, 2025@19:24:29 Page 2
ICD1831K ; ALB/ECF - FY 2007 UPDATE; 10/23/07 2:50 pm;
+1 ;;18.0;DRG Grouper;**31**;Oct 13,2000;Build 7
+2 QUIT
+3 ;
DRG(ICDTMP) ;post-install driver for file ICD Operation/Procedure
+1 ; file(#80.1) DRG updates
+2 ;This procedure loops through the ICD OPERATION/PROCDURE file (80.1)
+3 ;to create a DRG GROUPER EFFECTIVE DATE entry for FY08
+4 ; Input:
+5 ; ICDTMP - Temp file of error msg's
+6 ; Output:
+7 ; ICDTMP - Temp file of error msg's
+8 ; ICDTOT - Total MS-DRG codes filed
+9 ; ICDERTOT - Total error records - cannot file
+10 ;
+11 NEW ICDI,ICDCRCD,ICDFOK,ICDNWCD,ICDTOT,ICDX,ICDY,ICDVAL,ICDETOT,ICDYY,ICDZZ
+12 SET U="^"
+13 ;
+14 DO BMES^XPDUTL(">>> Adding FY08 DRG Grouper updates to ICD OP/PR file (#80.1)...")
+15 ;Error log
+16 SET ICDTMP=$GET(ICDTMP)
+17 IF ICDTMP']""
SET ICDTMP=$NAME(^TMP("ICDDGFY2008OP",$JOB))
Begin DoDot:1
+18 KILL @ICDTMP
+19 SET @ICDTMP@(0)="PATCH #? FY08 ICD DIAG DRG UPDATE^"_$$NOW^XLFDT
End DoDot:1
+20 ;
+21 ;Skip inactive
+22 SET (ICDETOT,ICDI,ICDTOT,ICDYY)=0
+23 ;
+24 FOR
SET ICDI=$ORDER(^ICD0(ICDI))
if ICDI=""!(ICDI'?.N)
QUIT
Begin DoDot:1
+25 ;quit if no zero node
+26 if $GET(^ICD0(ICDI,0))=""
QUIT
+27 ;quit if zero node corrupt
+28 if $PIECE($GET(^ICD0(ICDI,0)),U)']""
QUIT
+29 SET ICDVAL=$PIECE($GET(^ICD0(ICDI,0)),U)
+30 if ICDVAL=""
QUIT
+31 ;quit if code is inactive
+32 SET ICDZZ=$$ICDOP^ICDCODE(ICDVAL,3071001)
if $PIECE($GET(ICDZZ),U,10)=0
QUIT
+33 ;check if already created in case patch being re-installed
+34 if $DATA(^ICD0(ICDI,2,"B",3071001))
QUIT
+35 ;
+36 ;Get ien of latest Grouper Effective Date
+37 SET ICDX=$ORDER(^ICD0(ICDI,2,"B",9999999),-1)
+38 ;No Grp Eff Dt means this is a new code
+39 IF ICDX']""
Begin DoDot:2
+40 ;Call API
+41 KILL ICDNCDAR
+42 DO NEW801^ICD1831L(ICDVAL,.ICDNCDAR)
+43 if '$DATA(ICDNCDAR)
QUIT
+44 ;Build code array for UPDDIAG()
+45 KILL ICDCONAR
+46 DO GETNCRCD(ICDI,.ICDNCDAR,.ICDCONAR)
+47 if '$DATA(ICDCONAR(0))
QUIT
+48 DO UPDDIAG(ICDI,.ICDCONAR,.ICDTOT)
End DoDot:2
+49 ;
+50 IF ICDX]""
Begin DoDot:2
+51 ;Old codes to convert
+52 ;Call will be $$CONV801^ICD1831L(<ien of code>)for each MDC/DRG set
+53 SET ICDLEDI=$ORDER(^ICD0(ICDI,2,"B",ICDX,0))
+54 SET (ICDFYMI,ICDY)=0
+55 ;Loop through MDCs for this ICD PROC - DRG EFF DATE
+56 FOR
SET ICDFYMI=$ORDER(^ICD0(ICDI,2,ICDLEDI,1,ICDFYMI))
if ICDFYMI=""!(ICDFYMI'?.N)
QUIT
Begin DoDot:3
+57 KILL ICDNWCD,ICDNWCDA
+58 ;Build code string for conversion API
SET ICDDGCD=$$GETCRCD(ICDI,ICDLEDI,ICDFYMI)
+59 ;If no code string for this MDC, nothing to convert
+60 if ICDDGCD']""
QUIT
+61 ;Code string is ok, pass to conversion function
+62 SET ICDNWCD=$$CONV801^ICD1831L(ICDDGCD)
+63 ;Return codes are in string ICDCRCD <.01>^<MDC ien>^<DRG ien)^<DRG ien>.........
+64 ;Filer requires an array - at least a zero node is needed
+65 IF ICDNWCD]""
KILL ICDNWCDA
SET ICDNWCDA(0)=ICDNWCD
+66 ;Now process the array of code strings for this ICD Proc IEN
+67 if ICDNWCDA(0)']""
QUIT
+68 ;pass new codes to update procedure
+69 ;D UPDDIAG(ICDI,"X",.ICDNWCDA,.ICDTOT)
+70 DO UPDDIAG(ICDI,.ICDNWCDA,.ICDTOT)
+71 KILL ICDNWCDA
End DoDot:3
End DoDot:2
+72 End DoDot:1
+73 ;Back to top level - processing is over - do final tasks
+74 KILL ICDCONAR,ICDDGCD,ICDETOT,ICDFYMI,ICDNCDAR,ICDNWCDA
+75 ;HANDLE ERRORS
+76 ;No errors present
+77 ;
+78 SET (ICDTOT,ICDYY)=0
+79 FOR
SET ICDYY=$ORDER(^TMP("ICDFILEOK",$JOB,ICDYY))
if ICDYY=""
QUIT
IF ^TMP("ICDFILEOK",$JOB,ICDYY)=1
SET ICDTOT=ICDTOT+1
+80 IF '$DATA(@ICDTMP@("ERROR"))
Begin DoDot:1
+81 DO MES^XPDUTL(">>> ICD PROCEDURE File DRG Updates Completed...")
+82 DO MES^XPDUTL(" ...Total Codes Edited: "_ICDTOT)
+83 DO MES^XPDUTL("")
End DoDot:1
+84 QUIT
+85 ;Errors present
+86 ;
+87 IF $DATA(@ICDTMP@("ERROR"))
Begin DoDot:1
+88 FOR
SET ICDXX=$ORDER(^TMP("ICDDGFY2008OP",$JOB,"ERROR",ICDXX))
if ICDXX=""
QUIT
Begin DoDot:2
+89 SET ICDETOT=ICDETOT+1
End DoDot:2
+90 DO MES^XPDUTL(">>> ...Total Errors "_ICDETOT_" ERRORS")
+91 DO MES^XPDUTL("")
+92 DO MES^XPDUTL("Error are in ^TMP(""ICDDGFY2008OP"",$J)")
End DoDot:1
+93 ;
+94 KILL ICDCRCD,ICDVAL,ICDZZ
+95 KILL ^TMP("ICDFILEOK")
+96 QUIT
+97 ;
+98 ;END OF DRIVER
+99 ;Start of helper functions and procedures
+100 ;
GETCRCD(ICDIEN,ICDDGIEN,ICDMDIEN) ;
+1 ;Create input string for conversion API - only for non-New DRGs
+2 ;
+3 ;INPUT ICDIEN = ien in file 80.1 ICD OPERATION/PROCEDURE
+4 ; ICDDGIEN = ien of last DRG GROUPER EFFECTIVE DATE
+5 ; ICDMDIEN = ien of Major Diagnostic Category
+6 ;OUTPUT ICDCRDCS = string of codes formatted for API
+7 ;
+8 NEW ICDCRCDS,ICDXS
+9 ;
+10 SET (ICDCRCD)=""
+11 SET (ICDX)=0
+12 ;
+13 ;START STRING WITH THE .01 FIELD
+14 SET ICDCRCDS=$PIECE(^ICD0(ICDI,0),U)
+15 ;
+16 ;Add MDC ien to string
+17 SET ICDCRCDS=ICDCRCDS_"^"_$PIECE($GET(^ICD0(ICDIEN,2,ICDDGIEN,1,ICDMDIEN,0)),U)
+18 ;
+19 ;Loop thru DRGs this ICD procedure, this eff date, this MDC
+20 ;
+21 FOR
SET ICDX=$ORDER(^ICD0(ICDIEN,2,ICDDGIEN,1,ICDMDIEN,1,ICDX))
if ICDX=""!(ICDX'?.N)
QUIT
Begin DoDot:1
+22 if $GET(^ICD0(ICDIEN,2,ICDDGIEN,1,ICDMDIEN,1,ICDX,0))=""
QUIT
+23 SET ICDCRCDS=ICDCRCDS_"^"_$PIECE($GET(^ICD0(ICDIEN,2,ICDDGIEN,1,ICDMDIEN,1,ICDX,0)),U)
End DoDot:1
+24 QUIT ICDCRCDS
+25 ;
GETNCRCD(ICDIENP,ICDOAR,ICDCAR) ;
+1 ;Quit if input not correct, passing back a null zero node
+2 IF '$DATA(ICDIENP)
SET ICDCAR(0)=""
QUIT
+3 ;
+4 NEW ICDK,ICDJ,ICDL
+5 SET (ICDJ,ICDK,ICDL)=0
+6 FOR
SET ICDJ=$ORDER(ICDOAR(ICDJ))
if ICDJ=""
QUIT
Begin DoDot:1
+7 SET ICDCAR(ICDL)=ICDIENP_"^"_ICDJ_"^"
+8 FOR
SET ICDK=$ORDER(ICDOAR(ICDJ,ICDK))
if ICDK=""
QUIT
Begin DoDot:2
+9 SET ICDCAR(ICDL)=ICDCAR(ICDL)_ICDK_"^"
End DoDot:2
+10 SET ICDL=ICDL+1
End DoDot:1
+11 QUIT
+12 ;
+13 ;
UPDDIAG(ICDIP,ICDNWCDA,ICDTOTP) ;
+1 ;File 80.1 updater
+2 ;
+3 NEW ICDX1
+4 ; F ICDZ=1:1:3 I $P(ICDIAGP,U,ICDZ)']"" D Q
+5 ; .S @ICDTMP@("ERROR",ICDIP,"80.1")="Missing field "_ICDZ_" filing "_ICDIAGP
+6 ;
+7 ;Quit if complete data not passed
+8 if '$DATA(ICDIP)
QUIT
+9 if '$DATA(ICDNWCDA(0))
QUIT
+10 if $PIECE($GET(ICDNWCDA(0)),U,1)']""
QUIT
+11 if $PIECE($GET(ICDNWCDA(0)),U,2)']""
QUIT
+12 if $PIECE($GET(ICDNWCDA(0)),U,3)']""
QUIT
+13 ;
+14 SET ^TMP("ICDFILEOK",$JOB,ICDIP)=1
+15 ;
+16 KILL FDA(1831)
+17 ;
+18 ;Passed in array will trigger DRG Effective Date Multiple ONLY IF NEEDED
+19 ;
+20 IF '$DATA(^ICD0(ICDIP,2,"B",3071001))
Begin DoDot:1
+21 ;DRG GROUPER EFFECTIVE DATE MULTIPLE
+22 SET FDA(1831,80.1,"?1,",.01)="`"_ICDIP
+23 SET FDA(1831,80.171,"+2,?1,",.01)=3071001
+24 DO UPDATE^DIE("","FDA(1831)")
+25 KILL FDA(1831)
End DoDot:1
+26 ;
+27 SET ICDX1=""
+28 ;
+29 FOR
SET ICDX1=$ORDER(ICDNWCDA(ICDX1))
if ICDX1=""
QUIT
Begin DoDot:1
+30 ;ADD MDC MULTIPLE only if there are DRG codes for the MDC
+31 IF $PIECE(ICDNWCDA(ICDX1),U,2)]""
Begin DoDot:2
+32 if $PIECE(ICDNWCDA(ICDX1),U,3)']""
QUIT
+33 SET FDA(1831,80.1,"?1,",.01)="`"_ICDIP
+34 SET FDA(1831,80.171,"?2,?1,",.01)=3071001
+35 SET FDA(1831,80.1711,"+3,?2,?1,",.01)=$PIECE(ICDNWCDA(ICDX1),U,2)
+36 DO UPDATE^DIE("","FDA(1831)")
End DoDot:2
KILL FDA
+37 KILL FDA(1831)
+38 ;
+39 ;ADD DRG MULTIPLES - first code in Piece 3
+40 IF $PIECE(ICDNWCDA(ICDX1),U,3)]""
Begin DoDot:2
+41 SET FDA(1831,80.1,"?1,",.01)="`"_ICDIP
+42 SET FDA(1831,80.171,"?2,?1,",.01)=3071001
+43 SET FDA(1831,80.1711,"?3,?2,?1,",.01)=$PIECE(ICDNWCDA(ICDX1),U,2)
+44 SET FDA(1831,80.17111,"+4,?3,?2,?1,",.01)=$PIECE(ICDNWCDA(ICDX1),U,3)
+45 DO UPDATE^DIE("","FDA(1831)")
End DoDot:2
+46 KILL FDA(1831)
+47 ;
+48 ;ADD DRG MULTIPLES - second code in piece 4
+49 IF $PIECE(ICDNWCDA(ICDX1),U,4)]""
Begin DoDot:2
+50 SET FDA(1831,80.1,"?1,",.01)="`"_ICDIP
+51 SET FDA(1831,80.171,"?2,?1,",.01)=3071001
+52 SET FDA(1831,80.1711,"?3,?2,?1,",.01)=$PIECE(ICDNWCDA(ICDX1),U,2)
+53 SET FDA(1831,80.17111,"+5,?3,?2,?1,",.01)=$PIECE(ICDNWCDA(ICDX1),U,4)
+54 DO UPDATE^DIE("","FDA(1831)")
End DoDot:2
+55 KILL FDA(1831)
+56 ;
+57 IF $PIECE(ICDNWCDA(ICDX1),U,5)]""
Begin DoDot:2
+58 SET FDA(1831,80.1,"?1,",.01)="`"_ICDIP
+59 SET FDA(1831,80.171,"?2,?1,",.01)=3071001
+60 SET FDA(1831,80.1711,"?3,?2,?1,",.01)=$PIECE(ICDNWCDA(ICDX1),U,2)
+61 SET FDA(1831,80.17111,"+6,?3,?2,?1,",.01)=$PIECE(ICDNWCDA(ICDX1),U,5)
+62 DO UPDATE^DIE("","FDA(1831)")
End DoDot:2
+63 KILL FDA(1831)
+64 ;
+65 IF $PIECE(ICDNWCDA(ICDX1),U,6)]""
Begin DoDot:2
+66 SET FDA(1831,80.1,"?1,",.01)="`"_ICDIP
+67 SET FDA(1831,80.171,"?2,?1,",.01)=3071001
+68 SET FDA(1831,80.1711,"?3,?2,?1,",.01)=$PIECE(ICDNWCDA(ICDX1),U,2)
+69 SET FDA(1831,80.17111,"+7,?3,?2,?1,",.01)=$PIECE(ICDNWCDA(ICDX1),U,6)
+70 DO UPDATE^DIE("","FDA(1831)")
End DoDot:2
+71 KILL FDA(1831)
+72 ;
+73 IF $PIECE(ICDNWCDA(ICDX1),U,7)]""
Begin DoDot:2
+74 SET FDA(1831,80.1,"?1,",.01)="`"_ICDIP
+75 SET FDA(1831,80.171,"?2,?1,",.01)=3071001
+76 SET FDA(1831,80.1711,"?3,?2,?1,",.01)=$PIECE(ICDNWCDA(ICDX1),U,2)
+77 SET FDA(1831,80.17111,"+8,?3,?2,?1,",.01)=$PIECE(ICDNWCDA(ICDX1),U,7)
+78 DO UPDATE^DIE("","FDA(1831)")
End DoDot:2
+79 KILL FDA(1831)
+80 ;
+81 IF $PIECE(ICDNWCDA(ICDX1),U,8)]""
Begin DoDot:2
+82 SET FDA(1831,80.1,"?1,",.01)="`"_ICDIP
+83 SET FDA(1831,80.171,"?2,?1,",.01)=3071001
+84 SET FDA(1831,80.1711,"?3,?2,?1,",.01)=$PIECE(ICDNWCDA(ICDX1),U,2)
+85 SET FDA(1831,80.17111,"+9,?3,?2,?1,",.01)=$PIECE(ICDNWCDA(ICDX1),U,8)
+86 DO UPDATE^DIE("","FDA(1831)")
End DoDot:2
+87 KILL FDA(1831)
+88 ;
+89 IF $PIECE(ICDNWCDA(ICDX1),U,9)]""
Begin DoDot:2
+90 SET FDA(1831,80.1,"?1,",.01)="`"_ICDIP
+91 SET FDA(1831,80.171,"?2,?1,",.01)=3071001
+92 SET FDA(1831,80.1711,"?3,?2,?1,",.01)=$PIECE(ICDNWCDA(ICDX1),U,2)
+93 SET FDA(1831,80.17111,"+10,?3,?2,?1,",.01)=$PIECE(ICDNWCDA(ICDX1),U,9)
+94 DO UPDATE^DIE("","FDA(1831)")
End DoDot:2
+95 KILL FDA(1831)
+96 ;
+97 IF $PIECE(ICDNWCDA(ICDX1),U,10)]""
Begin DoDot:2
+98 SET FDA(1831,80.1,"?1,",.01)="`"_ICDIP
+99 SET FDA(1831,80.171,"?2,?1,",.01)=3071001
+100 SET FDA(1831,80.1711,"?3,?2,?1,",.01)=$PIECE(ICDNWCDA(ICDX1),U,2)
+101 SET FDA(1831,80.17111,"+11,?3,?2,?1,",.01)=$PIECE(ICDNWCDA(ICDX1),U,10)
+102 DO UPDATE^DIE("","FDA(1831)")
End DoDot:2
+103 KILL FDA(1831)
+104 ;
+105 IF $PIECE(ICDNWCDA(ICDX1),U,11)]""
Begin DoDot:2
+106 SET FDA(1831,80.1,"?1,",.01)="`"_ICDIP
+107 SET FDA(1831,80.171,"?2,?1,",.01)=3071001
+108 SET FDA(1831,80.1711,"?3,?2,?1,",.01)=$PIECE(ICDNWCDA(ICDX1),U,2)
+109 SET FDA(1831,80.17111,"+12,?3,?2,?1,",.01)=$PIECE(ICDNWCDA(ICDX1),U,11)
+110 DO UPDATE^DIE("","FDA(1831)")
End DoDot:2
+111 KILL FDA(1831)
+112 ;
+113 IF $PIECE(ICDNWCDA(ICDX1),U,12)]""
Begin DoDot:2
+114 SET FDA(1831,80.1,"?1,",.01)="`"_ICDIP
+115 SET FDA(1831,80.171,"?2,?1,",.01)=3071001
+116 SET FDA(1831,80.1711,"?3,?2,?1,",.01)=$PIECE(ICDNWCDA(ICDX1),U,2)
+117 SET FDA(1831,80.17111,"+13,?3,?2,?1,",.01)=$PIECE(ICDNWCDA(ICDX1),U,12)
+118 DO UPDATE^DIE("","FDA(1831)")
End DoDot:2
+119 KILL FDA(1831)
+120 ;
+121 IF $PIECE(ICDNWCDA(ICDX1),U,13)]""
Begin DoDot:2
+122 SET FDA(1831,80.1,"?1,",.01)="`"_ICDIP
+123 SET FDA(1831,80.171,"?2,?1,",.01)=3071001
+124 SET FDA(1831,80.1711,"?3,?2,?1,",.01)=$PIECE(ICDNWCDA(ICDX1),U,2)
+125 SET FDA(1831,80.17111,"+14,?3,?2,?1,",.01)=$PIECE(ICDNWCDA(ICDX1),U,13)
+126 DO UPDATE^DIE("","FDA(1831)")
End DoDot:2
+127 KILL FDA(1831)
+128 ;
+129 IF $DATA(^TMP("DIERR",$JOB))
SET @ICDTMP@("ERROR",ICDIP,"80.1")="CAN'T FILE CODES FOR IEN"_$PIECE(ICDNWCDA(ICDX1),U)_" CODES "_$PIECE(ICDNWCDA(ICDX1),3,99)
+130 IF $DATA(^TMP("DIERR",$JOB,ICDIP))
SET ^TMP("ICDFILEOK",$JOB,ICDIP)=0
End DoDot:1
+131 QUIT
