- ICDDRG ;ALB/GRR/EG/ADL - Assigns DRG Codes ;04/21/2014
- ;;18.0;DRG Grouper;**2,7,10,14,20,31,37,57**;Oct 20, 2000;Build 7
- ;
- ; ADL - Updated for Code Set Versioning 03/10/2003
- ; KER - Updated for ICD-10 06/30/2012
- ;
- ; Global Variables
- ; None
- ;
- ; External References
- ; ^ICDDRG0 ICR N/A
- ; EN1^ICDDRG5 ICR N/A
- ; EN1^ICDDRG8 ICR N/A
- ; $$GETDRG^ICDEX ICR N/A
- ; $$ICDDX^ICDEX ICR N/A
- ; $$ICDOP^ICDEX ICR N/A
- ; $$ISA^ICDEX ICR N/A
- ; $$MDCD^ICDEX ICR N/A
- ; $$MDCT^ICDEX ICR N/A
- ; $$MOR^ICDEX ICR N/A
- ; MDCG^ICDEX ICR N/A
- ;
- ; Local Variables NEWed or KILLed in ICDDRGM
- ; ICDDATE,ICDDMS,ICDDRG,ICDDX,ICDEXP,ICDMDC,ICDPRC,ICDRTC
- ; ICDS24,ICDTMP,ICDTRS,SEX
- ;
- TOP ; Main Entry Point
- K ICDDRG,ICDMDC,ICDRTC S (ICDDRG,ICDMDC,ICDRTC)=""
- ; Check for Invalid Input Variables
- I +($G(ICDDX(1)))'>0 S ICDRTC=1 G ERR
- ; Patient Expired?
- I ICDEXP'=0&(ICDEXP'=1)&(ICDEXP'="") S ICDRTC=5 G ERR
- ; Patient Transferred
- I ICDTRS'=0&(ICDTRS'=1)&(ICDTRS'="") S ICDRTC=6 G ERR
- ; Patient Discharged against Medical Advice
- I ICDDMS'=0&(ICDDMS'=1)&(ICDDMS'="") S ICDRTC=7 G ERR
- ; Patient Sex
- I SEX'="M"&(SEX'="F")&(SEX'="") S ICDRTC=4 G ERR
- ; Default is today's FileMan date
- I '$D(ICDDATE) S ICDDATE=DT
- ;
- PRI ; Primary Diagnosis Related Variables
- D KILL S ICDSEX($S(SEX="M":1,SEX="F":2,1:0))=""
- S ICDTMP=$$ICDDX^ICDEX(+($G(ICDDX(1))),ICDDATE,,"I")
- ; Error if not found
- I ICDTMP<0 S ICDRTC=1 G ERR
- S ICDY(0)=$P(ICDTMP,U,2,99)
- ; Error if unacceptable or inactive
- I $P(ICDY(0),"^",4)=1!($P(ICDY(0),"^",9)=0) S ICDRTC=1 G ERR
- S ICDMDC=$P(ICDY(0),"^",5),ICDPD=$P(ICDY(0),"^",2),ICDRG=0
- I $T(+2)[",57**",$$CSI^ICDEX(80,+($G(ICDDX(1))))=1 S ICDPD=$TR(ICDPD,";")
- ; Error if no MDC
- I 'ICDMDC S ICDRTC=1 G ERR
- D MDCG^ICDEX(+($G(ICDDX(1))),ICDDATE,.ICDMDC)
- S:$O(ICDMDC(0))>0 ICDMDC=$P(ICDY(0),"^",5)
- I $D(ICDMDC(12))!($D(ICDMDC(13))) S ICDMDC=$S(SEX="F":13,1:12) I SEX="" S ICDRTC=4 G ERR
- S ICDTMP=$$GETDRG^ICDEX(80,+($G(ICDDX(1))),ICDDATE) I ICDTMP>0 S ICDPDRG=$P(ICDTMP,";") D
- . F ICDI=1:1 Q:$P(ICDPDRG,"^",ICDI)']"" S ICDPDRG($P(ICDPDRG,"^",ICDI))="",ICDRG($P(ICDPDRG,"^",ICDI))=""
- S ICD104=0,ICDP24=$P(ICDY(0),"^",12),ICDP25=$P(ICDY(0),"^",13) D SEX
- ; The following establishes Secondary Diagnosis Variables
- S (ICDCCT,ICDMCCT,ICDSD)="",ICDCC=0,ICDMCC=0,ICDI=1
- F ICDIZ=0:0 S ICDI=$O(ICDDX(ICDI)) Q:ICDI'>0 D G:ICDRTC]"" ERR
- . S ICDTMP=$$ICDDX^ICDEX(+($G(ICDDX(ICDI))),ICDDATE,,"I")
- . I ICDTMP<0!'($P(ICDTMP,U,10)) S ICDRTC=8 Q
- . S ICDY(0)=$P(ICDTMP,U,2,99),ICDDXT($P(ICDY(0),"^",1))=""
- . S ICDP15($S($P(ICDY(0),"^",2)["J":1,1:0))=""
- . D SEC,SEX G:ICDRTC]"" ERR
- S:$D(ICDCCT(1)) ICDCC=1 K ICDCCT
- S:$D(ICDMCCT(1)) ICDMCC=1 S:$D(ICDMCCT(2)) ICDMCC=2 K ICDMCCT
- ; The following establishes Operation/Prodedure Variables
- N ICDOTMP S (ICDMAJ,ICDORNI,ICDOP,ICDOR,ICDOTMP)="",(ICDOCNT,ICDONR,ICDORNR,ICDNOR,ICDOPCT,ICDOPNR)=0
- ; Return ICD Operation/Procedure code info check if active
- I $D(ICDPRC) F ICDI=1:1 Q:'$D(ICDPRC(ICDI)) X "S ICDTMP=$$ICDOP^ICDEX(+($G(ICDPRC(ICDI))),ICDDATE,,""I"") I ICDTMP<0!'($P(ICDTMP,U,10)) S ICDRTC=2 Q" I ICDRTC="" D
- . S ICDY(0)=$P(ICDTMP,U,2,99),ICDNOR=ICDNOR+1,ICDY=+($G(ICDPRC(ICDI))),ICDO24($S($P(ICDY(0),"^",3)'="":$P(ICDY(0),"^",3),1:"N"))="" D OPS,SEX
- K ICDO24("N") G:ICDRTC]"" ERR
- G ^ICDDRG0
- ;
- SEC ; Secondary Diagnosis
- ; Is Secondary NCC for Primary
- I ICDDATE>3070930.9 D
- . S ICDMCC=$S(+($$ISA^ICDEX(+($G(ICDDX(ICDI))),+($G(ICDDX(1))),1.11))>0:0,$P(ICDY(0),"^",18)=2:2,($P(ICDY(0),"^",18)=1)&(ICDMCC'=2):1,1:ICDMCC),ICDMCCT(ICDMCC)=""
- E D
- . S ICDCC=$S(+($$ISA^ICDEX(+($G(ICDDX(ICDI))),+($G(ICDDX(1))),1.11))>0:0,$P(ICDY(0),"^",7)=1:1,1:ICDCC),ICDCCT(ICDCC)=""
- ; Group ICD identifiers in one variable
- I $L($P(ICDY(0),"^",2)) S ICDSD=$$TM(ICDSD,";")_";"_$$TM($P(ICDY(0),"^",2),";"),ICDSD=";"_$$TM(ICDSD,";")_";"
- S ICDTMP=$$GETDRG^ICDEX(80,+($G(ICDDX(ICDI))),ICDDATE)
- ; If any of the following conditions are met set ICDSDRG array
- I (($P(ICDY(0),"^",7)=1)!(ICDPD["h")!(ICDPD["J")!(ICDSD["h")),'$P(ICDTMP,";",3) D
- . S ICDSDRG=$P(ICDTMP,";") F ICDK=1:1 Q:$P(ICDSDRG,"^",ICDK)']"" S ICDSDRG($P(ICDSDRG,"^",ICDK))=""
- S ICDS24($S($P(ICDY(0),"^",12)'="":$P(ICDY(0),"^",12),1:"N"))="",ICDS25($S($P(ICDY(0),"^",13)'="":$P(ICDY(0),"^",13),1:0))=""
- K ICDS24("N"),ICDS25(0) Q
- ;
- OPS ; Operation/Procedures
- I '$D(ICDOP(" "_$P(ICDY(0),"^",1))) S ICDOP(" "_$P(ICDY(0),"^",1))="",ICDOCNT=ICDOCNT+1
- I $S($D(ICDMDC(12))!($D(ICDMDC(13)))>0:'$$MDCT^ICDEX(ICDY,ICDDATE,.ICDMDC,0),1:'$$MDCD^ICDEX(ICDY,ICDMDC,ICDDATE)) D
- . S ICDONR=ICDONR+1,ICDORNI=ICDORNI_$P(ICDY(0),"^",2),ICDORNI($S($P(ICDY(0),"^",2)'="":$P(ICDY(0),"^",2),1:0))="" S:ICDORNR'=0 ICDORNR=1
- I $L($P(ICDY(0),"^",2)) S ICDOR=$$TM(ICDOR,";")_";"_$$TM($P(ICDY(0),"^",2),";"),ICDOR=";"_$$TM(ICDOR,";")_";"
- I +ICDY(0)>37.69,+ICDY(0)<37.84,ICDOR'["p" D
- . N ICDCC3 D EN1^ICDDRG5 I ICDCC3 S ICDOR=ICDOR_"p" S:ICDOR'["O" ICDOR=ICDOR_"O"
- I +ICDY(0)>80.999 I +ICDY(0)<81.40 N ICDCC3 D EN1^ICDDRG8 I ICDCC3 S ICDOR=ICDOR_"F"
- ; Major OR Procedure
- S:$L($$MOR^ICDEX(ICDY)) ICDMAJ=ICDMAJ_$P($$MOR^ICDEX(ICDY),"^")_"^"
- ; Set ICDOTMP with DRGs for doing checks
- S ICDOTMP=$P($$GETDRG^ICDEX(80.1,ICDY,ICDDATE,$G(ICDMDC)),";",1) S:+ICDOTMP'>0 ICDOTMP=""
- I $P(ICDY(0),"^",2)["O" D
- .S ICDOPCT=ICDOPCT+1
- .I ICDOPNR=0 D
- ..I $S($D(ICDMDC(12))!($D(ICDMDC(13)))>0:'$$MDCT^ICDEX(ICDY,ICDDATE,.ICDMDC,0),1:'$D(ICDOTMP)) S ICDOPNR=1
- I +ICDOTMP>0 S ICDF=ICDOTMP F ICDFX=1:1 Q:$P(ICDF,"^",ICDFX)']"" S ICDODRG($P(ICDF,"^",ICDFX))=$P(ICDF,"^",ICDFX)
- ; Translate identifiers into common symbol, check for symbol
- S ICD104=$S($P(ICDY(0),"^",2)["P":1,1:0),ICDNMDC($S($TR($P(ICDY(0),"^",2),"lqtrB","\\\\")["\":1,1:0))="" Q
- ;
- ; Miscellaneous
- ERR ; Error Occured
- S ICDDRG=$S(ICDDATE>3070930.9:999,1:470)
- Q
- SEX ; Get sex for DX or Procedure
- S ICDSEX($S($P(ICDY(0),"^",10)="M":1,$P(ICDY(0),"^",10)="F":2,1:0))=""
- Q
- TM(X,Y) ; Trim Y
- S Y=$G(Y) S:'$L(Y) Y=" "
- F Q:$E(X,1)'=Y S X=$E(X,2,$L(X))
- F Q:$E(X,$L(X))'=Y S X=$E(X,1,($L(X)-1))
- Q X
- KILL ; Clean Environment
- K ICD104,ICDJ,ICDJJ,ICDOCNT,ICDOR,ICDNOR,ICDP15,ICDPDRG,ICDRG,ICDSEX
- K ICDSDRG,ICDODRG,ICDCC,ICDMCC,ICDOP,ICDORNR,ICDORNI,ICDP24,ICDP25,ICDPD
- K ICDSD,ICDI,ICDK,ICDF,ICDFX,ICDFK,ICDY,ICDDXT,ICDIZ,ICDONR,ICDOPCT
- K ICD,ICDCC2,ICDCC3,ICDGH,ICDL39,ICDMAJ,ICDNMDC,ICDNSD,ICDORNA,ICDREF
- K ICDS24,ICDS25,ICDOPNR,ICDO24,ICDO25
- Q
- ICDDRG ;ALB/GRR/EG/ADL - Assigns DRG Codes ;04/21/2014
- +1 ;;18.0;DRG Grouper;**2,7,10,14,20,31,37,57**;Oct 20, 2000;Build 7
- +2 ;
- +3 ; ADL - Updated for Code Set Versioning 03/10/2003
- +4 ; KER - Updated for ICD-10 06/30/2012
- +5 ;
- +6 ; Global Variables
- +7 ; None
- +8 ;
- +9 ; External References
- +10 ; ^ICDDRG0 ICR N/A
- +11 ; EN1^ICDDRG5 ICR N/A
- +12 ; EN1^ICDDRG8 ICR N/A
- +13 ; $$GETDRG^ICDEX ICR N/A
- +14 ; $$ICDDX^ICDEX ICR N/A
- +15 ; $$ICDOP^ICDEX ICR N/A
- +16 ; $$ISA^ICDEX ICR N/A
- +17 ; $$MDCD^ICDEX ICR N/A
- +18 ; $$MDCT^ICDEX ICR N/A
- +19 ; $$MOR^ICDEX ICR N/A
- +20 ; MDCG^ICDEX ICR N/A
- +21 ;
- +22 ; Local Variables NEWed or KILLed in ICDDRGM
- +23 ; ICDDATE,ICDDMS,ICDDRG,ICDDX,ICDEXP,ICDMDC,ICDPRC,ICDRTC
- +24 ; ICDS24,ICDTMP,ICDTRS,SEX
- +25 ;
- TOP ; Main Entry Point
- +1 KILL ICDDRG,ICDMDC,ICDRTC
- SET (ICDDRG,ICDMDC,ICDRTC)=""
- +2 ; Check for Invalid Input Variables
- +3 IF +($GET(ICDDX(1)))'>0
- SET ICDRTC=1
- GOTO ERR
- +4 ; Patient Expired?
- +5 IF ICDEXP'=0&(ICDEXP'=1)&(ICDEXP'="")
- SET ICDRTC=5
- GOTO ERR
- +6 ; Patient Transferred
- +7 IF ICDTRS'=0&(ICDTRS'=1)&(ICDTRS'="")
- SET ICDRTC=6
- GOTO ERR
- +8 ; Patient Discharged against Medical Advice
- +9 IF ICDDMS'=0&(ICDDMS'=1)&(ICDDMS'="")
- SET ICDRTC=7
- GOTO ERR
- +10 ; Patient Sex
- +11 IF SEX'="M"&(SEX'="F")&(SEX'="")
- SET ICDRTC=4
- GOTO ERR
- +12 ; Default is today's FileMan date
- +13 IF '$DATA(ICDDATE)
- SET ICDDATE=DT
- +14 ;
- PRI ; Primary Diagnosis Related Variables
- +1 DO KILL
- SET ICDSEX($SELECT(SEX="M":1,SEX="F":2,1:0))=""
- +2 SET ICDTMP=$$ICDDX^ICDEX(+($GET(ICDDX(1))),ICDDATE,,"I")
- +3 ; Error if not found
- +4 IF ICDTMP<0
- SET ICDRTC=1
- GOTO ERR
- +5 SET ICDY(0)=$PIECE(ICDTMP,U,2,99)
- +6 ; Error if unacceptable or inactive
- +7 IF $PIECE(ICDY(0),"^",4)=1!($PIECE(ICDY(0),"^",9)=0)
- SET ICDRTC=1
- GOTO ERR
- +8 SET ICDMDC=$PIECE(ICDY(0),"^",5)
- SET ICDPD=$PIECE(ICDY(0),"^",2)
- SET ICDRG=0
- +9 IF $TEXT(+2)[",57**"
- IF $$CSI^ICDEX(80,+($GET(ICDDX(1))))=1
- SET ICDPD=$TRANSLATE(ICDPD,";")
- +10 ; Error if no MDC
- +11 IF 'ICDMDC
- SET ICDRTC=1
- GOTO ERR
- +12 DO MDCG^ICDEX(+($GET(ICDDX(1))),ICDDATE,.ICDMDC)
- +13 IF $ORDER(ICDMDC(0))>0
- SET ICDMDC=$PIECE(ICDY(0),"^",5)
- +14 IF $DATA(ICDMDC(12))!($DATA(ICDMDC(13)))
- SET ICDMDC=$SELECT(SEX="F":13,1:12)
- IF SEX=""
- SET ICDRTC=4
- GOTO ERR
- +15 SET ICDTMP=$$GETDRG^ICDEX(80,+($GET(ICDDX(1))),ICDDATE)
- IF ICDTMP>0
- SET ICDPDRG=$PIECE(ICDTMP,";")
- Begin DoDot:1
- +16 FOR ICDI=1:1
- IF $PIECE(ICDPDRG,"^",ICDI)']""
- QUIT
- SET ICDPDRG($PIECE(ICDPDRG,"^",ICDI))=""
- SET ICDRG($PIECE(ICDPDRG,"^",ICDI))=""
- End DoDot:1
- +17 SET ICD104=0
- SET ICDP24=$PIECE(ICDY(0),"^",12)
- SET ICDP25=$PIECE(ICDY(0),"^",13)
- DO SEX
- +18 ; The following establishes Secondary Diagnosis Variables
- +19 SET (ICDCCT,ICDMCCT,ICDSD)=""
- SET ICDCC=0
- SET ICDMCC=0
- SET ICDI=1
- +20 FOR ICDIZ=0:0
- SET ICDI=$ORDER(ICDDX(ICDI))
- IF ICDI'>0
- QUIT
- Begin DoDot:1
- +21 SET ICDTMP=$$ICDDX^ICDEX(+($GET(ICDDX(ICDI))),ICDDATE,,"I")
- +22 IF ICDTMP<0!'($PIECE(ICDTMP,U,10))
- SET ICDRTC=8
- QUIT
- +23 SET ICDY(0)=$PIECE(ICDTMP,U,2,99)
- SET ICDDXT($PIECE(ICDY(0),"^",1))=""
- +24 SET ICDP15($SELECT($PIECE(ICDY(0),"^",2)["J":1,1:0))=""
- +25 DO SEC
- DO SEX
- IF ICDRTC]""
- GOTO ERR
- End DoDot:1
- IF ICDRTC]""
- GOTO ERR
- +26 IF $DATA(ICDCCT(1))
- SET ICDCC=1
- KILL ICDCCT
- +27 IF $DATA(ICDMCCT(1))
- SET ICDMCC=1
- IF $DATA(ICDMCCT(2))
- SET ICDMCC=2
- KILL ICDMCCT
- +28 ; The following establishes Operation/Prodedure Variables
- +29 NEW ICDOTMP
- SET (ICDMAJ,ICDORNI,ICDOP,ICDOR,ICDOTMP)=""
- SET (ICDOCNT,ICDONR,ICDORNR,ICDNOR,ICDOPCT,ICDOPNR)=0
- +30 ; Return ICD Operation/Procedure code info check if active
- +31 IF $DATA(ICDPRC)
- FOR ICDI=1:1
- IF '$DATA(ICDPRC(ICDI))
- QUIT
- XECUTE "S ICDTMP=$$ICDOP^ICDEX(+($G(ICDPRC(ICDI))),ICDDATE,,""I"") I ICDTMP<0!'($P(ICDTMP,U,10)) S ICDRTC=2 Q"
- IF ICDRTC=""
- Begin DoDot:1
- +32 SET ICDY(0)=$PIECE(ICDTMP,U,2,99)
- SET ICDNOR=ICDNOR+1
- SET ICDY=+($GET(ICDPRC(ICDI)))
- SET ICDO24($SELECT($PIECE(ICDY(0),"^",3)'="":$PIECE(ICDY(0),"^",3),1:"N"))=""
- DO OPS
- DO SEX
- End DoDot:1
- +33 KILL ICDO24("N")
- IF ICDRTC]""
- GOTO ERR
- +34 GOTO ^ICDDRG0
- +35 ;
- SEC ; Secondary Diagnosis
- +1 ; Is Secondary NCC for Primary
- +2 IF ICDDATE>3070930.9
- Begin DoDot:1
- +3 SET ICDMCC=$SELECT(+($$ISA^ICDEX(+($GET(ICDDX(ICDI))),+($GET(ICDDX(1))),1.11))>0:0,$PIECE(ICDY(0),"^",18)=2:2,($PIECE(ICDY(0),"^",18)=1)&(ICDMCC'=2):1,1:ICDMCC)
- SET ICDMCCT(ICDMCC)=""
- End DoDot:1
- +4 IF '$TEST
- Begin DoDot:1
- +5 SET ICDCC=$SELECT(+($$ISA^ICDEX(+($GET(ICDDX(ICDI))),+($GET(ICDDX(1))),1.11))>0:0,$PIECE(ICDY(0),"^",7)=1:1,1:ICDCC)
- SET ICDCCT(ICDCC)=""
- End DoDot:1
- +6 ; Group ICD identifiers in one variable
- +7 IF $LENGTH($PIECE(ICDY(0),"^",2))
- SET ICDSD=$$TM(ICDSD,";")_";"_$$TM($PIECE(ICDY(0),"^",2),";")
- SET ICDSD=";"_$$TM(ICDSD,";")_";"
- +8 SET ICDTMP=$$GETDRG^ICDEX(80,+($GET(ICDDX(ICDI))),ICDDATE)
- +9 ; If any of the following conditions are met set ICDSDRG array
- +10 IF (($PIECE(ICDY(0),"^",7)=1)!(ICDPD["h")!(ICDPD["J")!(ICDSD["h"))
- IF '$PIECE(ICDTMP,";",3)
- Begin DoDot:1
- +11 SET ICDSDRG=$PIECE(ICDTMP,";")
- FOR ICDK=1:1
- IF $PIECE(ICDSDRG,"^",ICDK)']""
- QUIT
- SET ICDSDRG($PIECE(ICDSDRG,"^",ICDK))=""
- End DoDot:1
- +12 SET ICDS24($SELECT($PIECE(ICDY(0),"^",12)'="":$PIECE(ICDY(0),"^",12),1:"N"))=""
- SET ICDS25($SELECT($PIECE(ICDY(0),"^",13)'="":$PIECE(ICDY(0),"^",13),1:0))=""
- +13 KILL ICDS24("N"),ICDS25(0)
- QUIT
- +14 ;
- OPS ; Operation/Procedures
- +1 IF '$DATA(ICDOP(" "_$PIECE(ICDY(0),"^",1)))
- SET ICDOP(" "_$PIECE(ICDY(0),"^",1))=""
- SET ICDOCNT=ICDOCNT+1
- +2 IF $SELECT($DATA(ICDMDC(12))!($DATA(ICDMDC(13)))>0:'$$MDCT^ICDEX(ICDY,ICDDATE,.ICDMDC,0),1:'$$MDCD^ICDEX(ICDY,ICDMDC,ICDDATE))
- Begin DoDot:1
- +3 SET ICDONR=ICDONR+1
- SET ICDORNI=ICDORNI_$PIECE(ICDY(0),"^",2)
- SET ICDORNI($SELECT($PIECE(ICDY(0),"^",2)'="":$PIECE(ICDY(0),"^",2),1:0))=""
- IF ICDORNR'=0
- SET ICDORNR=1
- End DoDot:1
- +4 IF $LENGTH($PIECE(ICDY(0),"^",2))
- SET ICDOR=$$TM(ICDOR,";")_";"_$$TM($PIECE(ICDY(0),"^",2),";")
- SET ICDOR=";"_$$TM(ICDOR,";")_";"
- +5 IF +ICDY(0)>37.69
- IF +ICDY(0)<37.84
- IF ICDOR'["p"
- Begin DoDot:1
- +6 NEW ICDCC3
- DO EN1^ICDDRG5
- IF ICDCC3
- SET ICDOR=ICDOR_"p"
- IF ICDOR'["O"
- SET ICDOR=ICDOR_"O"
- End DoDot:1
- +7 IF +ICDY(0)>80.999
- IF +ICDY(0)<81.40
- NEW ICDCC3
- DO EN1^ICDDRG8
- IF ICDCC3
- SET ICDOR=ICDOR_"F"
- +8 ; Major OR Procedure
- +9 IF $LENGTH($$MOR^ICDEX(ICDY))
- SET ICDMAJ=ICDMAJ_$PIECE($$MOR^ICDEX(ICDY),"^")_"^"
- +10 ; Set ICDOTMP with DRGs for doing checks
- +11 SET ICDOTMP=$PIECE($$GETDRG^ICDEX(80.1,ICDY,ICDDATE,$GET(ICDMDC)),";",1)
- IF +ICDOTMP'>0
- SET ICDOTMP=""
- +12 IF $PIECE(ICDY(0),"^",2)["O"
- Begin DoDot:1
- +13 SET ICDOPCT=ICDOPCT+1
- +14 IF ICDOPNR=0
- Begin DoDot:2
- +15 IF $SELECT($DATA(ICDMDC(12))!($DATA(ICDMDC(13)))>0:'$$MDCT^ICDEX(ICDY,ICDDATE,.ICDMDC,0),1:'$DATA(ICDOTMP))
- SET ICDOPNR=1
- End DoDot:2
- End DoDot:1
- +16 IF +ICDOTMP>0
- SET ICDF=ICDOTMP
- FOR ICDFX=1:1
- IF $PIECE(ICDF,"^",ICDFX)']""
- QUIT
- SET ICDODRG($PIECE(ICDF,"^",ICDFX))=$PIECE(ICDF,"^",ICDFX)
- +17 ; Translate identifiers into common symbol, check for symbol
- +18 SET ICD104=$SELECT($PIECE(ICDY(0),"^",2)["P":1,1:0)
- SET ICDNMDC($SELECT($TRANSLATE($PIECE(ICDY(0),"^",2),"lqtrB","\\\\")["\":1,1:0))=""
- QUIT
- +19 ;
- +20 ; Miscellaneous
- ERR ; Error Occured
- +1 SET ICDDRG=$SELECT(ICDDATE>3070930.9:999,1:470)
- +2 QUIT
- SEX ; Get sex for DX or Procedure
- +1 SET ICDSEX($SELECT($PIECE(ICDY(0),"^",10)="M":1,$PIECE(ICDY(0),"^",10)="F":2,1:0))=""
- +2 QUIT
- TM(X,Y) ; Trim Y
- +1 SET Y=$GET(Y)
- IF '$LENGTH(Y)
- SET Y=" "
- +2 FOR
- IF $EXTRACT(X,1)'=Y
- QUIT
- SET X=$EXTRACT(X,2,$LENGTH(X))
- +3 FOR
- IF $EXTRACT(X,$LENGTH(X))'=Y
- QUIT
- SET X=$EXTRACT(X,1,($LENGTH(X)-1))
- +4 QUIT X
- KILL ; Clean Environment
- +1 KILL ICD104,ICDJ,ICDJJ,ICDOCNT,ICDOR,ICDNOR,ICDP15,ICDPDRG,ICDRG,ICDSEX
- +2 KILL ICDSDRG,ICDODRG,ICDCC,ICDMCC,ICDOP,ICDORNR,ICDORNI,ICDP24,ICDP25,ICDPD
- +3 KILL ICDSD,ICDI,ICDK,ICDF,ICDFX,ICDFK,ICDY,ICDDXT,ICDIZ,ICDONR,ICDOPCT
- +4 KILL ICD,ICDCC2,ICDCC3,ICDGH,ICDL39,ICDMAJ,ICDNMDC,ICDNSD,ICDORNA,ICDREF
- +5 KILL ICDS24,ICDS25,ICDOPNR,ICDO24,ICDO25
- +6 QUIT
