Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: ICDDRGM

ICDDRGM.m

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