ICDDRGM ;ALB/GRR/EG/ADL/KUM - GROUPER DRIVER ;28 Oct 2013 5:41 PM
;;18.0;DRG Grouper;**7,36,57,64**;Oct 20, 2000;Build 103
;
; ADL Add Date prompt and passing of effective date for DRG CSV project
; ADL Update DIC("S") code to screen using new function calls
; ADL Update to access DRG file using new API for CSV Project
; KER Remove direct global reads, update for ICD-10
;
; Global Variables
; ^DPT( ICR 10035
;
; External References
; ^%DTC ICR 10000
; ^DIC ICR 10006
; ^DIR ICR 10026
; $$DT^XLFDT ICR 10103
; H^XUS ICR 10044
; ^ICDDRG ICR N/A
; $$DRG^ICDEX ICR N/A
; $$DRGD^ICDEX ICR N/A
; $$ROOT^ICDEX ICR N/A
;
; Local Variables NEWed or KILLed Elsewhere
; DIRUT,ICDDATE,QUIT,Y
;
S U="^",DT=$$DT^XLFDT W !!?11,"DRG Grouper Version ","18.0",!! ;$$VERSION^XPDUTL("ICD"),!!
PAT ; Patient
D KILL
S ICDQU=0 K ICDEXP,SEX,ICDDX,ICDSURG,ICDPOA,ICDCSYS
D EFFDATE G KILL:$D(DUOUT),ICDOUT:$D(DTOUT)
S DIR(0)="Y",DIR("A")="DRGs for Registered PATIENTS (Y/N)",DIR("B")="YES"
S DIR("?")="Enter 'Yes' if the patient has been previously registered, enter 'No' for other patient, or '^' to quit."
D ^DIR K DIR S ICDPT=Y G KILL:$D(DUOUT),ICDOUT:$D(DTOUT)
PAT0 ; Patient - Ask again
G:ICDPT=0 ASK
VA ; VA Patient File #2
S DIC="^DPT(",DIC(0)="AEQMZ" D ^DIC G Q:X=""!(X[U)!(Y'>0),ICDOUT:$D(DTOUT) S DFN=+Y,(DOB,AGE)=$P(Y(0),U,3),SEX=$P(Y(0),U,2)
D TAC G:ICDQU PAT D DAM G:ICDQU PAT
EN1 ; Entry Point - Patient is known (DFN)
I $D(^DPT(DFN,.35)),$L(^DPT(DFN,.35)) D ALIVE G:ICDQU PAT
S ICDEXP=$S($D(ICDEXP):ICDEXP,1:0)
I AGE]"" N %,X,X1,X2 S X1=DT,X2=AGE D ^%DTC S AGE=X\365.25 W " AGE: ",AGE
CD ;Prompt POA if ICD-10 DRG calculation
S ICDCSYS=$S(ICDDATE'<$$IMPDATE^LEXU("10D"):"ICD10",1:"ICD9")
D ICDCD G PAT:$G(QUIT)
G Q:X[U
OP ; PROCEDURE CODE SELECTION
S ICDCDSY=$S(ICDCSYS="ICD9":2,1:31),ICDCV="(ICD "_$P(ICDCSYS,"ICD",2)_")"
S DIC("A")="Enter Operation/Procedure "_ICDCV_": "
W !
F ICDNOR=1:1 D Q:X=""!(X[U) G:$D(DTOUT) ICDOUT I X'=0,Y>0 S ICDPRC(ICDNOR)=+Y,ICDSURG(ICDNOR)=X
.;I ICDCSYS="ICD10" S ICDXX1=1 S ICDPRC="" D ASK^ICDCODLK K ICDXX1
.I ICDCSYS="ICD10" D PROC
.I ICDCSYS="ICD9" S ICDPRC="" D ICD9OP
K DIC,ICDCDSY,ICDCV G Q:X["^"
;Rearrange ICDPRC array
S X=0,ICDCNT=1
F S X=$O(ICDPRC(X)) Q:'X D
. S ICDPRCT(ICDCNT)=ICDPRC(X)
. S ICDCNT=ICDCNT+1
K ICDPRC
M ICDPRC=ICDPRCT
;Rearrange ICDSURG array
S X=0,ICDCNT=1
F S X=$O(ICDSURG(X)) Q:'X D
. S ICDSURGT(ICDCNT)=ICDSURG(X)
. S ICDCNT=ICDCNT+1
K ICDSURG
M ICDSURG=ICDSURGT
;
I ICDCSYS="ICD10" M ICDDXZ=ICDDX,ICDPRCZ=ICDPRC,ICDPOAZ=ICDPOA
D ^ICDDRG
D WRT
I ICDCSYS="ICD10" K ICDEXP,SEX,ICDDX,ICDSURG,ICDPOA,ICDPRC,ICDDXZ,ICDPRCZ,ICDPOAZ,ICDPRCT,ICDCNT,ICDSURGT
G PAT0
WRT S ICDDRG(0)=$$DRG^ICDEX(+ICDDRG,ICDDATE) ; new CSV code
I ICDCSYS="ICD10" D
. S ICDTMP=$$ICDDX^ICDEX(ICDDXZ(1),ICDDATE,"10D","I")
. W !,"Principal Diagnosis: ",$P(ICDTMP,U,2),?30,$E($$VST^ICDEX(80,ICDDXZ(1),ICDDATE),1,44),?75,"POA=",$S($G(ICDPOAZ(1))'="":ICDPOAZ(1),1:"-")
. F ICDI=2:1 Q:'$D(ICDDXZ(ICDI)) D
. . S ICDTMP=$$ICDDX^ICDEX(ICDDXZ(ICDI),ICDDATE,"10D","I")
. . W:ICDI=2 !,"Secondary Diagnosis: " W:ICDI>2 !?21 W $P(ICDTMP,U,2),?30,$E($$VST^ICDEX(80,ICDDXZ(ICDI),ICDDATE),1,44),?75,"POA=",$S($G(ICDPOAZ(ICDI))'="":ICDPOAZ(ICDI),1:"-")
. F ICDI=1:1 Q:'$D(ICDPRCZ(ICDI)) D
. . S ICDTMP=$$ICDOP^ICDEX(ICDPRCZ(ICDI),ICDDATE,"10P","I")
. . W:ICDI=1 !!,"Procedure Code: " W:ICDI>1 ! W ?21,$P(ICDTMP,U,2),?30,$E($$VST^ICDEX(80.1,ICDPRCZ(ICDI),ICDDATE),1,50)
W !!?9,"Effective Date: "," ",ICDDSP
W !,"Diagnosis Related Group: ",$J(ICDDRG,6),?40,"Avg len of stay: ",$J($P(ICDDRG(0),"^",8),6)
W !?17,"Weight: ",$J($P(ICDDRG(0),"^",2),6),?40,"Local Breakeven: ",$J($P(ICDDRG(0),"^",12),6)
W !?12," Low day(s): ",$J($P(ICDDRG(0),"^",3),6),?39,"Local low day(s): ",$J($P(ICDDRG(0),"^",9),6)
W !?13," High days: ",$J($P(ICDDRG(0),"^",4),6),?40,"Local High days: ",$J($P(ICDDRG(0),"^",10),6)
;W !!,"DRG: ",ICDDRG,"-" F I=0:0 S I=$N(^ICD(ICDDRG,1,I)) Q:I'>0 W ?10,$P(^(I,0),U,1),!
;W !!,"DRG: ",ICDDRG,"-" F I=0:0 S I=$O(^ICD(ICDDRG,1,I)) Q:(I="")!(I'?.N) W ?10,$P(^(I,0),U,1),!
N ICDXD,ICDGDX,ICDGI
S ICDXD=$$DRGD^ICDEX(ICDDRG,"ICDGDX",ICDDATE),ICDGI=0
W !!,"DRG: ",ICDDRG,"-" F S ICDGI=$O(ICDGDX(ICDGI)) Q:'+ICDGI Q:ICDGDX(ICDGI)=" " W ?10,ICDGDX(ICDGI),!
Q
ERROR D WRT
I ICDRTC<5 W !!,"Invalid ",$S(ICDRTC=1:"Principal Diagnosis",ICDRTC=2:"Operation/Procedure",ICDRTC=3:"Age",ICDRTC=4:"Sex",1:"") G PAT0
I ICDRTC=5 W !!,"Grouper needs to know if patient died during this episode!" G PAT0
I ICDRTC=6 W !!,"Grouper needs to know if patient was transferred to an acute care facility!" G PAT0
I ICDRTC=7 W !!,"Grouper needs to know if patient was discharged against medical advice!" G PAT0
I ICDRTC=8 W !!,"Patient assigned newborn diagnosis code. Check diagnosis!" G PAT0
G PAT0
KILL K DIC,DFN,DUOUT,DTOUT,ICDNOR,ICDDX,ICDPRC,ICDEXP,ICDTRS,ICDDMS,ICDDRG,ICDMDC,ICDO24,ICDP24,ICDP25,ICDRTC,ICDPT,ICDQU,ICDSD,ICDNMDC
K ICDMAJ,ICDS25,ICDSEX,AGE,DOB,CC,HICDRG,ICD,ICDCC3,ICDJ,ICDJJ,ICDL39,ICDFZ,ICDDT,ICDDSP,IENT,QUIT
Q
Q G PAT
AGE S DIR(0)="NOA^0:124:0",DIR("A")="Patient's age: ",DIR("?")="Enter how old the patient is (0-124)." D ^DIR K DIR S AGE=Y G QQ:$D(DUOUT),ICDOUT:$D(DTOUT)
Q
ALIVE S DIR(0)="YO",DIR("A")="Did patient die during this episode" D ^DIR K DIR S ICDEXP=Y G QQ:$D(DUOUT),ICDOUT:$D(DTOUT)
Q
TAC S DIR(0)="YO",DIR("A")="Was patient transferred to an acute care facility" D ^DIR K DIR S ICDTRS=Y G QQ:$D(DUOUT),ICDOUT:$D(DTOUT)
Q
DAM S DIR(0)="YO",DIR("A")="Was patient discharged against medical advice" D ^DIR K DIR S ICDDMS=Y G QQ:$D(DUOUT),ICDOUT:$D(DTOUT)
Q
SEX S DIR(0)="SBO^M:MALE;F:FEMALE",DIR("?")="Enter M for Male and F for Female",DIR("A")="Patient's Sex" D ^DIR K DIR S SEX=Y G QQ:$D(DUOUT),ICDOUT:$D(DTOUT)
Q
QQ S ICDQU=1 Q
EFFDATE ;prompts for effective date for DRG grouper?
K DIR S DIR(0)="D^::AEX",DIR("B")="TODAY",DIR("A")="Effective Date"
S DIR("?")="The effective to be used when calculating the DRG code for the patient."
D ^DIR K DIR I $D(DIRUT) S QUIT=1 Q
S ICDDATE=Y,ICDDSP=Y(0)
Q
ASK K DTOUT,DUOUT D AGE G:ICDQU PAT D ALIVE G:ICDQU PAT D TAC G:ICDQU PAT D DAM G:ICDQU PAT D SEX G:ICDQU PAT G CD
ICDOUT G H^XUS
;
ICDCD ;prompts for ICD diagnosis codes; ALB/JAM *64 ICD10 changes
N ICDPDXV,ICDSDXV,ICDDXPOA,ICDSD,ICDSC
S ICDSC="(ICD "_$P(ICDCSYS,"ICD",2)_")"
S ICDPDXV=$$ICDPDX Q:$G(QUIT)!(ICDPDXV<0) S ICDDX(1)=ICDPDXV
;if ICD9 code skip POA question
I ICDCSYS="ICD9" G ICDSDXV
S ICDDXPOA=$$POA(ICDPDXV) Q:$G(QUIT) S ICDPOA(1)=$TR(ICDDXPOA,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
ICDSDXV F ICDSD=2:1 S ICDSDXV=$$ICDSDX Q:$G(QUIT)!(ICDSDXV'>0) S ICDDX(ICDSD)=ICDSDXV D Q:$G(QUIT)
.; if ICD9 code skip POA question
.I ICDCSYS="ICD9" Q
.S ICDDXPOA=$$POA(ICDSDXV) Q:$G(QUIT) S ICDPOA(ICDSD)=$TR(ICDDXPOA,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
Q
;
; Get ICD Principal Diagnosis Code
ICDPDX() ;
N DIC,ICDCDSY,IENT,ICDSVAL,ICDPRI
N ICDDSCR,ICDQUIT
S ICDQUIT=0
S ICDDSCR="Enter Principal diagnosis "_ICDSC_": "
S ICDCDSY=$S(ICDCSYS="ICD9":1,1:30)
;if ICD-10
I ICDCSYS="ICD10" D Q ICDSVAL
. ;if was aborted in the list then don't set QUIT=1, if aborted in the search string prompt then set QUIT=1
. F S ICDSVAL=$$ICD10SRH(ICDDSCR,ICDDATE) Q:$G(ICDSVAL)>0 S:(ICDSVAL=-11)!(ICDSVAL=-2)!(ICDSVAL=0) (ICDQUIT,QUIT)=1 Q:ICDQUIT=1
;if ICD-9
S IENT="I",ICDPRI="Y"
S DIC=$$ROOT^ICDEX(80),DIC(0)="AEQMZI"
S DIC("A")=ICDDSCR
S DIC("S")="I $P($$ICDDX^ICDEX(+$G(Y),$G(ICDDATE),ICDCDSY,IENT),U,1)>0,$P($$ICDDX^ICDEX(+$G(Y),$G(ICDDATE),ICDCDSY,IENT),U,10),'$P($$ICDDX^ICDEX(+$G(Y),ICDDATE,ICDCDSY,IENT),U,5)"
S Y=$$SEARCH^ICDSAPI(80,DIC("S"),DIC(0),$G(ICDDATE))
I Y<=0 S QUIT=1 Q -1
Q +Y
;
;Get ICD Secondary Diagnoses Codes
ICDSDX() ;
N DIC,ICDCDSY,IENT,ICDSVAL
N ICDDSCR,ICDQUIT
S ICDQUIT=0
S ICDDSCR="Enter SECONDARY diagnosis "_ICDSC_": "
S ICDCDSY=$S(ICDCSYS="ICD9":1,1:30)
;if ICD-10
I ICDCSYS="ICD10" D Q ICDSVAL
. ;if was aborted in the list then don't set QUIT=1, if aborted in the search string prompt then set QUIT=1
. F S ICDSVAL=$$ICD10SRH(ICDDSCR,ICDDATE) Q:$G(ICDSVAL)>0 S:ICDSVAL=0!(ICDSVAL=-2) ICDQUIT=1 S:ICDSVAL=-11 (ICDQUIT,QUIT)=1 Q:ICDQUIT=1
;if ICD-9
S IENT="I"
S DIC=$$ROOT^ICDEX(80),DIC(0)="AEQMZI"
S DIC("A")=ICDDSCR
S DIC("S")="I $P($$ICDDX^ICDEX(+$G(Y),$G(ICDDATE),ICDCDSY,IENT),U,1)>0,$P($$ICDDX^ICDEX(+$G(Y),$G(ICDDATE),ICDCDSY,IENT),U,10)"
S Y=$$SEARCH^ICDSAPI(80,DIC("S"),DIC(0),$G(ICDDATE))
I $D(DTOUT) S QUIT=1 Q -1
I Y>0 Q +Y
Q -1
;
;
;Ask for diagnosis
;ICDTINT - date of interest
;ICDPROM - prompt
;
;returns -11 if user has entered one of these - ^ ^^ or null
; -4 user doesn't want to continue
; -11 aborted by ^ or ^^ when the user enters the search sring (wants to quit from the prompt to the previous level)
; -3 aborted by ^ or ^^ during selection of the items on the list
; -2 Timed out
; -9 User entered only one character
; -1 User entered Blank in the list of selection
; -10 User entered invalid data in the list of selection
ICD10SRH(ICDPROM,ICDTINT) ; Lexicon Partial Code Search
N ICDUSTR,ICDPARAM
;set parameters for partial LEXICON search
D SETPARAM^ICDDSLK(.ICDPARAM)
;if prompt provided the getusers input,
; return -11 to indicate that user wants to quit from the prompt to the previous level
; return 0 to indicate that user pressed Enter in the primary diag prompt it means he wants to quit from the prompt to the previous level,
; in secondary - wants to skip secodary diags
; otherwise call STS API for partial LEXICON search
D Q:ICDUSTR'>0 ICDUSTR S ICDY=$$LEXICD10^ICDDSLK($P(ICDUSTR,U,2),ICDTINT,.ICDPARAM)
. F S ICDUSTR=$$GETUSINP(ICDPROM) Q:ICDUSTR'=-22 ;repeat if less than 2 chars and wasn't aborted by ^,^^ or null (Enter key pressed)
; User entered only one character
I ICDY=-9 Q -9
; User entered Blank
I ICDY=-1 Q -1
; User entered invalid data
I ICDY="" W !!,ICDPARAM("NO DATA FOUND") Q -12
; aborted by ^ or ^^
I ICDY=-3 Q -3
; Timed out
I ICDY=-2 Q -2
; User doesn't want to continue
I ICDY=-4 Q -4
; otherwise get the IEN of the selected code
K DIC
S ICDY=+$$CODEN^ICDEX($P($P(ICDY,";",2),U,1),80)
Q +ICDY
;
;Get user input
;returns:
; "-2" timeout
; "-11" user entered ^ or ^^
; "-22" user entered less than 2 chars
; 0 user entered null
; 1 user entered more than 2 chars
GETUSINP(ICDPRMPT) ;
N DIR
S DIR("A")=ICDPRMPT
S DIR(0)="FAO^0:245"
S DIR("?")="^D INPHLP^ICDDSLK"
S DIR("??")="^D INPHLP^ICDDSLK"
D ^DIR
I $D(DTOUT) Q -2 ;timeout
I Y="" Q 0 ; user entered null
I Y["^" Q -11 ; user entered ^ or ^^
I $L(Y)'>1 W !,"Please enter at least the first two characters of the ICD-10 code or code description to start the search." Q -22
Q "1"_U_Y
;
GETIDX(ICDCSYS,ICDCODE,ICDT) ;
N ICDICDX
S ICDICDX=$$ICDDATA^ICDXCODE(ICDCSYS,ICDCODE,ICDT)
I ICDICDX<1 Q $P(ICDICDX,U,2)
Q $P(ICDICDX,U)_U_$P(ICDICDX,U,4)
;
POA(ICDDX123) ; Present On Admission
N DIR,X,Y,ICDPR
S QUIT=0,DIR("A")="Present on Admission: ",DIR(0)="SOA^Y:YES;N:NO;U:Unknown;W:Clinically undetermined"
K DIR S QUIT=0,DIR("A")="Present on Admission: ",DIR(0)="SOA^Y:YES;N:NO;U:Unknown;W:Clinically undetermined"
S (DIR("?"),DIR("??"))="^D HELPPOA^ICDDRGM"
D ^DIR
I ($D(DTOUT))!($D(DUOUT))!($D(DIROUT)) S QUIT=1 Q -1
I X="" D
. I $$GET1^DIQ(80,ICDDX123,1.9,"I")'=1 D ;Not POA Exempt
. . S ICDPR(1)="Diagnosis "_$$GET1^DIQ(80,ICDDX123,.01,"I")_" is not contained in the POA Exempt list so the POA field should"
. . S ICDPR(2)="not be blank. If left blank, it will be treated as if it were a No (""N"")."
. . D EN^DDIOL(.ICDPR)
. . K DIR S DIR(0)="Y",DIR("A")="Do you wish to continue? (Y/N)",DIR("B")="YES" D ^DIR I ($D(DTOUT))!($D(DUOUT))!($D(DIROUT)) S QUIT=1
. . I Y=0 S QUIT=1 Q
. . S Y="N" ;This may subsequently be removed if the DX is on the HAC list - see $$HAC^ICDDRGM
. E S Y="Y"
E S Y=X
I QUIT Q -1
Q Y
;
DXSCRN ;Diagnoses review of POA and HAC indicators; ALB/JAM *64 ICD10 changes
N I,X,ICDDX123,ICDTMPX,ICDTMPOA,C,ICDOUT
;if POA value does not exist for Primary DX set to "U"nknown
I '$D(ICDPOA(1)) S ICDPOA(1)="U"
S X=1
F S X=$O(ICDDX(X)) Q:'X S ICDOUT=0 D
.;if POA value does not exist for DX set to "U"nknown
.I '$D(ICDPOA(X)) S ICDPOA(X)="U"
.;if DX is POA exempt include in DRG calculation
.S ICDDX123=ICDDX(X) I $$GET1^DIQ(80,ICDDX123,1.9,"I") Q
.;if POA value for DX is Y or W include in DRG calculation
.F I="Y","W" I ICDPOA(X)=I S ICDOUT=1 Q
.I ICDOUT Q
.;if DX not in HAC list include in DRG calculation
.F I="N","U",1 I ICDPOA(X)=I,'$$HAC(ICDDX123) S ICDOUT=1 Q
.I ICDOUT Q
.I ICDPOA(X)="",'$$HAC(ICDDX123) S ICDOUT=1 Q
.I ICDOUT Q
.; remove entry from ICDDX and ICDPOA array
.K ICDDX(X),ICDPOA(X)
; resequence entries in ICDDX and ICDPOA array
M ICDTMPX=ICDDX,ICDTMPOA=ICDPOA
K ICDDX,ICDPOA
S C=0
S X=0 F S X=$O(ICDTMPX(X)) Q:'X S C=C+1,ICDDX(C)=ICDTMPX(X),ICDPOA(C)=ICDTMPOA(X)
Q
;
HAC(ICDDX123) ; Check if diagnosis code is in Hospital Acquired Conditions (HACS) file #80.6
;Input DX - Diagnosis code IEN, pointer to file #80
;Output - 1 if the DX code is found in file #80.6
; 0 if the DX code not found in the file
;
I $D(^ICDHAC("C",ICDDX123)) Q 1
Q 0
;
ICD9OP ; ICD-9 PROCEDURE CODE SEARCH
S IENT="I"
S DIC("S")="I $P($$ICDOP^ICDEX(+$G(Y),$G(ICDDATE),ICDCDSY,IENT),U,1)>0,+$P($$ICDOP^ICDEX(+$G(Y),$G(ICDDATE),ICDCDSY,IENT),U,10)'=0"
S DIC("A")="Enter Operation/Procedure "_ICDCV_": "
S DIC(0)="AEQMZI" ;,DIC("S")="I $P($$ICDOP^ICDEX($G(Y),$G(ICDDATE),ICDCDSY,IENT),U,1)>0"
S Y=$$SEARCH^ICDSAPI(80.1,DIC("S"),DIC(0),$G(ICDDATE))
Q
;
HELPPOA ;
W !?5,"Apply the Present on Admission (POA) indicator for each diagnosis"
W !?5,"and external cause of injury code(s) reported as the final set of"
W !?5,"diagnosis codes assigned. One of the following values should be"
W !?5,"assigned in accordance with the official coding guidelines:"
W !?5,""
W !?5,"Y = present at the time of inpatient admission;"
W !?5,"N = not present at the time of inpatient admission;"
W !?5,"U = documentation is insufficient to determine if"
W !?5," condition is present on admission;"
W !?5,"W = provider is unable to clinically determine"
W !?5," whether condition was present on admission or not"
W !?5,"<enter> = use only if diagnosis is exempt from POA reporting"
Q
;
PROC ; Ask Procedure
N DIR,ICDXX1
S ICDXX1=1 S ICDPRC=""
S DIR(0)="FAO^1:12"
S DIR("A")="Enter Operation/Procedure (ICD 10):"
S DIR("?")="^D P1^ICDDRGM",DIR("??")="^D P2^ICDDRGM"
D ^DIR
I $D(DTOUT)!($D(DUOUT))!($D(DIRUT))!($D(DIROUT))!(Y="") S Y=-1 Q
;I X["*" S X=$P(X,"*",1)
S ICDPRC=X
;I X["*" S X=$P(X,"*",1)_$P(X,"*",2)
D ASK^ICDCODLK
Q Y
P1 ;
I X["???" D P3 Q ;For calls from ^DIR, doesn't support ??? help
I X["??" D P2 Q
D EN^DDIOL("Enter the initial character(s) of an ICD-10 partial code or an","","!?5")
D EN^DDIOL("asterisk (*) for more information.","","!?5")
D EN^DDIOL(" ")
Q
;
P2 ;
D EN^DDIOL("1. Enter an ICD-10 Procedure Code.","","!?8")
D EN^DDIOL(" or ","","!?8")
D EN^DDIOL("2. Enter any alphanumeric char values of the procedure code to 'build'","","!?8")
D EN^DDIOL(" an ICD-10 Procedure Code.","","!?8")
D EN^DDIOL(" or ","","!?8")
D EN^DDIOL("3. Enter an asterisk (*) to initiate a procedure code build search. ","","!?8")
D EN^DDIOL(" ")
Q
;
P3 ;
D EN^DDIOL("The procedure code search provides a 'decision tree' type structure","","!?8")
D EN^DDIOL("that makes use of the specific ICD-10-PCS code format and structure,","","!?8")
D EN^DDIOL("where all codes consist of 7 alphanumeric characters, with each","","!?8")
D EN^DDIOL("position in the code having a specific meaning.","","!?8")
D EN^DDIOL(" ")
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HICDDRGM 16295 printed Sep 23, 2025@19:26:23 Page 2
ICDDRGM ;ALB/GRR/EG/ADL/KUM - GROUPER DRIVER ;28 Oct 2013 5:41 PM
+1 ;;18.0;DRG Grouper;**7,36,57,64**;Oct 20, 2000;Build 103
+2 ;
+3 ; ADL Add Date prompt and passing of effective date for DRG CSV project
+4 ; ADL Update DIC("S") code to screen using new function calls
+5 ; ADL Update to access DRG file using new API for CSV Project
+6 ; KER Remove direct global reads, update for ICD-10
+7 ;
+8 ; Global Variables
+9 ; ^DPT( ICR 10035
+10 ;
+11 ; External References
+12 ; ^%DTC ICR 10000
+13 ; ^DIC ICR 10006
+14 ; ^DIR ICR 10026
+15 ; $$DT^XLFDT ICR 10103
+16 ; H^XUS ICR 10044
+17 ; ^ICDDRG ICR N/A
+18 ; $$DRG^ICDEX ICR N/A
+19 ; $$DRGD^ICDEX ICR N/A
+20 ; $$ROOT^ICDEX ICR N/A
+21 ;
+22 ; Local Variables NEWed or KILLed Elsewhere
+23 ; DIRUT,ICDDATE,QUIT,Y
+24 ;
+25 ;$$VERSION^XPDUTL("ICD"),!!
SET U="^"
SET DT=$$DT^XLFDT
WRITE !!?11,"DRG Grouper Version ","18.0",!!
PAT ; Patient
+1 DO KILL
+2 SET ICDQU=0
KILL ICDEXP,SEX,ICDDX,ICDSURG,ICDPOA,ICDCSYS
+3 DO EFFDATE
if $DATA(DUOUT)
GOTO KILL
if $DATA(DTOUT)
GOTO ICDOUT
+4 SET DIR(0)="Y"
SET DIR("A")="DRGs for Registered PATIENTS (Y/N)"
SET DIR("B")="YES"
+5 SET DIR("?")="Enter 'Yes' if the patient has been previously registered, enter 'No' for other patient, or '^' to quit."
+6 DO ^DIR
KILL DIR
SET ICDPT=Y
if $DATA(DUOUT)
GOTO KILL
if $DATA(DTOUT)
GOTO ICDOUT
PAT0 ; Patient - Ask again
+1 if ICDPT=0
GOTO ASK
VA ; VA Patient File #2
+1 SET DIC="^DPT("
SET DIC(0)="AEQMZ"
DO ^DIC
if X=""!(X[U)!(Y'>0)
GOTO Q
if $DATA(DTOUT)
GOTO ICDOUT
SET DFN=+Y
SET (DOB,AGE)=$PIECE(Y(0),U,3)
SET SEX=$PIECE(Y(0),U,2)
+2 DO TAC
if ICDQU
GOTO PAT
DO DAM
if ICDQU
GOTO PAT
EN1 ; Entry Point - Patient is known (DFN)
+1 IF $DATA(^DPT(DFN,.35))
IF $LENGTH(^DPT(DFN,.35))
DO ALIVE
if ICDQU
GOTO PAT
+2 SET ICDEXP=$SELECT($DATA(ICDEXP):ICDEXP,1:0)
+3 IF AGE]""
NEW %,X,X1,X2
SET X1=DT
SET X2=AGE
DO ^%DTC
SET AGE=X\365.25
WRITE " AGE: ",AGE
CD ;Prompt POA if ICD-10 DRG calculation
+1 SET ICDCSYS=$SELECT(ICDDATE'<$$IMPDATE^LEXU("10D"):"ICD10",1:"ICD9")
+2 DO ICDCD
if $GET(QUIT)
GOTO PAT
+3 if X[U
GOTO Q
OP ; PROCEDURE CODE SELECTION
+1 SET ICDCDSY=$SELECT(ICDCSYS="ICD9":2,1:31)
SET ICDCV="(ICD "_$PIECE(ICDCSYS,"ICD",2)_")"
+2 SET DIC("A")="Enter Operation/Procedure "_ICDCV_": "
+3 WRITE !
+4 FOR ICDNOR=1:1
Begin DoDot:1
+5 ;I ICDCSYS="ICD10" S ICDXX1=1 S ICDPRC="" D ASK^ICDCODLK K ICDXX1
+6 IF ICDCSYS="ICD10"
DO PROC
+7 IF ICDCSYS="ICD9"
SET ICDPRC=""
DO ICD9OP
End DoDot:1
if X=""!(X[U)
QUIT
if $DATA(DTOUT)
GOTO ICDOUT
IF X'=0
IF Y>0
SET ICDPRC(ICDNOR)=+Y
SET ICDSURG(ICDNOR)=X
+8 KILL DIC,ICDCDSY,ICDCV
if X["^"
GOTO Q
+9 ;Rearrange ICDPRC array
+10 SET X=0
SET ICDCNT=1
+11 FOR
SET X=$ORDER(ICDPRC(X))
if 'X
QUIT
Begin DoDot:1
+12 SET ICDPRCT(ICDCNT)=ICDPRC(X)
+13 SET ICDCNT=ICDCNT+1
End DoDot:1
+14 KILL ICDPRC
+15 MERGE ICDPRC=ICDPRCT
+16 ;Rearrange ICDSURG array
+17 SET X=0
SET ICDCNT=1
+18 FOR
SET X=$ORDER(ICDSURG(X))
if 'X
QUIT
Begin DoDot:1
+19 SET ICDSURGT(ICDCNT)=ICDSURG(X)
+20 SET ICDCNT=ICDCNT+1
End DoDot:1
+21 KILL ICDSURG
+22 MERGE ICDSURG=ICDSURGT
+23 ;
+24 IF ICDCSYS="ICD10"
MERGE ICDDXZ=ICDDX,ICDPRCZ=ICDPRC,ICDPOAZ=ICDPOA
+25 DO ^ICDDRG
+26 DO WRT
+27 IF ICDCSYS="ICD10"
KILL ICDEXP,SEX,ICDDX,ICDSURG,ICDPOA,ICDPRC,ICDDXZ,ICDPRCZ,ICDPOAZ,ICDPRCT,ICDCNT,ICDSURGT
+28 GOTO PAT0
WRT ; new CSV code
SET ICDDRG(0)=$$DRG^ICDEX(+ICDDRG,ICDDATE)
+1 IF ICDCSYS="ICD10"
Begin DoDot:1
+2 SET ICDTMP=$$ICDDX^ICDEX(ICDDXZ(1),ICDDATE,"10D","I")
+3 WRITE !,"Principal Diagnosis: ",$PIECE(ICDTMP,U,2),?30,$EXTRACT($$VST^ICDEX(80,ICDDXZ(1),ICDDATE),1,44),?75,"POA=",$SELECT($GET(ICDPOAZ(1))'="":ICDPOAZ(1),1:"-")
+4 FOR ICDI=2:1
if '$DATA(ICDDXZ(ICDI))
QUIT
Begin DoDot:2
+5 SET ICDTMP=$$ICDDX^ICDEX(ICDDXZ(ICDI),ICDDATE,"10D","I")
+6 if ICDI=2
WRITE !,"Secondary Diagnosis: "
if ICDI>2
WRITE !?21
WRITE $PIECE(ICDTMP,U,2),?30,$EXTRACT($$VST^ICDEX(80,ICDDXZ(ICDI),ICDDATE),1,44),?75,"POA=",$SELECT($GET(ICDPOAZ(ICDI))'="":ICDPOAZ(ICDI),1:"-")
End DoDot:2
+7 FOR ICDI=1:1
if '$DATA(ICDPRCZ(ICDI))
QUIT
Begin DoDot:2
+8 SET ICDTMP=$$ICDOP^ICDEX(ICDPRCZ(ICDI),ICDDATE,"10P","I")
+9 if ICDI=1
WRITE !!,"Procedure Code: "
if ICDI>1
WRITE !
WRITE ?21,$PIECE(ICDTMP,U,2),?30,$EXTRACT($$VST^ICDEX(80.1,ICDPRCZ(ICDI),ICDDATE),1,50)
End DoDot:2
End DoDot:1
+10 WRITE !!?9,"Effective Date: "," ",ICDDSP
+11 WRITE !,"Diagnosis Related Group: ",$JUSTIFY(ICDDRG,6),?40,"Avg len of stay: ",$JUSTIFY($PIECE(ICDDRG(0),"^",8),6)
+12 WRITE !?17,"Weight: ",$JUSTIFY($PIECE(ICDDRG(0),"^",2),6),?40,"Local Breakeven: ",$JUSTIFY($PIECE(ICDDRG(0),"^",12),6)
+13 WRITE !?12," Low day(s): ",$JUSTIFY($PIECE(ICDDRG(0),"^",3),6),?39,"Local low day(s): ",$JUSTIFY($PIECE(ICDDRG(0),"^",9),6)
+14 WRITE !?13," High days: ",$JUSTIFY($PIECE(ICDDRG(0),"^",4),6),?40,"Local High days: ",$JUSTIFY($PIECE(ICDDRG(0),"^",10),6)
+15 ;W !!,"DRG: ",ICDDRG,"-" F I=0:0 S I=$N(^ICD(ICDDRG,1,I)) Q:I'>0 W ?10,$P(^(I,0),U,1),!
+16 ;W !!,"DRG: ",ICDDRG,"-" F I=0:0 S I=$O(^ICD(ICDDRG,1,I)) Q:(I="")!(I'?.N) W ?10,$P(^(I,0),U,1),!
+17 NEW ICDXD,ICDGDX,ICDGI
+18 SET ICDXD=$$DRGD^ICDEX(ICDDRG,"ICDGDX",ICDDATE)
SET ICDGI=0
+19 WRITE !!,"DRG: ",ICDDRG,"-"
FOR
SET ICDGI=$ORDER(ICDGDX(ICDGI))
if '+ICDGI
QUIT
if ICDGDX(ICDGI)=" "
QUIT
WRITE ?10,ICDGDX(ICDGI),!
+20 QUIT
ERROR DO WRT
+1 IF ICDRTC<5
WRITE !!,"Invalid ",$SELECT(ICDRTC=1:"Principal Diagnosis",ICDRTC=2:"Operation/Procedure",ICDRTC=3:"Age",ICDRTC=4:"Sex",1:"")
GOTO PAT0
+2 IF ICDRTC=5
WRITE !!,"Grouper needs to know if patient died during this episode!"
GOTO PAT0
+3 IF ICDRTC=6
WRITE !!,"Grouper needs to know if patient was transferred to an acute care facility!"
GOTO PAT0
+4 IF ICDRTC=7
WRITE !!,"Grouper needs to know if patient was discharged against medical advice!"
GOTO PAT0
+5 IF ICDRTC=8
WRITE !!,"Patient assigned newborn diagnosis code. Check diagnosis!"
GOTO PAT0
+6 GOTO PAT0
KILL KILL DIC,DFN,DUOUT,DTOUT,ICDNOR,ICDDX,ICDPRC,ICDEXP,ICDTRS,ICDDMS,ICDDRG,ICDMDC,ICDO24,ICDP24,ICDP25,ICDRTC,ICDPT,ICDQU,ICDSD,ICDNMDC
+1 KILL ICDMAJ,ICDS25,ICDSEX,AGE,DOB,CC,HICDRG,ICD,ICDCC3,ICDJ,ICDJJ,ICDL39,ICDFZ,ICDDT,ICDDSP,IENT,QUIT
+2 QUIT
Q GOTO PAT
AGE SET DIR(0)="NOA^0:124:0"
SET DIR("A")="Patient's age: "
SET DIR("?")="Enter how old the patient is (0-124)."
DO ^DIR
KILL DIR
SET AGE=Y
if $DATA(DUOUT)
GOTO QQ
if $DATA(DTOUT)
GOTO ICDOUT
+1 QUIT
ALIVE SET DIR(0)="YO"
SET DIR("A")="Did patient die during this episode"
DO ^DIR
KILL DIR
SET ICDEXP=Y
if $DATA(DUOUT)
GOTO QQ
if $DATA(DTOUT)
GOTO ICDOUT
+1 QUIT
TAC SET DIR(0)="YO"
SET DIR("A")="Was patient transferred to an acute care facility"
DO ^DIR
KILL DIR
SET ICDTRS=Y
if $DATA(DUOUT)
GOTO QQ
if $DATA(DTOUT)
GOTO ICDOUT
+1 QUIT
DAM SET DIR(0)="YO"
SET DIR("A")="Was patient discharged against medical advice"
DO ^DIR
KILL DIR
SET ICDDMS=Y
if $DATA(DUOUT)
GOTO QQ
if $DATA(DTOUT)
GOTO ICDOUT
+1 QUIT
SEX SET DIR(0)="SBO^M:MALE;F:FEMALE"
SET DIR("?")="Enter M for Male and F for Female"
SET DIR("A")="Patient's Sex"
DO ^DIR
KILL DIR
SET SEX=Y
if $DATA(DUOUT)
GOTO QQ
if $DATA(DTOUT)
GOTO ICDOUT
+1 QUIT
QQ SET ICDQU=1
QUIT
EFFDATE ;prompts for effective date for DRG grouper?
+1 KILL DIR
SET DIR(0)="D^::AEX"
SET DIR("B")="TODAY"
SET DIR("A")="Effective Date"
+2 SET DIR("?")="The effective to be used when calculating the DRG code for the patient."
+3 DO ^DIR
KILL DIR
IF $DATA(DIRUT)
SET QUIT=1
QUIT
+4 SET ICDDATE=Y
SET ICDDSP=Y(0)
+5 QUIT
ASK KILL DTOUT,DUOUT
DO AGE
if ICDQU
GOTO PAT
DO ALIVE
if ICDQU
GOTO PAT
DO TAC
if ICDQU
GOTO PAT
DO DAM
if ICDQU
GOTO PAT
DO SEX
if ICDQU
GOTO PAT
GOTO CD
ICDOUT GOTO H^XUS
+1 ;
ICDCD ;prompts for ICD diagnosis codes; ALB/JAM *64 ICD10 changes
+1 NEW ICDPDXV,ICDSDXV,ICDDXPOA,ICDSD,ICDSC
+2 SET ICDSC="(ICD "_$PIECE(ICDCSYS,"ICD",2)_")"
+3 SET ICDPDXV=$$ICDPDX
if $GET(QUIT)!(ICDPDXV<0)
QUIT
SET ICDDX(1)=ICDPDXV
+4 ;if ICD9 code skip POA question
+5 IF ICDCSYS="ICD9"
GOTO ICDSDXV
+6 SET ICDDXPOA=$$POA(ICDPDXV)
if $GET(QUIT)
QUIT
SET ICDPOA(1)=$TRANSLATE(ICDDXPOA,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
ICDSDXV FOR ICDSD=2:1
SET ICDSDXV=$$ICDSDX
if $GET(QUIT)!(ICDSDXV'>0)
QUIT
SET ICDDX(ICDSD)=ICDSDXV
Begin DoDot:1
+1 ; if ICD9 code skip POA question
+2 IF ICDCSYS="ICD9"
QUIT
+3 SET ICDDXPOA=$$POA(ICDSDXV)
if $GET(QUIT)
QUIT
SET ICDPOA(ICDSD)=$TRANSLATE(ICDDXPOA,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
End DoDot:1
if $GET(QUIT)
QUIT
+4 QUIT
+5 ;
+6 ; Get ICD Principal Diagnosis Code
ICDPDX() ;
+1 NEW DIC,ICDCDSY,IENT,ICDSVAL,ICDPRI
+2 NEW ICDDSCR,ICDQUIT
+3 SET ICDQUIT=0
+4 SET ICDDSCR="Enter Principal diagnosis "_ICDSC_": "
+5 SET ICDCDSY=$SELECT(ICDCSYS="ICD9":1,1:30)
+6 ;if ICD-10
+7 IF ICDCSYS="ICD10"
Begin DoDot:1
+8 ;if was aborted in the list then don't set QUIT=1, if aborted in the search string prompt then set QUIT=1
+9 FOR
SET ICDSVAL=$$ICD10SRH(ICDDSCR,ICDDATE)
if $GET(ICDSVAL)>0
QUIT
if (ICDSVAL=-11)!(ICDSVAL=-2)!(ICDSVAL=0)
SET (ICDQUIT,QUIT)=1
if ICDQUIT=1
QUIT
End DoDot:1
QUIT ICDSVAL
+10 ;if ICD-9
+11 SET IENT="I"
SET ICDPRI="Y"
+12 SET DIC=$$ROOT^ICDEX(80)
SET DIC(0)="AEQMZI"
+13 SET DIC("A")=ICDDSCR
+14 SET DIC("S")="I $P($$ICDDX^ICDEX(+$G(Y),$G(ICDDATE),ICDCDSY,IENT),U,1)>0,$P($$ICDDX^ICDEX(+$G(Y),$G(ICDDATE),ICDCDSY,IENT),U,10),'$P($$ICDDX^ICDEX(+$G(Y),ICDDATE,ICDCDSY,IENT),U,5)"
+15 SET Y=$$SEARCH^ICDSAPI(80,DIC("S"),DIC(0),$GET(ICDDATE))
+16 IF Y<=0
SET QUIT=1
QUIT -1
+17 QUIT +Y
+18 ;
+19 ;Get ICD Secondary Diagnoses Codes
ICDSDX() ;
+1 NEW DIC,ICDCDSY,IENT,ICDSVAL
+2 NEW ICDDSCR,ICDQUIT
+3 SET ICDQUIT=0
+4 SET ICDDSCR="Enter SECONDARY diagnosis "_ICDSC_": "
+5 SET ICDCDSY=$SELECT(ICDCSYS="ICD9":1,1:30)
+6 ;if ICD-10
+7 IF ICDCSYS="ICD10"
Begin DoDot:1
+8 ;if was aborted in the list then don't set QUIT=1, if aborted in the search string prompt then set QUIT=1
+9 FOR
SET ICDSVAL=$$ICD10SRH(ICDDSCR,ICDDATE)
if $GET(ICDSVAL)>0
QUIT
if ICDSVAL=0!(ICDSVAL=-2)
SET ICDQUIT=1
if ICDSVAL=-11
SET (ICDQUIT,QUIT)=1
if ICDQUIT=1
QUIT
End DoDot:1
QUIT ICDSVAL
+10 ;if ICD-9
+11 SET IENT="I"
+12 SET DIC=$$ROOT^ICDEX(80)
SET DIC(0)="AEQMZI"
+13 SET DIC("A")=ICDDSCR
+14 SET DIC("S")="I $P($$ICDDX^ICDEX(+$G(Y),$G(ICDDATE),ICDCDSY,IENT),U,1)>0,$P($$ICDDX^ICDEX(+$G(Y),$G(ICDDATE),ICDCDSY,IENT),U,10)"
+15 SET Y=$$SEARCH^ICDSAPI(80,DIC("S"),DIC(0),$GET(ICDDATE))
+16 IF $DATA(DTOUT)
SET QUIT=1
QUIT -1
+17 IF Y>0
QUIT +Y
+18 QUIT -1
+19 ;
+20 ;
+21 ;Ask for diagnosis
+22 ;ICDTINT - date of interest
+23 ;ICDPROM - prompt
+24 ;
+25 ;returns -11 if user has entered one of these - ^ ^^ or null
+26 ; -4 user doesn't want to continue
+27 ; -11 aborted by ^ or ^^ when the user enters the search sring (wants to quit from the prompt to the previous level)
+28 ; -3 aborted by ^ or ^^ during selection of the items on the list
+29 ; -2 Timed out
+30 ; -9 User entered only one character
+31 ; -1 User entered Blank in the list of selection
+32 ; -10 User entered invalid data in the list of selection
ICD10SRH(ICDPROM,ICDTINT) ; Lexicon Partial Code Search
+1 NEW ICDUSTR,ICDPARAM
+2 ;set parameters for partial LEXICON search
+3 DO SETPARAM^ICDDSLK(.ICDPARAM)
+4 ;if prompt provided the getusers input,
+5 ; return -11 to indicate that user wants to quit from the prompt to the previous level
+6 ; return 0 to indicate that user pressed Enter in the primary diag prompt it means he wants to quit from the prompt to the previous level,
+7 ; in secondary - wants to skip secodary diags
+8 ; otherwise call STS API for partial LEXICON search
+9 Begin DoDot:1
+10 ;repeat if less than 2 chars and wasn't aborted by ^,^^ or null (Enter key pressed)
FOR
SET ICDUSTR=$$GETUSINP(ICDPROM)
if ICDUSTR'=-22
QUIT
End DoDot:1
if ICDUSTR'>0
QUIT ICDUSTR
SET ICDY=$$LEXICD10^ICDDSLK($PIECE(ICDUSTR,U,2),ICDTINT,.ICDPARAM)
+11 ; User entered only one character
+12 IF ICDY=-9
QUIT -9
+13 ; User entered Blank
+14 IF ICDY=-1
QUIT -1
+15 ; User entered invalid data
+16 IF ICDY=""
WRITE !!,ICDPARAM("NO DATA FOUND")
QUIT -12
+17 ; aborted by ^ or ^^
+18 IF ICDY=-3
QUIT -3
+19 ; Timed out
+20 IF ICDY=-2
QUIT -2
+21 ; User doesn't want to continue
+22 IF ICDY=-4
QUIT -4
+23 ; otherwise get the IEN of the selected code
+24 KILL DIC
+25 SET ICDY=+$$CODEN^ICDEX($PIECE($PIECE(ICDY,";",2),U,1),80)
+26 QUIT +ICDY
+27 ;
+28 ;Get user input
+29 ;returns:
+30 ; "-2" timeout
+31 ; "-11" user entered ^ or ^^
+32 ; "-22" user entered less than 2 chars
+33 ; 0 user entered null
+34 ; 1 user entered more than 2 chars
GETUSINP(ICDPRMPT) ;
+1 NEW DIR
+2 SET DIR("A")=ICDPRMPT
+3 SET DIR(0)="FAO^0:245"
+4 SET DIR("?")="^D INPHLP^ICDDSLK"
+5 SET DIR("??")="^D INPHLP^ICDDSLK"
+6 DO ^DIR
+7 ;timeout
IF $DATA(DTOUT)
QUIT -2
+8 ; user entered null
IF Y=""
QUIT 0
+9 ; user entered ^ or ^^
IF Y["^"
QUIT -11
+10 IF $LENGTH(Y)'>1
WRITE !,"Please enter at least the first two characters of the ICD-10 code or code description to start the search."
QUIT -22
+11 QUIT "1"_U_Y
+12 ;
GETIDX(ICDCSYS,ICDCODE,ICDT) ;
+1 NEW ICDICDX
+2 SET ICDICDX=$$ICDDATA^ICDXCODE(ICDCSYS,ICDCODE,ICDT)
+3 IF ICDICDX<1
QUIT $PIECE(ICDICDX,U,2)
+4 QUIT $PIECE(ICDICDX,U)_U_$PIECE(ICDICDX,U,4)
+5 ;
POA(ICDDX123) ; Present On Admission
+1 NEW DIR,X,Y,ICDPR
+2 SET QUIT=0
SET DIR("A")="Present on Admission: "
SET DIR(0)="SOA^Y:YES;N:NO;U:Unknown;W:Clinically undetermined"
+3 KILL DIR
SET QUIT=0
SET DIR("A")="Present on Admission: "
SET DIR(0)="SOA^Y:YES;N:NO;U:Unknown;W:Clinically undetermined"
+4 SET (DIR("?"),DIR("??"))="^D HELPPOA^ICDDRGM"
+5 DO ^DIR
+6 IF ($DATA(DTOUT))!($DATA(DUOUT))!($DATA(DIROUT))
SET QUIT=1
QUIT -1
+7 IF X=""
Begin DoDot:1
+8 ;Not POA Exempt
IF $$GET1^DIQ(80,ICDDX123,1.9,"I")'=1
Begin DoDot:2
+9 SET ICDPR(1)="Diagnosis "_$$GET1^DIQ(80,ICDDX123,.01,"I")_" is not contained in the POA Exempt list so the POA field should"
+10 SET ICDPR(2)="not be blank. If left blank, it will be treated as if it were a No (""N"")."
+11 DO EN^DDIOL(.ICDPR)
+12 KILL DIR
SET DIR(0)="Y"
SET DIR("A")="Do you wish to continue? (Y/N)"
SET DIR("B")="YES"
DO ^DIR
IF ($DATA(DTOUT))!($DATA(DUOUT))!($DATA(DIROUT))
SET QUIT=1
+13 IF Y=0
SET QUIT=1
QUIT
+14 ;This may subsequently be removed if the DX is on the HAC list - see $$HAC^ICDDRGM
SET Y="N"
End DoDot:2
+15 IF '$TEST
SET Y="Y"
End DoDot:1
+16 IF '$TEST
SET Y=X
+17 IF QUIT
QUIT -1
+18 QUIT Y
+19 ;
DXSCRN ;Diagnoses review of POA and HAC indicators; ALB/JAM *64 ICD10 changes
+1 NEW I,X,ICDDX123,ICDTMPX,ICDTMPOA,C,ICDOUT
+2 ;if POA value does not exist for Primary DX set to "U"nknown
+3 IF '$DATA(ICDPOA(1))
SET ICDPOA(1)="U"
+4 SET X=1
+5 FOR
SET X=$ORDER(ICDDX(X))
if 'X
QUIT
SET ICDOUT=0
Begin DoDot:1
+6 ;if POA value does not exist for DX set to "U"nknown
+7 IF '$DATA(ICDPOA(X))
SET ICDPOA(X)="U"
+8 ;if DX is POA exempt include in DRG calculation
+9 SET ICDDX123=ICDDX(X)
IF $$GET1^DIQ(80,ICDDX123,1.9,"I")
QUIT
+10 ;if POA value for DX is Y or W include in DRG calculation
+11 FOR I="Y","W"
IF ICDPOA(X)=I
SET ICDOUT=1
QUIT
+12 IF ICDOUT
QUIT
+13 ;if DX not in HAC list include in DRG calculation
+14 FOR I="N","U",1
IF ICDPOA(X)=I
IF '$$HAC(ICDDX123)
SET ICDOUT=1
QUIT
+15 IF ICDOUT
QUIT
+16 IF ICDPOA(X)=""
IF '$$HAC(ICDDX123)
SET ICDOUT=1
QUIT
+17 IF ICDOUT
QUIT
+18 ; remove entry from ICDDX and ICDPOA array
+19 KILL ICDDX(X),ICDPOA(X)
End DoDot:1
+20 ; resequence entries in ICDDX and ICDPOA array
+21 MERGE ICDTMPX=ICDDX,ICDTMPOA=ICDPOA
+22 KILL ICDDX,ICDPOA
+23 SET C=0
+24 SET X=0
FOR
SET X=$ORDER(ICDTMPX(X))
if 'X
QUIT
SET C=C+1
SET ICDDX(C)=ICDTMPX(X)
SET ICDPOA(C)=ICDTMPOA(X)
+25 QUIT
+26 ;
HAC(ICDDX123) ; Check if diagnosis code is in Hospital Acquired Conditions (HACS) file #80.6
+1 ;Input DX - Diagnosis code IEN, pointer to file #80
+2 ;Output - 1 if the DX code is found in file #80.6
+3 ; 0 if the DX code not found in the file
+4 ;
+5 IF $DATA(^ICDHAC("C",ICDDX123))
QUIT 1
+6 QUIT 0
+7 ;
ICD9OP ; ICD-9 PROCEDURE CODE SEARCH
+1 SET IENT="I"
+2 SET DIC("S")="I $P($$ICDOP^ICDEX(+$G(Y),$G(ICDDATE),ICDCDSY,IENT),U,1)>0,+$P($$ICDOP^ICDEX(+$G(Y),$G(ICDDATE),ICDCDSY,IENT),U,10)'=0"
+3 SET DIC("A")="Enter Operation/Procedure "_ICDCV_": "
+4 ;,DIC("S")="I $P($$ICDOP^ICDEX($G(Y),$G(ICDDATE),ICDCDSY,IENT),U,1)>0"
SET DIC(0)="AEQMZI"
+5 SET Y=$$SEARCH^ICDSAPI(80.1,DIC("S"),DIC(0),$GET(ICDDATE))
+6 QUIT
+7 ;
HELPPOA ;
+1 WRITE !?5,"Apply the Present on Admission (POA) indicator for each diagnosis"
+2 WRITE !?5,"and external cause of injury code(s) reported as the final set of"
+3 WRITE !?5,"diagnosis codes assigned. One of the following values should be"
+4 WRITE !?5,"assigned in accordance with the official coding guidelines:"
+5 WRITE !?5,""
+6 WRITE !?5,"Y = present at the time of inpatient admission;"
+7 WRITE !?5,"N = not present at the time of inpatient admission;"
+8 WRITE !?5,"U = documentation is insufficient to determine if"
+9 WRITE !?5," condition is present on admission;"
+10 WRITE !?5,"W = provider is unable to clinically determine"
+11 WRITE !?5," whether condition was present on admission or not"
+12 WRITE !?5,"<enter> = use only if diagnosis is exempt from POA reporting"
+13 QUIT
+14 ;
PROC ; Ask Procedure
+1 NEW DIR,ICDXX1
+2 SET ICDXX1=1
SET ICDPRC=""
+3 SET DIR(0)="FAO^1:12"
+4 SET DIR("A")="Enter Operation/Procedure (ICD 10):"
+5 SET DIR("?")="^D P1^ICDDRGM"
SET DIR("??")="^D P2^ICDDRGM"
+6 DO ^DIR
+7 IF $DATA(DTOUT)!($DATA(DUOUT))!($DATA(DIRUT))!($DATA(DIROUT))!(Y="")
SET Y=-1
QUIT
+8 ;I X["*" S X=$P(X,"*",1)
+9 SET ICDPRC=X
+10 ;I X["*" S X=$P(X,"*",1)_$P(X,"*",2)
+11 DO ASK^ICDCODLK
+12 QUIT Y
P1 ;
+1 ;For calls from ^DIR, doesn't support ??? help
IF X["???"
DO P3
QUIT
+2 IF X["??"
DO P2
QUIT
+3 DO EN^DDIOL("Enter the initial character(s) of an ICD-10 partial code or an","","!?5")
+4 DO EN^DDIOL("asterisk (*) for more information.","","!?5")
+5 DO EN^DDIOL(" ")
+6 QUIT
+7 ;
P2 ;
+1 DO EN^DDIOL("1. Enter an ICD-10 Procedure Code.","","!?8")
+2 DO EN^DDIOL(" or ","","!?8")
+3 DO EN^DDIOL("2. Enter any alphanumeric char values of the procedure code to 'build'","","!?8")
+4 DO EN^DDIOL(" an ICD-10 Procedure Code.","","!?8")
+5 DO EN^DDIOL(" or ","","!?8")
+6 DO EN^DDIOL("3. Enter an asterisk (*) to initiate a procedure code build search. ","","!?8")
+7 DO EN^DDIOL(" ")
+8 QUIT
+9 ;
P3 ;
+1 DO EN^DDIOL("The procedure code search provides a 'decision tree' type structure","","!?8")
+2 DO EN^DDIOL("that makes use of the specific ICD-10-PCS code format and structure,","","!?8")
+3 DO EN^DDIOL("where all codes consist of 7 alphanumeric characters, with each","","!?8")
+4 DO EN^DDIOL("position in the code having a specific meaning.","","!?8")
+5 DO EN^DDIOL(" ")
+6 QUIT
+7 ;
