- 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
