- ICDIDX2 ;DLS/DEK - MUMPS Cross Reference Routine for History ;04/21/2014
- ;;18.0;DRG Grouper;**57**;Oct 20, 2000;Build 1
- ;
- ; Global Variables
- ; None
- ;
- ; External References
- ; None
- ;
- ; Common Variables used:
- ;
- ; ICDCOD ICD Code from Global
- ; ICDCODX ICD Code passed in (X)
- ; ICDEFF Effective Date
- ; ICDSTA Status
- ; ICDNOD Global Node (to reduce Global hits)
- ; DA IEN file 80, 80.1, 80.066 or 80.166
- ; ICDIEN,DA(1) IEN of file 80 or 80.1
- ; ICDHIS IEN of file 80.066 or 80.166
- ; X Data passed in to be indexed
- ;
- Q
- SAHC(ICD) ; Code .01 ACT1 Set
- N ICDNOD,ICDSTA,ICDEFF,ICDCOD,ICDCODX,ICDHIS,ICDIEN,ICDSYS,RT,EXC
- S RT=$$RT($G(ICD)) Q:'$L(RT) S EXC=$$EXC(+($G(DA)),RT) Q:+EXC'>0
- S ICDCODX=$G(X) Q:'$L(ICDCODX) S ICDIEN=+($G(DA)) Q:+ICDIEN'>0
- Q:'$D(@(RT_+ICDIEN_",66)"))
- S ICDHIS=0 F S ICDHIS=$O(@(RT_+ICDIEN_",66,"_ICDHIS_")")) Q:+ICDHIS=0 D
- . N DA,ICDSYS,X S DA=+ICDHIS,DA(1)=+ICDIEN D HDC
- . S ICDCOD=ICDCODX Q:'$L($G(ICDCOD))
- . Q:'$L($G(ICDEFF)) Q:'$L($G(ICDSTA)) K ICDSYS D SHIS
- . S ICDSYS=+($P($G(@(RT_+($G(DA(1)))_",1)")),"^",1)) D:+ICDSYS>0 SHIS
- Q
- KAHC(ICD) ; Code .01 ACT1 Kill
- N ICDNOD,ICDSTA,ICDEFF,ICDCOD,ICDCODX,ICDHIS,ICDIEN,ICDSYS,RT
- S RT=$$RT($G(ICD)) Q:'$L(RT) S ICDCODX=$G(X) Q:'$L(ICDCODX)
- S ICDIEN=+($G(DA)) Q:+ICDIEN'>0 Q:'$D(@(RT_+ICDIEN_",66)"))
- S ICDHIS=0 F S ICDHIS=$O(@(RT_+ICDIEN_",66,"_ICDHIS_")")) Q:+ICDHIS=0 D
- . N DA,X S DA=+ICDHIS,DA(1)=+ICDIEN D HDC
- . S ICDCOD=ICDCODX Q:'$L($G(ICDCOD))
- . Q:'$L($G(ICDEFF)) Q:'$L($G(ICDSTA)) K ICDSYS D KHIS
- . S ICDSYS=+($P($G(@(RT_+($G(DA(1)))_",1)")),"^",1)) D:+ICDSYS>0 KHIS
- Q
- SAHD(ICD) ; Effective Date 66,.01 ACT2 Set
- S RT=$$RT($G(ICD)) Q:'$L(RT) S EXC=$$EXC(+($G(DA(1))),RT) Q:+EXC'>0
- N ICDNOD,ICDSTA,ICDEFF,ICDCOD,ICDSYS
- D HDC Q:'$L($G(ICDCOD)) Q:'$L($G(ICDSTA)) S ICDEFF=+($G(X)) Q:+ICDEFF=0 K ICDSYS D SHIS
- S ICDSYS=+($P($G(@(RT_+($G(DA(1)))_",1)")),"^",1)) D:+ICDSYS>0 SHIS
- Q
- KAHD(ICD) ; Effective Date 66,.01 ACT2 Kill
- N ICDNOD,ICDSTA,ICDEFF,ICDCOD,ICDSYS
- S RT=$$RT($G(ICD)) Q:'$L(RT) D HDC Q:'$L($G(ICDCOD)) Q:'$L($G(ICDSTA))
- S ICDEFF=+($G(X)) Q:+ICDEFF=0 K ICDSYS D KHIS
- S ICDSYS=+($P($G(@(RT_+($G(DA(1)))_",1)")),"^",1)) D:+ICDSYS>0 KHIS
- Q
- SAHS(ICD) ; Status 66,.02 ACT3 Set
- N ICDNOD,ICDSTA,ICDEFF,ICDCOD,ICDSYS,RT,EXC
- S RT=$$RT($G(ICD)) Q:'$L(RT) S EXC=$$EXC(+($G(DA(1))),RT) Q:+EXC'>0
- D HDC Q:'$L($G(ICDCOD)) Q:+ICDEFF=0
- S ICDSTA=$G(X) Q:'$L(ICDSTA) K ICDSYS D SHIS
- S ICDSYS=+($P($G(@(RT_+($G(DA(1)))_",1)")),"^",1)) D:+ICDSYS>0 SHIS
- Q
- KAHS(ICD) ; Status 66,.02 ACT3 Kill
- N ICDNOD,ICDSTA,ICDEFF,ICDCOD,ICDSYS,ICDSYS,RT
- S RT=$$RT($G(ICD)) Q:'$L(RT)
- D HDC Q:'$L($G(ICDCOD)) Q:+ICDEFF=0
- S ICDSTA=$G(X) Q:'$L(ICDSTA) K ICDSYS D KHIS
- S ICDSYS=+($P($G(@(RT_+($G(DA(1)))_",1)")),"^",1)) D:+ICDSYS>0 KHIS
- Q
- SAHCS(ICD) ; Coding System 1.1 ACT4 Set
- N ICDNOD,ICDSTA,ICDEFF,ICDCOD,ICDCODX,ICDHIS,ICDIEN,ICDSYS,RT,EXC
- S RT=$$RT($G(ICD)) Q:'$L(RT) S EXC=$$EXC(+($G(DA)),RT) Q:+EXC'>0
- S ICDSYS=$G(X) Q:'$L(ICDSYS) S ICDIEN=+($G(DA)) Q:+ICDIEN'>0
- S EXC=$$EXC(DA) Q:+EXC'>0 Q:'$D(@(RT_+ICDIEN_",66)"))
- S ICDHIS=0 F S ICDHIS=$O(@(RT_+ICDIEN_",66,"_ICDHIS_")")) Q:+ICDHIS=0 D
- . N DA,X S DA=+ICDHIS,DA(1)=+ICDIEN D HDC
- . S ICDCOD=$P($G(@(RT_+ICDIEN_",0)")),"^",1) Q:'$L($G(ICDCOD))
- . Q:'$L($G(ICDEFF)) Q:'$L($G(ICDSTA)) D SHIS
- Q
- KAHCS(ICD) ; Coding System 1.1 ACT4 Kill
- N ICDNOD,ICDSTA,ICDEFF,ICDCOD,ICDCODX,ICDHIS,ICDIEN,ICDSYS,RT
- S RT=$$RT($G(ICD)) Q:'$L(RT) S ICDSYS=$G(X) Q:'$L(ICDSYS)
- S ICDIEN=+($G(DA)) Q:+ICDIEN'>0 Q:'$D(@(RT_+ICDIEN_",66)"))
- S ICDHIS=0 F S ICDHIS=$O(@(RT_+ICDIEN_",66,"_ICDHIS_")")) Q:+ICDHIS=0 D
- . N DA,X S DA=+ICDHIS,DA(1)=+ICDIEN D HDC
- . S ICDCOD=$P($G(@(RT_+ICDIEN_",0)")),"^",1) Q:'$L($G(ICDCOD))
- . Q:'$L($G(ICDEFF)) Q:'$L($G(ICDSTA)) D KHIS
- Q
- SNUM(ICD) ; Code .01 AN1 Set
- N RT,EXC,NUM,SYS
- S RT=$$RT($G(ICD)) Q:'$L(RT) S EXC=$$EXC(+($G(DA)),RT) Q:+EXC'>0
- S SYS=+($P($G(@(RT_+DA_",1)")),"^",1)) Q:+SYS'>0
- Q:'$L($G(X)) Q:+($G(DA))'>0
- S NUM=$$NUM^ICDEX(X) Q:+NUM'>0
- S @(RT_""""_"AN"_+SYS_""","_+NUM_","_+DA_")")=""
- Q
- KNUM(ICD) ; Code .01 AN1 Kill
- N RT,NUM,SYS
- S RT=$$RT($G(ICD)) Q:'$L(RT) S SYS=+($P($G(@(RT_+DA_",1)")),"^",1)) Q:+SYS'>0
- Q:'$L($G(X)) Q:+($G(DA))'>0 S NUM=$$NUM^ICDEX(X) Q:+NUM'>0
- K @(RT_""""_"AN"_+SYS_""","_+NUM_","_+DA_")")
- Q
- SNUM2(ICD) ; Coding System 1.1 AN2 Set
- N RT,EXC,NUM,SYS,COD S SYS=+($G(X)) Q:+SYS'>0 Q:+($G(DA))'>0
- S RT=$$RT($G(ICD)) Q:'$L(RT) S EXC=$$EXC(+($G(DA)),RT) Q:+EXC'>0
- S COD=$P($G(@(RT_+DA_",0)")),"^",1) Q:'$L(COD)
- S NUM=$$NUM^ICDEX(COD) Q:+NUM'>0
- S @(RT_""""_"AN"_+SYS_""","_+NUM_","_+DA_")")=""
- Q
- KNUM2(ICD) ; Coding System 1.1 AN2 Kill
- N RT,EXC,NUM,SYS,COD S SYS=+($G(X)) Q:+SYS'>0 Q:+($G(DA))'>0
- S RT=$$RT($G(ICD)) Q:'$L(RT) S COD=$P($G(@(RT_+DA_",0)")),"^",1)
- Q:'$L(COD) S NUM=$$NUM^ICDEX(COD) Q:+NUM'>0
- K @(RT_""""_"AN"_+SYS_""","_+NUM_","_+DA_")")
- Q
- SSYS(ICD) ; Coding System - Static
- Q
- KSYS(ICD) ; Coding System - Static
- Q
- ;
- ; Miscellaneous
- HDC ; Set Common Variables (Code, Status and Effective Date)
- Q:'$L($G(RT)) S (ICDCOD,ICDSTA,ICDEFF)="" Q:'$L($G(RT))
- Q:+($G(DA(1)))'>0 Q:+($G(DA))'>0 Q:'$D(@(RT_+($G(DA(1)))_",66,"_+($G(DA))_",0)"))
- S ICDCOD=$P($G(@(RT_+($G(DA(1)))_",0)")),"^",1),ICDNOD=$G(@(RT_+($G(DA(1)))_",66,"_+($G(DA))_",0)"))
- S ICDSTA=$P(ICDNOD,"^",2),ICDEFF=$P(ICDNOD,"^",1)
- Q
- SHIS ; Set ^ROOT("ACT",<code>,<status>,<date>,<ien>,<history>)
- ; Set ^ROOT("ACTS",<sys>,<code>,<status>,<date>,<ien>,<history>)
- Q:'$L($G(RT)) N EXC Q:+($G(DA(1)))'>0 Q:+($G(DA))'>0
- Q:'$D(@(RT_+($G(DA(1)))_",66,"_+($G(DA))_",0)"))
- Q:'$L($G(ICDCOD)) Q:'$L($G(ICDSTA)) Q:'$L($G(ICDEFF))
- S @(RT_"""ACT"","""_(ICDCOD_" ")_""","_+ICDSTA_","_+ICDEFF_","_+DA(1)_","_+DA_")")=""
- S:+($G(ICDSYS))>0 @(RT_"""ACTS"","_+ICDSYS_","""_(ICDCOD_" ")_""","_+ICDSTA_","_+ICDEFF_","_+DA(1)_","_+DA_")")=""
- I +($G(ICDSYS))'>0 D
- . N SYS S SYS=+($P($G(@(RT_+DA(1)_",1)")),"^",1))
- . S:+SYS>0 @(RT_"""ACTS"","_+SYS_","""_(ICDCOD_" ")_""","_+ICDSTA_","_+ICDEFF_","_+DA(1)_","_+DA_")")=""
- Q
- KHIS ; Kill ^ROOT("ACT",<code>,<status>,<date>,<ien>,<history>)
- ; Kill ^ROOT("ACTS",<sys>,<code>,<status>,<date>,<ien>,<history>)
- Q:'$L($G(RT)) Q:+($G(DA(1)))'>0 Q:+($G(DA))'>0 Q:'$D(@(RT_+($G(DA(1)))_",66,"_+($G(DA))_",0)"))
- Q:'$L($G(ICDCOD)) Q:'$L($G(ICDSTA)) Q:'$L($G(ICDEFF))
- K @(RT_"""ACT"","""_(ICDCOD_" ")_""","_+ICDSTA_","_+ICDEFF_","_+DA(1)_","_+DA_")")
- K:+($G(ICDSYS))>0 @(RT_"""ACTS"","_+ICDSYS_","""_(ICDCOD_" ")_""","_+ICDSTA_","_+ICDEFF_","_+DA(1)_","_+DA_")")
- I +($G(ICDSYS))'>0 D
- . N SYS S SYS=+($P($G(@(RT_+DA(1)_",1)")),"^",1))
- . K:+SYS>0 @(RT_"""ACTS"","_+SYS_","""_(ICDCOD_" ")_""","_+ICDSTA_","_+ICDEFF_","_+DA(1)_","_+DA_")")
- Q
- EXC(X,Y) ; Exclude from lookup
- N COD,EFF,LDS,IEN,RT S IEN=+($G(X)),RT=$G(Y) Q:+IEN'>0 0 Q:'$L(RT) 0 S COD=$P($G(@(RT_+IEN_",0)")),"^",1)
- S EFF=$O(@(RT_+IEN_",66,0)")),LDS=$O(@(RT_+IEN_",68,0)")) Q:$L(COD)&(+EFF>0)&(+LDS>0) 1
- Q 0
- RT(X) ; Root from File #
- Q $S(+($G(X))=80:$$ROOT^ICDEX(80),+($G(X))=80.1:$$ROOT^ICDEX(80.1),1:"")
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HICDIDX2 7459 printed Feb 18, 2025@23:17:17 Page 2
- ICDIDX2 ;DLS/DEK - MUMPS Cross Reference Routine for History ;04/21/2014
- +1 ;;18.0;DRG Grouper;**57**;Oct 20, 2000;Build 1
- +2 ;
- +3 ; Global Variables
- +4 ; None
- +5 ;
- +6 ; External References
- +7 ; None
- +8 ;
- +9 ; Common Variables used:
- +10 ;
- +11 ; ICDCOD ICD Code from Global
- +12 ; ICDCODX ICD Code passed in (X)
- +13 ; ICDEFF Effective Date
- +14 ; ICDSTA Status
- +15 ; ICDNOD Global Node (to reduce Global hits)
- +16 ; DA IEN file 80, 80.1, 80.066 or 80.166
- +17 ; ICDIEN,DA(1) IEN of file 80 or 80.1
- +18 ; ICDHIS IEN of file 80.066 or 80.166
- +19 ; X Data passed in to be indexed
- +20 ;
- +21 QUIT
- SAHC(ICD) ; Code .01 ACT1 Set
- +1 NEW ICDNOD,ICDSTA,ICDEFF,ICDCOD,ICDCODX,ICDHIS,ICDIEN,ICDSYS,RT,EXC
- +2 SET RT=$$RT($GET(ICD))
- if '$LENGTH(RT)
- QUIT
- SET EXC=$$EXC(+($GET(DA)),RT)
- if +EXC'>0
- QUIT
- +3 SET ICDCODX=$GET(X)
- if '$LENGTH(ICDCODX)
- QUIT
- SET ICDIEN=+($GET(DA))
- if +ICDIEN'>0
- QUIT
- +4 if '$DATA(@(RT_+ICDIEN_",66)"))
- QUIT
- +5 SET ICDHIS=0
- FOR
- SET ICDHIS=$ORDER(@(RT_+ICDIEN_",66,"_ICDHIS_")"))
- if +ICDHIS=0
- QUIT
- Begin DoDot:1
- +6 NEW DA,ICDSYS,X
- SET DA=+ICDHIS
- SET DA(1)=+ICDIEN
- DO HDC
- +7 SET ICDCOD=ICDCODX
- if '$LENGTH($GET(ICDCOD))
- QUIT
- +8 if '$LENGTH($GET(ICDEFF))
- QUIT
- if '$LENGTH($GET(ICDSTA))
- QUIT
- KILL ICDSYS
- DO SHIS
- +9 SET ICDSYS=+($PIECE($GET(@(RT_+($GET(DA(1)))_",1)")),"^",1))
- if +ICDSYS>0
- DO SHIS
- End DoDot:1
- +10 QUIT
- KAHC(ICD) ; Code .01 ACT1 Kill
- +1 NEW ICDNOD,ICDSTA,ICDEFF,ICDCOD,ICDCODX,ICDHIS,ICDIEN,ICDSYS,RT
- +2 SET RT=$$RT($GET(ICD))
- if '$LENGTH(RT)
- QUIT
- SET ICDCODX=$GET(X)
- if '$LENGTH(ICDCODX)
- QUIT
- +3 SET ICDIEN=+($GET(DA))
- if +ICDIEN'>0
- QUIT
- if '$DATA(@(RT_+ICDIEN_",66)"))
- QUIT
- +4 SET ICDHIS=0
- FOR
- SET ICDHIS=$ORDER(@(RT_+ICDIEN_",66,"_ICDHIS_")"))
- if +ICDHIS=0
- QUIT
- Begin DoDot:1
- +5 NEW DA,X
- SET DA=+ICDHIS
- SET DA(1)=+ICDIEN
- DO HDC
- +6 SET ICDCOD=ICDCODX
- if '$LENGTH($GET(ICDCOD))
- QUIT
- +7 if '$LENGTH($GET(ICDEFF))
- QUIT
- if '$LENGTH($GET(ICDSTA))
- QUIT
- KILL ICDSYS
- DO KHIS
- +8 SET ICDSYS=+($PIECE($GET(@(RT_+($GET(DA(1)))_",1)")),"^",1))
- if +ICDSYS>0
- DO KHIS
- End DoDot:1
- +9 QUIT
- SAHD(ICD) ; Effective Date 66,.01 ACT2 Set
- +1 SET RT=$$RT($GET(ICD))
- if '$LENGTH(RT)
- QUIT
- SET EXC=$$EXC(+($GET(DA(1))),RT)
- if +EXC'>0
- QUIT
- +2 NEW ICDNOD,ICDSTA,ICDEFF,ICDCOD,ICDSYS
- +3 DO HDC
- if '$LENGTH($GET(ICDCOD))
- QUIT
- if '$LENGTH($GET(ICDSTA))
- QUIT
- SET ICDEFF=+($GET(X))
- if +ICDEFF=0
- QUIT
- KILL ICDSYS
- DO SHIS
- +4 SET ICDSYS=+($PIECE($GET(@(RT_+($GET(DA(1)))_",1)")),"^",1))
- if +ICDSYS>0
- DO SHIS
- +5 QUIT
- KAHD(ICD) ; Effective Date 66,.01 ACT2 Kill
- +1 NEW ICDNOD,ICDSTA,ICDEFF,ICDCOD,ICDSYS
- +2 SET RT=$$RT($GET(ICD))
- if '$LENGTH(RT)
- QUIT
- DO HDC
- if '$LENGTH($GET(ICDCOD))
- QUIT
- if '$LENGTH($GET(ICDSTA))
- QUIT
- +3 SET ICDEFF=+($GET(X))
- if +ICDEFF=0
- QUIT
- KILL ICDSYS
- DO KHIS
- +4 SET ICDSYS=+($PIECE($GET(@(RT_+($GET(DA(1)))_",1)")),"^",1))
- if +ICDSYS>0
- DO KHIS
- +5 QUIT
- SAHS(ICD) ; Status 66,.02 ACT3 Set
- +1 NEW ICDNOD,ICDSTA,ICDEFF,ICDCOD,ICDSYS,RT,EXC
- +2 SET RT=$$RT($GET(ICD))
- if '$LENGTH(RT)
- QUIT
- SET EXC=$$EXC(+($GET(DA(1))),RT)
- if +EXC'>0
- QUIT
- +3 DO HDC
- if '$LENGTH($GET(ICDCOD))
- QUIT
- if +ICDEFF=0
- QUIT
- +4 SET ICDSTA=$GET(X)
- if '$LENGTH(ICDSTA)
- QUIT
- KILL ICDSYS
- DO SHIS
- +5 SET ICDSYS=+($PIECE($GET(@(RT_+($GET(DA(1)))_",1)")),"^",1))
- if +ICDSYS>0
- DO SHIS
- +6 QUIT
- KAHS(ICD) ; Status 66,.02 ACT3 Kill
- +1 NEW ICDNOD,ICDSTA,ICDEFF,ICDCOD,ICDSYS,ICDSYS,RT
- +2 SET RT=$$RT($GET(ICD))
- if '$LENGTH(RT)
- QUIT
- +3 DO HDC
- if '$LENGTH($GET(ICDCOD))
- QUIT
- if +ICDEFF=0
- QUIT
- +4 SET ICDSTA=$GET(X)
- if '$LENGTH(ICDSTA)
- QUIT
- KILL ICDSYS
- DO KHIS
- +5 SET ICDSYS=+($PIECE($GET(@(RT_+($GET(DA(1)))_",1)")),"^",1))
- if +ICDSYS>0
- DO KHIS
- +6 QUIT
- SAHCS(ICD) ; Coding System 1.1 ACT4 Set
- +1 NEW ICDNOD,ICDSTA,ICDEFF,ICDCOD,ICDCODX,ICDHIS,ICDIEN,ICDSYS,RT,EXC
- +2 SET RT=$$RT($GET(ICD))
- if '$LENGTH(RT)
- QUIT
- SET EXC=$$EXC(+($GET(DA)),RT)
- if +EXC'>0
- QUIT
- +3 SET ICDSYS=$GET(X)
- if '$LENGTH(ICDSYS)
- QUIT
- SET ICDIEN=+($GET(DA))
- if +ICDIEN'>0
- QUIT
- +4 SET EXC=$$EXC(DA)
- if +EXC'>0
- QUIT
- if '$DATA(@(RT_+ICDIEN_",66)"))
- QUIT
- +5 SET ICDHIS=0
- FOR
- SET ICDHIS=$ORDER(@(RT_+ICDIEN_",66,"_ICDHIS_")"))
- if +ICDHIS=0
- QUIT
- Begin DoDot:1
- +6 NEW DA,X
- SET DA=+ICDHIS
- SET DA(1)=+ICDIEN
- DO HDC
- +7 SET ICDCOD=$PIECE($GET(@(RT_+ICDIEN_",0)")),"^",1)
- if '$LENGTH($GET(ICDCOD))
- QUIT
- +8 if '$LENGTH($GET(ICDEFF))
- QUIT
- if '$LENGTH($GET(ICDSTA))
- QUIT
- DO SHIS
- End DoDot:1
- +9 QUIT
- KAHCS(ICD) ; Coding System 1.1 ACT4 Kill
- +1 NEW ICDNOD,ICDSTA,ICDEFF,ICDCOD,ICDCODX,ICDHIS,ICDIEN,ICDSYS,RT
- +2 SET RT=$$RT($GET(ICD))
- if '$LENGTH(RT)
- QUIT
- SET ICDSYS=$GET(X)
- if '$LENGTH(ICDSYS)
- QUIT
- +3 SET ICDIEN=+($GET(DA))
- if +ICDIEN'>0
- QUIT
- if '$DATA(@(RT_+ICDIEN_",66)"))
- QUIT
- +4 SET ICDHIS=0
- FOR
- SET ICDHIS=$ORDER(@(RT_+ICDIEN_",66,"_ICDHIS_")"))
- if +ICDHIS=0
- QUIT
- Begin DoDot:1
- +5 NEW DA,X
- SET DA=+ICDHIS
- SET DA(1)=+ICDIEN
- DO HDC
- +6 SET ICDCOD=$PIECE($GET(@(RT_+ICDIEN_",0)")),"^",1)
- if '$LENGTH($GET(ICDCOD))
- QUIT
- +7 if '$LENGTH($GET(ICDEFF))
- QUIT
- if '$LENGTH($GET(ICDSTA))
- QUIT
- DO KHIS
- End DoDot:1
- +8 QUIT
- SNUM(ICD) ; Code .01 AN1 Set
- +1 NEW RT,EXC,NUM,SYS
- +2 SET RT=$$RT($GET(ICD))
- if '$LENGTH(RT)
- QUIT
- SET EXC=$$EXC(+($GET(DA)),RT)
- if +EXC'>0
- QUIT
- +3 SET SYS=+($PIECE($GET(@(RT_+DA_",1)")),"^",1))
- if +SYS'>0
- QUIT
- +4 if '$LENGTH($GET(X))
- QUIT
- if +($GET(DA))'>0
- QUIT
- +5 SET NUM=$$NUM^ICDEX(X)
- if +NUM'>0
- QUIT
- +6 SET @(RT_""""_"AN"_+SYS_""","_+NUM_","_+DA_")")=""
- +7 QUIT
- KNUM(ICD) ; Code .01 AN1 Kill
- +1 NEW RT,NUM,SYS
- +2 SET RT=$$RT($GET(ICD))
- if '$LENGTH(RT)
- QUIT
- SET SYS=+($PIECE($GET(@(RT_+DA_",1)")),"^",1))
- if +SYS'>0
- QUIT
- +3 if '$LENGTH($GET(X))
- QUIT
- if +($GET(DA))'>0
- QUIT
- SET NUM=$$NUM^ICDEX(X)
- if +NUM'>0
- QUIT
- +4 KILL @(RT_""""_"AN"_+SYS_""","_+NUM_","_+DA_")")
- +5 QUIT
- SNUM2(ICD) ; Coding System 1.1 AN2 Set
- +1 NEW RT,EXC,NUM,SYS,COD
- SET SYS=+($GET(X))
- if +SYS'>0
- QUIT
- if +($GET(DA))'>0
- QUIT
- +2 SET RT=$$RT($GET(ICD))
- if '$LENGTH(RT)
- QUIT
- SET EXC=$$EXC(+($GET(DA)),RT)
- if +EXC'>0
- QUIT
- +3 SET COD=$PIECE($GET(@(RT_+DA_",0)")),"^",1)
- if '$LENGTH(COD)
- QUIT
- +4 SET NUM=$$NUM^ICDEX(COD)
- if +NUM'>0
- QUIT
- +5 SET @(RT_""""_"AN"_+SYS_""","_+NUM_","_+DA_")")=""
- +6 QUIT
- KNUM2(ICD) ; Coding System 1.1 AN2 Kill
- +1 NEW RT,EXC,NUM,SYS,COD
- SET SYS=+($GET(X))
- if +SYS'>0
- QUIT
- if +($GET(DA))'>0
- QUIT
- +2 SET RT=$$RT($GET(ICD))
- if '$LENGTH(RT)
- QUIT
- SET COD=$PIECE($GET(@(RT_+DA_",0)")),"^",1)
- +3 if '$LENGTH(COD)
- QUIT
- SET NUM=$$NUM^ICDEX(COD)
- if +NUM'>0
- QUIT
- +4 KILL @(RT_""""_"AN"_+SYS_""","_+NUM_","_+DA_")")
- +5 QUIT
- SSYS(ICD) ; Coding System - Static
- +1 QUIT
- KSYS(ICD) ; Coding System - Static
- +1 QUIT
- +2 ;
- +3 ; Miscellaneous
- HDC ; Set Common Variables (Code, Status and Effective Date)
- +1 if '$LENGTH($GET(RT))
- QUIT
- SET (ICDCOD,ICDSTA,ICDEFF)=""
- if '$LENGTH($GET(RT))
- QUIT
- +2 if +($GET(DA(1)))'>0
- QUIT
- if +($GET(DA))'>0
- QUIT
- if '$DATA(@(RT_+($GET(DA(1)))_",66,"_+($GET(DA))_",0)"))
- QUIT
- +3 SET ICDCOD=$PIECE($GET(@(RT_+($GET(DA(1)))_",0)")),"^",1)
- SET ICDNOD=$GET(@(RT_+($GET(DA(1)))_",66,"_+($GET(DA))_",0)"))
- +4 SET ICDSTA=$PIECE(ICDNOD,"^",2)
- SET ICDEFF=$PIECE(ICDNOD,"^",1)
- +5 QUIT
- SHIS ; Set ^ROOT("ACT",<code>,<status>,<date>,<ien>,<history>)
- +1 ; Set ^ROOT("ACTS",<sys>,<code>,<status>,<date>,<ien>,<history>)
- +2 if '$LENGTH($GET(RT))
- QUIT
- NEW EXC
- if +($GET(DA(1)))'>0
- QUIT
- if +($GET(DA))'>0
- QUIT
- +3 if '$DATA(@(RT_+($GET(DA(1)))_",66,"_+($GET(DA))_",0)"))
- QUIT
- +4 if '$LENGTH($GET(ICDCOD))
- QUIT
- if '$LENGTH($GET(ICDSTA))
- QUIT
- if '$LENGTH($GET(ICDEFF))
- QUIT
- +5 SET @(RT_"""ACT"","""_(ICDCOD_" ")_""","_+ICDSTA_","_+ICDEFF_","_+DA(1)_","_+DA_")")=""
- +6 if +($GET(ICDSYS))>0
- SET @(RT_"""ACTS"","_+ICDSYS_","""_(ICDCOD_" ")_""","_+ICDSTA_","_+ICDEFF_","_+DA(1)_","_+DA_")")=""
- +7 IF +($GET(ICDSYS))'>0
- Begin DoDot:1
- +8 NEW SYS
- SET SYS=+($PIECE($GET(@(RT_+DA(1)_",1)")),"^",1))
- +9 if +SYS>0
- SET @(RT_"""ACTS"","_+SYS_","""_(ICDCOD_" ")_""","_+ICDSTA_","_+ICDEFF_","_+DA(1)_","_+DA_")")=""
- End DoDot:1
- +10 QUIT
- KHIS ; Kill ^ROOT("ACT",<code>,<status>,<date>,<ien>,<history>)
- +1 ; Kill ^ROOT("ACTS",<sys>,<code>,<status>,<date>,<ien>,<history>)
- +2 if '$LENGTH($GET(RT))
- QUIT
- if +($GET(DA(1)))'>0
- QUIT
- if +($GET(DA))'>0
- QUIT
- if '$DATA(@(RT_+($GET(DA(1)))_",66,"_+($GET(DA))_",0)"))
- QUIT
- +3 if '$LENGTH($GET(ICDCOD))
- QUIT
- if '$LENGTH($GET(ICDSTA))
- QUIT
- if '$LENGTH($GET(ICDEFF))
- QUIT
- +4 KILL @(RT_"""ACT"","""_(ICDCOD_" ")_""","_+ICDSTA_","_+ICDEFF_","_+DA(1)_","_+DA_")")
- +5 if +($GET(ICDSYS))>0
- KILL @(RT_"""ACTS"","_+ICDSYS_","""_(ICDCOD_" ")_""","_+ICDSTA_","_+ICDEFF_","_+DA(1)_","_+DA_")")
- +6 IF +($GET(ICDSYS))'>0
- Begin DoDot:1
- +7 NEW SYS
- SET SYS=+($PIECE($GET(@(RT_+DA(1)_",1)")),"^",1))
- +8 if +SYS>0
- KILL @(RT_"""ACTS"","_+SYS_","""_(ICDCOD_" ")_""","_+ICDSTA_","_+ICDEFF_","_+DA(1)_","_+DA_")")
- End DoDot:1
- +9 QUIT
- EXC(X,Y) ; Exclude from lookup
- +1 NEW COD,EFF,LDS,IEN,RT
- SET IEN=+($GET(X))
- SET RT=$GET(Y)
- if +IEN'>0
- QUIT 0
- if '$LENGTH(RT)
- QUIT 0
- SET COD=$PIECE($GET(@(RT_+IEN_",0)")),"^",1)
- +2 SET EFF=$ORDER(@(RT_+IEN_",66,0)"))
- SET LDS=$ORDER(@(RT_+IEN_",68,0)"))
- if $LENGTH(COD)&(+EFF>0)&(+LDS>0)
- QUIT 1
- +3 QUIT 0
- RT(X) ; Root from File #
- +1 QUIT $SELECT(+($GET(X))=80:$$ROOT^ICDEX(80),+($GET(X))=80.1:$$ROOT^ICDEX(80.1),1:"")