AICDGRP1 ; IHS/OHPRD/GIS - SUPERGROUPER: GROUPER WITH SMART DX AND OP LOOKUP AND PRIORITIZED DISPLAY OF ALL DRG DIAGNOSES ; [ 12/31/2002 1:16 PM ]
;;3.51;IHS ICD/CPT lookup & grouper;**1,6**;MAY 30, 1991
PAT G PAT^AICDGRP
DXS K AICDDX S OR="",SD="",SD1=1
F AICDI=1:1 W ! S AICDPRMT="Enter Diagnosis No. "_AICDI_": " D DLOOKUP Q:"^"[X S:Y=-1 AICDI=AICDI-1 I Y'=-1 S AICDDX(AICDI)=Y,AICDDX(AICDI,0)=Y(0),AICDTOT=AICDI
I '$D(AICDDX) G PAT
OP W ! F NOR=0:1 S AICDPRMT="Enter Operation/Procedure: " D PLOOKUP Q:"^"[X I Y>0 S DA=+Y,OR=OR_$P(Y(0),U,2) F ORG=0:0 S ORG=$O(^ICD0(DA,"DR",ORG)) Q:ORG'>0 S %=$P(^ICD(ORG,0),U,5) I % S ORG(%,ORG)=""
G:X["^" Q
SUB F NSD=1:1:AICDTOT S Y(0)=AICDDX(NSD,0),SD=SD_$P(Y(0),U,2) S:$P(Y(0),U,2)'["g" SD1=0
MAKEARR F AICDJ=1:1:AICDTOT D ARR
LIST ;
S (X,W)="",S=3,$P(X,"-",81)="" W !!,X,!
S AICDN="" F AICDI=1:1 S AICDN=$O(AICDE(AICDN)) Q:AICDN="" D NARR I W=U G PAT
S X="" S $P(X,"-",81)="" W !,X,!!
G PAT
;
NARR I X=AICDE(AICDN) S AICDI=AICDI-1 Q
S X=AICDE(AICDN) X LINE G:W=U NARRQ W "RANK: ",AICDI,$J(("DRG: "_$E($P(X,U),4,99)),15),$J(("IHS WEIGHT: "_$P(X,U,7)),22),$J(("ALOS: "_$P(X,U,8)),15)
X LINE G:W=U NARRQ W "ICD9: "
F AICDJ=1:1 Q:'$D(AICDE(AICDN,AICDJ)) S Y=AICDE(AICDN,AICDJ) W:AICDJ>1 " " W "(",$P(Y,U),") ",$P(Y,U,3) X LINE G:W=U NARRQ
S AICDJ=0 W "DRG: (",$E($P(X,U),4,99),") "
F AICDL=1:1 S AICDJ=$O(^ICD($E($P(X,U),4,99),1,AICDJ)) Q:AICDJ'=+AICDJ W:AICDL>1 " " W ^(AICDJ,0) X LINE G:W=U NARRQ
NARRQ Q
;
ARR S Y=AICDDX(AICDJ),Y(0)=AICDDX(AICDJ,0),MDC=$P(Y(0),U,5) I MDC=469 Q
CD K RG
S PD=$P(Y(0),U,2),RG=0 I MDC=12 S MDC=$S(SEX="F":13,1:12)
F NDR=1:1 S RG=$O(^ICD9(+Y,"DR",RG)) Q:RG'>0 S RG(RG)=""
MORE I MDC=5,'NOR!(OR'["O") D MI,WRT:RG>0 Q
I MDC=18,OR["O" S RG=415 D WRT Q
I MDC=19,OR["O" S RG=424 D WRT Q
I MDC=23,OR["O" S RG=461 D WRT Q
I MDC=14 D ^DGDRG14,WRT Q
I MDC=20,DAM S RG=433 D WRT Q
I MDC=22 S:'$D(TAC) TAC=0 S RG=$S(TAC:456,PD["*"!(SD["*"):457,OR'["O":460,1:0) I RG D WRT Q
I MDC=15,TRS!EXP S RG=385 D WRT Q
I MDC=15,SD1 S RG=391 D WRT Q
I 'NOR,NDR<3 S RG=$O(RG(0)) D:RG'>0 469 D WRT Q
I 'NOR S RG=$O(RG(0)) X:$D(^ICD(RG,"MC")) ^ICD(RG,"MC") D WRT Q
D ^DGDRG6:MDC=6,^DGDRG8:MDC=8,^DGDRG2:MDC=2,^DGDRG3:MDC=3 S RG=$O(ORG(MDC,0)) G:RG'>0 NOP X:$D(^ICD(RG,"MC")) ^ICD(RG,"MC") D WRT Q
NOP I OR["O",MDC'=20 D 468 Q
D S RG=$O(RG(0)) X:$D(^ICD(RG,"MC")) ^ICD(RG,"MC") D:RG'>0 469 D WRT Q
WRT D:'$D(RG) 469 Q:RG<0 S DRGCAL=^ICD(RG,0),AICDN=$P(DRGCAL,U,7) I AICDN'="" D SETDRG
Q
SETDRG I '$D(AICDE(9-AICDN)) S AICDE(9-AICDN)=DRGCAL,AICDE(9-AICDN,1)=Y(0) Q
I DRGCAL'=AICDE(9-AICDN) S AICDN=AICDN+.000001 G SETDRG
F I=1:1 I '$D(AICDE(9-AICDN,I)) S AICDE(9-AICDN,I)=Y(0) Q
Q
;
469 S RG=469 W *7,!!,"DRG= 469 PDX INVALID AS DISCHARGE DIAGNOSIS" Q
468 ;
S OR="",NOR=0 K AICDVAR
D CD
Q
MI I PD["I"!(SD["I") S RG=$S($S($D(EXP):EXP,1:0):123,PD["V"!(SD["V"):121,1:122) Q
CATH I OR["H" S RG=$S(PD["X"!(SD["X"):124,1:125) Q
S RG=$O(RG(0)) X:$D(^ICD(RG,"MC")) ^ICD(RG,"MC") D:RG'>0 469 Q
Q
Q G Q^AICDGRP
DLOOKUP N (X,Y,AICDPRMT) K DIC S DIC="^ICD9(",DIC("A")=AICDPRMT,DIC(0)="AEMQZ" D ^DIC Q ;*1*
PLOOKUP N (X,Y,AICDPRMT) K DIC S DIC="^ICD0(",DIC("A")=AICDPRMT,DIC(0)="AEMQZ" D ^DIC Q ;*1*
AICDGRP1 ; IHS/OHPRD/GIS - SUPERGROUPER: GROUPER WITH SMART DX AND OP LOOKUP AND PRIORITIZED DISPLAY OF ALL DRG DIAGNOSES ; [ 12/31/2002 1:16 PM ]
+1 ;;3.51;IHS ICD/CPT lookup & grouper;**1,6**;MAY 30, 1991
PAT GOTO PAT^AICDGRP
DXS KILL AICDDX
SET OR=""
SET SD=""
SET SD1=1
+1 FOR AICDI=1:1
WRITE !
SET AICDPRMT="Enter Diagnosis No. "_AICDI_": "
DO DLOOKUP
IF "^"[X
QUIT
IF Y=-1
SET AICDI=AICDI-1
IF Y'=-1
SET AICDDX(AICDI)=Y
SET AICDDX(AICDI,0)=Y(0)
SET AICDTOT=AICDI
+2 IF '$DATA(AICDDX)
GOTO PAT
OP WRITE !
FOR NOR=0:1
SET AICDPRMT="Enter Operation/Procedure: "
DO PLOOKUP
IF "^"[X
QUIT
IF Y>0
SET DA=+Y
SET OR=OR_$PIECE(Y(0),U,2)
FOR ORG=0:0
SET ORG=$ORDER(^ICD0(DA,"DR",ORG))
IF ORG'>0
QUIT
SET %=$PIECE(^ICD(ORG,0),U,5)
IF %
SET ORG(%,ORG)=""
+1 IF X["^"
GOTO Q
SUB FOR NSD=1:1:AICDTOT
SET Y(0)=AICDDX(NSD,0)
SET SD=SD_$PIECE(Y(0),U,2)
IF $PIECE(Y(0),U,2)'["g"
SET SD1=0
MAKEARR FOR AICDJ=1:1:AICDTOT
DO ARR
LIST ;
+1 SET (X,W)=""
SET S=3
SET $PIECE(X,"-",81)=""
WRITE !!,X,!
+2 SET AICDN=""
FOR AICDI=1:1
SET AICDN=$ORDER(AICDE(AICDN))
IF AICDN=""
QUIT
DO NARR
IF W=U
GOTO PAT
+3 SET X=""
SET $PIECE(X,"-",81)=""
WRITE !,X,!!
+4 GOTO PAT
+5 ;
NARR IF X=AICDE(AICDN)
SET AICDI=AICDI-1
QUIT
+1 SET X=AICDE(AICDN)
XECUTE LINE
IF W=U
GOTO NARRQ
WRITE "RANK: ",AICDI,$JUSTIFY(("DRG: "_$EXTRACT($PIECE(X,U),4,99)),15),$JUSTIFY(("IHS WEIGHT: "_$PIECE(X,U,7)),22),$JUSTIFY(("ALOS: "_$PIECE(X,U,8)),15)
+2 XECUTE LINE
IF W=U
GOTO NARRQ
WRITE "ICD9: "
+3 FOR AICDJ=1:1
IF '$DATA(AICDE(AICDN,AICDJ))
QUIT
SET Y=AICDE(AICDN,AICDJ)
IF AICDJ>1
WRITE " "
WRITE "(",$PIECE(Y,U),") ",$PIECE(Y,U,3)
XECUTE LINE
IF W=U
GOTO NARRQ
+4 SET AICDJ=0
WRITE "DRG: (",$EXTRACT($PIECE(X,U),4,99),") "
+5 FOR AICDL=1:1
SET AICDJ=$ORDER(^ICD($EXTRACT($PIECE(X,U),4,99),1,AICDJ))
IF AICDJ'=+AICDJ
QUIT
IF AICDL>1
WRITE " "
WRITE ^(AICDJ,0)
XECUTE LINE
IF W=U
GOTO NARRQ
NARRQ QUIT
+1 ;
ARR SET Y=AICDDX(AICDJ)
SET Y(0)=AICDDX(AICDJ,0)
SET MDC=$PIECE(Y(0),U,5)
IF MDC=469
QUIT
CD KILL RG
+1 SET PD=$PIECE(Y(0),U,2)
SET RG=0
IF MDC=12
SET MDC=$SELECT(SEX="F":13,1:12)
+2 FOR NDR=1:1
SET RG=$ORDER(^ICD9(+Y,"DR",RG))
IF RG'>0
QUIT
SET RG(RG)=""
MORE IF MDC=5
IF 'NOR!(OR'["O")
DO MI
IF RG>0
DO WRT
QUIT
+1 IF MDC=18
IF OR["O"
SET RG=415
DO WRT
QUIT
+2 IF MDC=19
IF OR["O"
SET RG=424
DO WRT
QUIT
+3 IF MDC=23
IF OR["O"
SET RG=461
DO WRT
QUIT
+4 IF MDC=14
DO ^DGDRG14
DO WRT
QUIT
+5 IF MDC=20
IF DAM
SET RG=433
DO WRT
QUIT
+6 IF MDC=22
IF '$DATA(TAC)
SET TAC=0
SET RG=$SELECT(TAC:456,PD["*"!(SD["*"):457,OR'["O":460,1:0)
IF RG
DO WRT
QUIT
+7 IF MDC=15
IF TRS!EXP
SET RG=385
DO WRT
QUIT
+8 IF MDC=15
IF SD1
SET RG=391
DO WRT
QUIT
+9 IF 'NOR
IF NDR<3
SET RG=$ORDER(RG(0))
IF RG'>0
DO 469
DO WRT
QUIT
+10 IF 'NOR
SET RG=$ORDER(RG(0))
IF $DATA(^ICD(RG,"MC"))
XECUTE ^ICD(RG,"MC")
DO WRT
QUIT
+11 IF MDC=6
DO ^DGDRG6
IF MDC=8
DO ^DGDRG8
IF MDC=2
DO ^DGDRG2
IF MDC=3
DO ^DGDRG3
SET RG=$ORDER(ORG(MDC,0))
IF RG'>0
GOTO NOP
IF $DATA(^ICD(RG,"MC"))
XECUTE ^ICD(RG,"MC")
DO WRT
QUIT
NOP IF OR["O"
IF MDC'=20
DO 468
QUIT
D SET RG=$ORDER(RG(0))
IF $DATA(^ICD(RG,"MC"))
XECUTE ^ICD(RG,"MC")
IF RG'>0
DO 469
DO WRT
QUIT
WRT IF '$DATA(RG)
DO 469
IF RG<0
QUIT
SET DRGCAL=^ICD(RG,0)
SET AICDN=$PIECE(DRGCAL,U,7)
IF AICDN'=""
DO SETDRG
+1 QUIT
SETDRG IF '$DATA(AICDE(9-AICDN))
SET AICDE(9-AICDN)=DRGCAL
SET AICDE(9-AICDN,1)=Y(0)
QUIT
+1 IF DRGCAL'=AICDE(9-AICDN)
SET AICDN=AICDN+.000001
GOTO SETDRG
+2 FOR I=1:1
IF '$DATA(AICDE(9-AICDN,I))
SET AICDE(9-AICDN,I)=Y(0)
QUIT
+3 QUIT
+4 ;
469 SET RG=469
WRITE *7,!!,"DRG= 469 PDX INVALID AS DISCHARGE DIAGNOSIS"
QUIT
468 ;
+1 SET OR=""
SET NOR=0
KILL AICDVAR
+2 DO CD
+3 QUIT
MI IF PD["I"!(SD["I")
SET RG=$SELECT($SELECT($DATA(EXP):EXP,1:0):123,PD["V"!(SD["V"):121,1:122)
QUIT
CATH IF OR["H"
SET RG=$SELECT(PD["X"!(SD["X"):124,1:125)
QUIT
+1 SET RG=$ORDER(RG(0))
IF $DATA(^ICD(RG,"MC"))
XECUTE ^ICD(RG,"MC")
IF RG'>0
DO 469
QUIT
+2 QUIT
Q GOTO Q^AICDGRP
DLOOKUP ;*1*
NEW (X,Y,AICDPRMT)
KILL DIC
SET DIC="^ICD9("
SET DIC("A")=AICDPRMT
SET DIC(0)="AEMQZ"
DO ^DIC
QUIT
PLOOKUP ;*1*
NEW (X,Y,AICDPRMT)
KILL DIC
SET DIC="^ICD0("
SET DIC("A")=AICDPRMT
SET DIC(0)="AEMQZ"
DO ^DIC
QUIT
