AUPNSICD ; IHS/CMI/LAB - Screen Purpose of Visit/ICD9 codes 24-MAY-1993 ; 05 Nov 2014 10:46 AM
;;2.0;IHS PCC SUITE;**2,10,11,15**;MAY 14, 2009;Build 11
;IHS/TUCSON/LAB - added checks for filegram and CHS, do not
;execute screen if in chs or filegrams 03/18/96 PATCH 4
I $$CHK(Y)
Q:$D(^ICD9(Y))
Q
IMP(D) ;PEP - which coding system should be used:
;RETURN IEN of entry in ^ICDS
;1 = ICD9
;30 = ICD10
;will need to add subroutines for ICD11 when we have that.
I $G(D)="" S D=DT
NEW X,Y,Z
I '$O(^ICDS("F",80,0)) Q 1
S Y=""
S X=0 F S X=$O(^ICDS("F",80,X)) Q:X'=+X D
.I $P(^ICDS(X,0),U,4)="" Q ;NO IMPLEMENTATION DATE?? SKIP IT
.S Z($P(^ICDS(X,0),U,4))=X
;now go through and get the last one before it imp date is greater than the visit date
S X=0 F S X=$O(Z(X)) Q:X="" D
.I D<X Q
.I D=X S Y=Z(X) Q
.I D>X S Y=Z(X) Q
I Y="" S Y=$O(Z(0)) Q Z(Y)
Q Y
IMPOP(D) ;PEP - which coding system should be used:
;RETURN IEN of entry in ^ICDS
;1 = ICD9
;30 = ICD10
;will need to add subroutines for ICD11 when we have that.
I $G(D)="" S D=DT
NEW X,Y,Z
I '$O(^ICDS("F",80.1,0)) Q 2
S Y=""
S X=0 F S X=$O(^ICDS("F",80.1,X)) Q:X'=+X D
.I $P(^ICDS(X,0),U,4)="" Q ;NO IMPLEMENTATION DATE?? SKIP IT
.S Z($P(^ICDS(X,0),U,4))=X
;now go through and get the last one before it imp date is greater than the visit date
S X=0 F S X=$O(Z(X)) Q:X="" D
.I D<X Q
.I D=X S Y=Z(X) Q
.I D>X S Y=Z(X) Q
I Y="" S Y=$O(Z(0)) Q Z(Y)
Q Y
;
CHK(Y) ;EP - SCREEN OUT E CODES AND INACTIVE CODES
NEW A,I,D,%
I $D(DIFGLINE) Q 1 ;in filegrams so take code and accept it
I $D(ACHSDIEN) Q 1 ;in CHS so take code and accept it
I $G(DUZ("AG"))'="I" Q 1
;use date if available
;get visit date if known, if not known, use DT to determine whether to use
;ICD9 vs ICD10
S D=""
I $G(APCDVSIT),$D(^AUPNVSIT(APCDVSIT)) D
.I $P(^AUPNVSIT(APCDVSIT,0),U,7)="H",$$DSCHDATE^APCLV(APCDVSIT)]"" S D=$$DSCHDATE^APCLV(APCDVSIT) Q
.S D=$P($P(^AUPNVSIT(APCDVSIT,0),U),".")
I D="" S D=$P($G(APCDDATE),".")
I D="" S D=DT
S I=$$IMP(D) ;get ien of coding system
S %=$$ICDDX^ICDEX(Y,D,,"I") I 1
I $P(%,U,20)]"",$P(%,U,20)'=I Q 0 ;not correct coding system
S I="CHKDX"_I
G @I
;Q
CHKDX1 ;CODING SYSTEM 1 - ICD9
I $E($P(%,U,2),1)="E" Q 0 ;no E codes
I '$P(%,U,10) Q 0 ;STATUS IS INACTIVE
;
CSEX ; IF 'USE WITH SEX' FIELD HAS A VALUE CHECK THAT VALUE AGAINST AUPNSEX
I '$D(AUPNSEX) Q 1
I $P(%,U,11)]"",$P(%,U,11)'=AUPNSEX Q 0
Q 1
;
CHKDX30 ;coding system 30 - ICD10
I $E($P(%,U,2),1)="V" Q 0 ;no codes V00-Y99 per Leslie Racine.
I $E($P(%,U,2),1)="W" Q 0
I $E($P(%,U,2),1)="X" Q 0
I $E($P(%,U,2),1)="Y" Q 0
I '$P(%,U,10) Q 0 ;STATUS IS INACTIVE
;
CSEX30 ; IF 'USE WITH SEX' FIELD HAS A VALUE CHECK THAT VALUE AGAINST AUPNSEX
I '$D(AUPNSEX) Q 1
I $P(%,U,11)]"",$P(%,U,11)'=AUPNSEX Q 0
Q 1
CPT ;EP - screen on CPT from V CPT .01 and V Procedure
;note: DATE ADDED in the CPT table reflects the date the code was added to the local table and thus can't be used. It should be the date added to the CPT file, AFTER CSV will be able to use it
I $$CHKCPT(Y)
Q:$D(^ICPT(Y))
Q
;
CHKCPT(Y) ;check CPT for valid date, inactive flag
I $D(APCDOVR) Q 1 ;override for something
I $D(DIFGLINE) Q 1 ;if in MFI accept all cpt codes
I $D(ACHSDIEN) Q 1 ;if in CHS link accept all cpt codes
I $G(DUZ("AG"))'="I" Q 1 ;if not an IHS facility accept all cpt codes
NEW A,I,D,%
;get date if available
S D=""
I $G(APCDVSIT),$D(^AUPNVSIT(APCDVSIT)) D
.I $P(^AUPNVSIT(APCDVSIT,0),U,7)="H",$$DSCHDATE^APCLV(APCDVSIT)]"" S D=$$DSCHDATE^APCLV(APCDVSIT) Q
.S D=$P($P(^AUPNVSIT(APCDVSIT,0),U),".")
;check date if have date
I D="" S D=$P($G(APCDDATE),".")
I D="" S D=DT
;
S %=$$CPT^ICPTCOD(Y,D)
I $$VERSION^XPDUTL("BCSV")]"" Q $P(%,U,7)
S A="",I=$P(^ICPT(Y,0),U,7)
I D]"",I]"",D>I Q 0
Q 1
;
;
ICDOPCHK ;EP called from input tx on V PROCEDURE .01 SCREEN OUT E CODES AND INACTIVE CODES
I $$CHKOP(Y)
Q:$D(^ICD0(Y))
Q
;
CHKOP(Y) ;EP
;new subroutine for CSV
I $D(DIFGLINE) Q 1 ;in MFI
I $D(ACHSDIEN) Q 1 ;in CHS
I $G(DUZ("AG"))'="I" Q 1 ;not IHS
;use date if available
;get visit date if known, if not known, use DT to determine whether to use
;ICD9 vs ICD10
NEW A,I,D,%
S D=""
I $G(APCDVSIT),$D(^AUPNVSIT(APCDVSIT)) D
.I $P(^AUPNVSIT(APCDVSIT,0),U,7)="H",$$DSCHDATE^APCLV(APCDVSIT)]"" S D=$$DSCHDATE^APCLV(APCDVSIT) Q
.S D=$P($P(^AUPNVSIT(APCDVSIT,0),U),".")
I D="" S D=$P($G(APCDDATE),".")
I D="" S D=DT
S I=$$IMPOP(D) ;get ien of coding system
S %=$$ICDOP^ICDEX(Y,D,,"I")
I $P(%,U,15)]"",$P(%,U,15)'=I Q 0 ;not correct coding system
S I="CHKOP"_I G @I
;Q
CHKOP2 ;CODING SYSTEM 2 - ICD9
I '$P(%,U,10) Q 0 ;STATUS IS INACTIVE
OPSEX ; IF 'USE WITH SEX' FIELD HAS A VALUE CHECK THAT VALUE AGAINST AUPNSEX
I '$D(AUPNSEX) Q 1
I $P(%,U,11)]"",$P(%,U,11)'=AUPNSEX Q 0
Q 1
;
CHKOP31 ;coding system 31 - ICD10
I '$P(%,U,10) Q 0 ;STATUS IS INACTIVE
;
CSEX31 ; IF 'USE WITH SEX' FIELD HAS A VALUE CHECK THAT VALUE AGAINST AUPNSEX
I '$D(AUPNSEX) Q 1
I $P(%,U,11)]"",$P(%,U,11)'=AUPNSEX Q 0
Q 1
CHKFH(Y) ;EP - SCREEN OUT E CODES AND INACTIVE CODES
I $D(DIFGLINE) Q 1 ;take whatever mfi gives us
NEW A,I,D,%
S D=""
S D=$P($G(APCDDATE),".")
I D="" S D=DT
S I=$$IMP(D) ;get ien of coding system
S %=$$ICDDX^ICDEX(Y,D,,"I")
I $P(%,U,20)]"",$P(%,U,20)'=I Q 0 ;not correct coding system
S I="CHKFH"_I G @I
;
CHKFH1 ;
S A=0 D
.I $E($P(%,U,2),1,3)="V16" S A=1
.I $E($P(%,U,2),1,3)="V17" S A=1
.I $E($P(%,U,2),1,3)="V18" S A=1
.I $E($P(%,U,2),1,3)="V19" S A=1
.I $P(%,U,2)=".9999" S A=1
I 'A Q 0
I $$VERSION^XPDUTL("BCSV")]"" Q $P(%,U,10)
S A=$P($G(^ICD9(Y,9999999)),U,4),I=$P(^ICD9(Y,0),U,11)
I D]"",I]"",D>I Q 0
I D]"",A]"",D<A Q 0
Q 1
CHKFH30 ;
S A=0 D
.I $E($P(%,U,2),1,3)="Z80" S A=1
.I $E($P(%,U,2),1,3)="Z81" S A=1
.I $E($P(%,U,2),1,3)="Z82" S A=1
.I $E($P(%,U,2),1,3)="Z83" S A=1
.I $E($P(%,U,2),1,3)="Z84" S A=1
.I $P(%,U,2)="ZZZ.999" S A=1
I 'A Q 0
I $$VERSION^XPDUTL("BCSV")]"" Q $P(%,U,10)
S A=$P($G(^ICD9(Y,9999999)),U,4),I=$P(^ICD9(Y,0),U,11)
I D]"",I]"",D>I Q 0
I D]"",A]"",D<A Q 0
Q 1
CHKE ;EP - ECODE SCREEN
I $$CHKE1(Y)
Q:$D(^ICD9(Y))
Q
CHKE1(Y) ;EP SCREEN OUT E CODES AND INACTIVE CODES
NEW A,I,D,%
I $D(DIFGLINE) Q 1 ;in filegrams so take code and accept it
I $D(ACHSDIEN) Q 1 ;in CHS so take code and accept it
I $G(DUZ("AG"))'="I" Q 1
;use date if available
;get visit date if known, if not known, use DT to determine whether to use
;ICD9 vs ICD10
S D=""
I $G(APCDVSIT),$D(^AUPNVSIT(APCDVSIT)) D
.I $P(^AUPNVSIT(APCDVSIT,0),U,7)="H",$$DSCHDATE^APCLV(APCDVSIT)]"" S D=$$DSCHDATE^APCLV(APCDVSIT) Q
.S D=$P($P(^AUPNVSIT(APCDVSIT,0),U),".")
I D="" S D=$P($G(APCDDATE),".")
I D="" S D=DT
S I=$$IMP(D) ;get ien of coding system
S %=$$ICDDX^ICDEX(Y,D,,"I")
I $P(%,U,20)]"",$P(%,U,20)'=I Q 0 ;not correct coding system
S I="CHKEX"_I G @I
;Q
CHKEX1 ;CODING SYSTEM 1 - ICD9
I $E($P(%,U,2),1)'="E" Q 0 ;only E codes
I $$VERSION^XPDUTL("BCSV")]"",'$P(%,U,10) Q 0 ;STATUS IS INACTIVE
I $$VERSION^XPDUTL("BCSV")]"" G CSEX
S A=$P($G(^ICD9(Y,9999999)),U,4),I=$P(^ICD9(Y,0),U,11)
I D]"",I]"",D>I Q 0
I D]"",A]"",D<A Q 0
Q 1
;
CHKEX30 ;coding system 30 - ICD10
NEW J
S J=0
I $E($P(%,U,2),1)="V" S J=1 ;only codes V00-Y99 per Leslie Racine.
I $E($P(%,U,2),1)="W" S J=1
I $E($P(%,U,2),1)="X" S J=1
I $E($P(%,U,2),1)="Y" S J=1
I 'J Q 0
I '$P(%,U,10) Q 0 ;STATUS IS INACTIVE
Q 1
FHCHK ;PEP - called from input tx on FAMILY HISTORY .01 field
;screen out all codes but V16-V19 and make sure it is active as of date being entered
;IHS/CMI/LAB - AUPN*99.1*7 - begin mods 02/15/2002
I $$CHKFH(Y)
Q:$D(^ICD9(Y))
Q
HELP ;EP
D HELP^AUPNSICH
Q
HELPFH ;EP
D HELPFH^AUPNSICH
Q
HELPE ;EP
D HELPE^AUPNSICH
Q
RFBH ;EP
D HELPRFB^AUPNSICH
Q
EOP ;
S AUPNQ=0
NEW DIR
NEW DIRUT,DFOUT,DLOUT,DTOUT,DUOUT
S DIR(0)="E" D ^DIR K DIR
I $D(DUOUT) S AUPNQ=1 Q
W:$D(IOF) @IOF
Q
;
HELPPL ;EP
D HELPPL^AUPNSICH
Q
PLACE ;EP - ECODE SCREEN
I $$CHKPL(Y)
Q:$D(^ICD9(Y))
Q
CHKPL(Y) ; SCREEN OUT E CODES AND INACTIVE CODES
NEW A,I,D,%
I $D(DIFGLINE) Q 1 ;in filegrams so take code and accept it
I $D(ACHSDIEN) Q 1 ;in CHS so take code and accept it
I $G(DUZ("AG"))'="I" Q 1
;use date if available
;get visit date if known, if not known, use DT to determine whether to use
;ICD9 vs ICD10
S D=""
I $G(APCDVSIT),$D(^AUPNVSIT(APCDVSIT)) D
.I $P(^AUPNVSIT(APCDVSIT,0),U,7)="H",$$DSCHDATE^APCLV(APCDVSIT)]"" S D=$$DSCHDATE^APCLV(APCDVSIT) Q
.S D=$P($P(^AUPNVSIT(APCDVSIT,0),U),".")
I D="" S D=$P($G(APCDDATE),".")
I D="" S D=DT
;;S D=3140101
S I=$$IMP(D) ;get ien of coding system
S %=$$ICDDX^ICDEX(Y,D,,"I")
I $P(%,U,20)]"",$P(%,U,20)'=I Q 0 ;not correct coding system
S I="CHKPL"_I G @I
;Q
CHKPL1 ;CODING SYSTEM 1 - ICD9
I $E($P(%,U,2),1,4)'="E849" Q 0 ;only place of occurence
I '$P(%,U,10) Q 0 ;STATUS IS INACTIVE
Q 1
;
CHKPL30 ;coding system 30 - ICD10
NEW J
S J=0
I $E($P(%,U,2),1,3)="Y92" S J=1 ;only codes XXX per Leslie Racine.
I 'J Q 0
I '$P(%,U,10) Q 0 ;STATUS IS INACTIVE
Q 1
HELPOP ;EP
D HELPOP^AUPNSICH
Q
RFB ;EP - ECODE SCREEN
I $$CHKRFB(Y)
Q:$D(^ICD9(Y))
Q
CHKRFB(Y) ; SCREEN Z18-Z18.9
NEW A,I,D,%
I $D(DIFGLINE) Q 1 ;in filegrams so take code and accept it
I $D(ACHSDIEN) Q 1 ;in CHS so take code and accept it
I $G(DUZ("AG"))'="I" Q 1
;use date if available
;get visit date if known, if not known, use DT to determine whether to use
;ICD9 vs ICD10
S D=""
I $G(APCDVSIT),$D(^AUPNVSIT(APCDVSIT)) D
.I $P(^AUPNVSIT(APCDVSIT,0),U,7)="H",$$DSCHDATE^APCLV(APCDVSIT)]"" S D=$$DSCHDATE^APCLV(APCDVSIT) Q
.S D=$P($P(^AUPNVSIT(APCDVSIT,0),U),".")
I D="" S D=$P($G(APCDDATE),".")
I D="" S D=DT
S I=$$IMP(D) ;get ien of coding system
I I'=30 Q 0
S %=$$ICDDX^ICDEX(Y,D,,"I")
I $P(%,U,20)'=I Q 0 ;not correct coding system
S I="CHKRFB"_I G @I
;Q
CHKRFB1 ;CODING SYSTEM 1 - ICD9
;
CHKRFB30 ;coding system 30 - ICD10
NEW J
S J=0
I $E($P(%,U,2),1,3)="Z18" S J=1 ;only codes Z18 per Leslie Racine.
I 'J Q 0
I '$P(%,U,10) Q 0 ;STATUS IS INACTIVE
Q 1
CONC(IN) ;PEP - called to return ICD codes for a snomed concept ID
;Input
; OUT - Output variable/global to return information in (VAR)
; IN - P1 - The Concept Id to look up
; - P2 (Optional) - The code set Id (default SNOMED '36')
; - P3 (Optional) - Snapshot Date to check (default DT)
; - P4 (Optional) - LOCAL - Pass 1 to perform local listing, otherwise leave
; blank for remote listing
; - P5 (Optional) - DEBUG - Pass 1 to display debug information
; - P6 (Optional) - Mapping Parameters
;
;Output
; Function returns - [1]^[2]^[3]^[4]
; [1] - Description Id of Fully Specified Name
; [2] - Fully Specified Name
; [3] - Description Id of Preferred Term
; [4] - Preferred Term
; [5] - Mapped ICD Values (based on P3 Snapshot Date)
; [6] - Mapped ICD9 Values
NEW AUPNP,AUPNIN1,AUPNV,AUPND,AUPNI,AUPNIMP,AUPNZ,AUPNY
S AUPNIN1=$P(IN,U,1,6) ;value to pass to BSTS
S AUPND=$P(IN,U,3) S:AUPND="" AUPND=DT ;DATE FOR CODES
S AUPNV=$$CONC^BSTSAPI(AUPNIN1)
;GET ICD CODES FROM 5TH PIECE
S AUPNI=$P(AUPNV,U,5) ;ICD CODES RETURNED
I AUPNI="" S $P(AUPNV,U,5)=$$UNCODE(AUPND) Q AUPNV ;if there are no icd codes pass back the uncoded in 5th piece
;PARSE OUT ALL CODES AND SET TO UNCODED IF IT FAILS INPUT TRANSFORM OF .01 OF V POV
S AUPNIMP=$$IMP(AUPND) ;ICD IMPLEMENTATION
F AUPNZ=1:1 S AUPNY=$P(AUPNI,";",AUPNZ) Q:AUPNY="" D
.I AUPNY'["." S AUPNY=AUPNY_".",$P(AUPNI,";",AUPNZ)=AUPNY
.S AUPNP=$$ICDDX^ICDEX(AUPNY,AUPND,,"E")
.I $P(AUPNP,U,1)="-1" S $P(AUPNI,";",AUPNZ)=$$UNCODE(AUPND) Q ;NOT AN ICD CODE
.I '$P(AUPNP,U,10) S $P(AUPNI,";",AUPNZ)=$$UNCODE(AUPND) Q ;INACTIVE AS OF AUPND
.Q
S $P(AUPNV,U,5)=AUPNI
Q AUPNV
UNCODE(D) ;
I $G(D)="" S D=DT
NEW I
S I=$$IMP(D)
Q $S(I=30:"ZZZ.999",1:".9999")
AUPNSICD ; IHS/CMI/LAB - Screen Purpose of Visit/ICD9 codes 24-MAY-1993 ; 05 Nov 2014 10:46 AM
+1 ;;2.0;IHS PCC SUITE;**2,10,11,15**;MAY 14, 2009;Build 11
+2 ;IHS/TUCSON/LAB - added checks for filegram and CHS, do not
+3 ;execute screen if in chs or filegrams 03/18/96 PATCH 4
+4 IF $$CHK(Y)
+5 IF $DATA(^ICD9(Y))
QUIT
+6 QUIT
IMP(D) ;PEP - which coding system should be used:
+1 ;RETURN IEN of entry in ^ICDS
+2 ;1 = ICD9
+3 ;30 = ICD10
+4 ;will need to add subroutines for ICD11 when we have that.
+5 IF $GET(D)=""
SET D=DT
+6 NEW X,Y,Z
+7 IF '$ORDER(^ICDS("F",80,0))
QUIT 1
+8 SET Y=""
+9 SET X=0
FOR
SET X=$ORDER(^ICDS("F",80,X))
IF X'=+X
QUIT
Begin DoDot:1
+10 ;NO IMPLEMENTATION DATE?? SKIP IT
IF $PIECE(^ICDS(X,0),U,4)=""
QUIT
+11 SET Z($PIECE(^ICDS(X,0),U,4))=X
End DoDot:1
+12 ;now go through and get the last one before it imp date is greater than the visit date
+13 SET X=0
FOR
SET X=$ORDER(Z(X))
IF X=""
QUIT
Begin DoDot:1
+14 IF D<X
QUIT
+15 IF D=X
SET Y=Z(X)
QUIT
+16 IF D>X
SET Y=Z(X)
QUIT
End DoDot:1
+17 IF Y=""
SET Y=$ORDER(Z(0))
QUIT Z(Y)
+18 QUIT Y
IMPOP(D) ;PEP - which coding system should be used:
+1 ;RETURN IEN of entry in ^ICDS
+2 ;1 = ICD9
+3 ;30 = ICD10
+4 ;will need to add subroutines for ICD11 when we have that.
+5 IF $GET(D)=""
SET D=DT
+6 NEW X,Y,Z
+7 IF '$ORDER(^ICDS("F",80.1,0))
QUIT 2
+8 SET Y=""
+9 SET X=0
FOR
SET X=$ORDER(^ICDS("F",80.1,X))
IF X'=+X
QUIT
Begin DoDot:1
+10 ;NO IMPLEMENTATION DATE?? SKIP IT
IF $PIECE(^ICDS(X,0),U,4)=""
QUIT
+11 SET Z($PIECE(^ICDS(X,0),U,4))=X
End DoDot:1
+12 ;now go through and get the last one before it imp date is greater than the visit date
+13 SET X=0
FOR
SET X=$ORDER(Z(X))
IF X=""
QUIT
Begin DoDot:1
+14 IF D<X
QUIT
+15 IF D=X
SET Y=Z(X)
QUIT
+16 IF D>X
SET Y=Z(X)
QUIT
End DoDot:1
+17 IF Y=""
SET Y=$ORDER(Z(0))
QUIT Z(Y)
+18 QUIT Y
+19 ;
CHK(Y) ;EP - SCREEN OUT E CODES AND INACTIVE CODES
+1 NEW A,I,D,%
+2 ;in filegrams so take code and accept it
IF $DATA(DIFGLINE)
QUIT 1
+3 ;in CHS so take code and accept it
IF $DATA(ACHSDIEN)
QUIT 1
+4 IF $GET(DUZ("AG"))'="I"
QUIT 1
+5 ;use date if available
+6 ;get visit date if known, if not known, use DT to determine whether to use
+7 ;ICD9 vs ICD10
+8 SET D=""
+9 IF $GET(APCDVSIT)
IF $DATA(^AUPNVSIT(APCDVSIT))
Begin DoDot:1
+10 IF $PIECE(^AUPNVSIT(APCDVSIT,0),U,7)="H"
IF $$DSCHDATE^APCLV(APCDVSIT)]""
SET D=$$DSCHDATE^APCLV(APCDVSIT)
QUIT
+11 SET D=$PIECE($PIECE(^AUPNVSIT(APCDVSIT,0),U),".")
End DoDot:1
+12 IF D=""
SET D=$PIECE($GET(APCDDATE),".")
+13 IF D=""
SET D=DT
+14 ;get ien of coding system
SET I=$$IMP(D)
+15 SET %=$$ICDDX^ICDEX(Y,D,,"I")
IF 1
+16 ;not correct coding system
IF $PIECE(%,U,20)]""
IF $PIECE(%,U,20)'=I
QUIT 0
+17 SET I="CHKDX"_I
+18 GOTO @I
+19 ;Q
CHKDX1 ;CODING SYSTEM 1 - ICD9
+1 ;no E codes
IF $EXTRACT($PIECE(%,U,2),1)="E"
QUIT 0
+2 ;STATUS IS INACTIVE
IF '$PIECE(%,U,10)
QUIT 0
+3 ;
CSEX ; IF 'USE WITH SEX' FIELD HAS A VALUE CHECK THAT VALUE AGAINST AUPNSEX
+1 IF '$DATA(AUPNSEX)
QUIT 1
+2 IF $PIECE(%,U,11)]""
IF $PIECE(%,U,11)'=AUPNSEX
QUIT 0
+3 QUIT 1
+4 ;
CHKDX30 ;coding system 30 - ICD10
+1 ;no codes V00-Y99 per Leslie Racine.
IF $EXTRACT($PIECE(%,U,2),1)="V"
QUIT 0
+2 IF $EXTRACT($PIECE(%,U,2),1)="W"
QUIT 0
+3 IF $EXTRACT($PIECE(%,U,2),1)="X"
QUIT 0
+4 IF $EXTRACT($PIECE(%,U,2),1)="Y"
QUIT 0
+5 ;STATUS IS INACTIVE
IF '$PIECE(%,U,10)
QUIT 0
+6 ;
CSEX30 ; IF 'USE WITH SEX' FIELD HAS A VALUE CHECK THAT VALUE AGAINST AUPNSEX
+1 IF '$DATA(AUPNSEX)
QUIT 1
+2 IF $PIECE(%,U,11)]""
IF $PIECE(%,U,11)'=AUPNSEX
QUIT 0
+3 QUIT 1
CPT ;EP - screen on CPT from V CPT .01 and V Procedure
+1 ;note: DATE ADDED in the CPT table reflects the date the code was added to the local table and thus can't be used. It should be the date added to the CPT file, AFTER CSV will be able to use it
+2 IF $$CHKCPT(Y)
+3 IF $DATA(^ICPT(Y))
QUIT
+4 QUIT
+5 ;
CHKCPT(Y) ;check CPT for valid date, inactive flag
+1 ;override for something
IF $DATA(APCDOVR)
QUIT 1
+2 ;if in MFI accept all cpt codes
IF $DATA(DIFGLINE)
QUIT 1
+3 ;if in CHS link accept all cpt codes
IF $DATA(ACHSDIEN)
QUIT 1
+4 ;if not an IHS facility accept all cpt codes
IF $GET(DUZ("AG"))'="I"
QUIT 1
+5 NEW A,I,D,%
+6 ;get date if available
+7 SET D=""
+8 IF $GET(APCDVSIT)
IF $DATA(^AUPNVSIT(APCDVSIT))
Begin DoDot:1
+9 IF $PIECE(^AUPNVSIT(APCDVSIT,0),U,7)="H"
IF $$DSCHDATE^APCLV(APCDVSIT)]""
SET D=$$DSCHDATE^APCLV(APCDVSIT)
QUIT
+10 SET D=$PIECE($PIECE(^AUPNVSIT(APCDVSIT,0),U),".")
End DoDot:1
+11 ;check date if have date
+12 IF D=""
SET D=$PIECE($GET(APCDDATE),".")
+13 IF D=""
SET D=DT
+14 ;
+15 SET %=$$CPT^ICPTCOD(Y,D)
+16 IF $$VERSION^XPDUTL("BCSV")]""
QUIT $PIECE(%,U,7)
+17 SET A=""
SET I=$PIECE(^ICPT(Y,0),U,7)
+18 IF D]""
IF I]""
IF D>I
QUIT 0
+19 QUIT 1
+20 ;
+21 ;
ICDOPCHK ;EP called from input tx on V PROCEDURE .01 SCREEN OUT E CODES AND INACTIVE CODES
+1 IF $$CHKOP(Y)
+2 IF $DATA(^ICD0(Y))
QUIT
+3 QUIT
+4 ;
CHKOP(Y) ;EP
+1 ;new subroutine for CSV
+2 ;in MFI
IF $DATA(DIFGLINE)
QUIT 1
+3 ;in CHS
IF $DATA(ACHSDIEN)
QUIT 1
+4 ;not IHS
IF $GET(DUZ("AG"))'="I"
QUIT 1
+5 ;use date if available
+6 ;get visit date if known, if not known, use DT to determine whether to use
+7 ;ICD9 vs ICD10
+8 NEW A,I,D,%
+9 SET D=""
+10 IF $GET(APCDVSIT)
IF $DATA(^AUPNVSIT(APCDVSIT))
Begin DoDot:1
+11 IF $PIECE(^AUPNVSIT(APCDVSIT,0),U,7)="H"
IF $$DSCHDATE^APCLV(APCDVSIT)]""
SET D=$$DSCHDATE^APCLV(APCDVSIT)
QUIT
+12 SET D=$PIECE($PIECE(^AUPNVSIT(APCDVSIT,0),U),".")
End DoDot:1
+13 IF D=""
SET D=$PIECE($GET(APCDDATE),".")
+14 IF D=""
SET D=DT
+15 ;get ien of coding system
SET I=$$IMPOP(D)
+16 SET %=$$ICDOP^ICDEX(Y,D,,"I")
+17 ;not correct coding system
IF $PIECE(%,U,15)]""
IF $PIECE(%,U,15)'=I
QUIT 0
+18 SET I="CHKOP"_I
GOTO @I
+19 ;Q
CHKOP2 ;CODING SYSTEM 2 - ICD9
+1 ;STATUS IS INACTIVE
IF '$PIECE(%,U,10)
QUIT 0
OPSEX ; IF 'USE WITH SEX' FIELD HAS A VALUE CHECK THAT VALUE AGAINST AUPNSEX
+1 IF '$DATA(AUPNSEX)
QUIT 1
+2 IF $PIECE(%,U,11)]""
IF $PIECE(%,U,11)'=AUPNSEX
QUIT 0
+3 QUIT 1
+4 ;
CHKOP31 ;coding system 31 - ICD10
+1 ;STATUS IS INACTIVE
IF '$PIECE(%,U,10)
QUIT 0
+2 ;
CSEX31 ; IF 'USE WITH SEX' FIELD HAS A VALUE CHECK THAT VALUE AGAINST AUPNSEX
+1 IF '$DATA(AUPNSEX)
QUIT 1
+2 IF $PIECE(%,U,11)]""
IF $PIECE(%,U,11)'=AUPNSEX
QUIT 0
+3 QUIT 1
CHKFH(Y) ;EP - SCREEN OUT E CODES AND INACTIVE CODES
+1 ;take whatever mfi gives us
IF $DATA(DIFGLINE)
QUIT 1
+2 NEW A,I,D,%
+3 SET D=""
+4 SET D=$PIECE($GET(APCDDATE),".")
+5 IF D=""
SET D=DT
+6 ;get ien of coding system
SET I=$$IMP(D)
+7 SET %=$$ICDDX^ICDEX(Y,D,,"I")
+8 ;not correct coding system
IF $PIECE(%,U,20)]""
IF $PIECE(%,U,20)'=I
QUIT 0
+9 SET I="CHKFH"_I
GOTO @I
+10 ;
CHKFH1 ;
+1 SET A=0
Begin DoDot:1
+2 IF $EXTRACT($PIECE(%,U,2),1,3)="V16"
SET A=1
+3 IF $EXTRACT($PIECE(%,U,2),1,3)="V17"
SET A=1
+4 IF $EXTRACT($PIECE(%,U,2),1,3)="V18"
SET A=1
+5 IF $EXTRACT($PIECE(%,U,2),1,3)="V19"
SET A=1
+6 IF $PIECE(%,U,2)=".9999"
SET A=1
End DoDot:1
+7 IF 'A
QUIT 0
+8 IF $$VERSION^XPDUTL("BCSV")]""
QUIT $PIECE(%,U,10)
+9 SET A=$PIECE($GET(^ICD9(Y,9999999)),U,4)
SET I=$PIECE(^ICD9(Y,0),U,11)
+10 IF D]""
IF I]""
IF D>I
QUIT 0
+11 IF D]""
IF A]""
IF D<A
QUIT 0
+12 QUIT 1
CHKFH30 ;
+1 SET A=0
Begin DoDot:1
+2 IF $EXTRACT($PIECE(%,U,2),1,3)="Z80"
SET A=1
+3 IF $EXTRACT($PIECE(%,U,2),1,3)="Z81"
SET A=1
+4 IF $EXTRACT($PIECE(%,U,2),1,3)="Z82"
SET A=1
+5 IF $EXTRACT($PIECE(%,U,2),1,3)="Z83"
SET A=1
+6 IF $EXTRACT($PIECE(%,U,2),1,3)="Z84"
SET A=1
+7 IF $PIECE(%,U,2)="ZZZ.999"
SET A=1
End DoDot:1
+8 IF 'A
QUIT 0
+9 IF $$VERSION^XPDUTL("BCSV")]""
QUIT $PIECE(%,U,10)
+10 SET A=$PIECE($GET(^ICD9(Y,9999999)),U,4)
SET I=$PIECE(^ICD9(Y,0),U,11)
+11 IF D]""
IF I]""
IF D>I
QUIT 0
+12 IF D]""
IF A]""
IF D<A
QUIT 0
+13 QUIT 1
CHKE ;EP - ECODE SCREEN
+1 IF $$CHKE1(Y)
+2 IF $DATA(^ICD9(Y))
QUIT
+3 QUIT
CHKE1(Y) ;EP SCREEN OUT E CODES AND INACTIVE CODES
+1 NEW A,I,D,%
+2 ;in filegrams so take code and accept it
IF $DATA(DIFGLINE)
QUIT 1
+3 ;in CHS so take code and accept it
IF $DATA(ACHSDIEN)
QUIT 1
+4 IF $GET(DUZ("AG"))'="I"
QUIT 1
+5 ;use date if available
+6 ;get visit date if known, if not known, use DT to determine whether to use
+7 ;ICD9 vs ICD10
+8 SET D=""
+9 IF $GET(APCDVSIT)
IF $DATA(^AUPNVSIT(APCDVSIT))
Begin DoDot:1
+10 IF $PIECE(^AUPNVSIT(APCDVSIT,0),U,7)="H"
IF $$DSCHDATE^APCLV(APCDVSIT)]""
SET D=$$DSCHDATE^APCLV(APCDVSIT)
QUIT
+11 SET D=$PIECE($PIECE(^AUPNVSIT(APCDVSIT,0),U),".")
End DoDot:1
+12 IF D=""
SET D=$PIECE($GET(APCDDATE),".")
+13 IF D=""
SET D=DT
+14 ;get ien of coding system
SET I=$$IMP(D)
+15 SET %=$$ICDDX^ICDEX(Y,D,,"I")
+16 ;not correct coding system
IF $PIECE(%,U,20)]""
IF $PIECE(%,U,20)'=I
QUIT 0
+17 SET I="CHKEX"_I
GOTO @I
+18 ;Q
CHKEX1 ;CODING SYSTEM 1 - ICD9
+1 ;only E codes
IF $EXTRACT($PIECE(%,U,2),1)'="E"
QUIT 0
+2 ;STATUS IS INACTIVE
IF $$VERSION^XPDUTL("BCSV")]""
IF '$PIECE(%,U,10)
QUIT 0
+3 IF $$VERSION^XPDUTL("BCSV")]""
GOTO CSEX
+4 SET A=$PIECE($GET(^ICD9(Y,9999999)),U,4)
SET I=$PIECE(^ICD9(Y,0),U,11)
+5 IF D]""
IF I]""
IF D>I
QUIT 0
+6 IF D]""
IF A]""
IF D<A
QUIT 0
+7 QUIT 1
+8 ;
CHKEX30 ;coding system 30 - ICD10
+1 NEW J
+2 SET J=0
+3 ;only codes V00-Y99 per Leslie Racine.
IF $EXTRACT($PIECE(%,U,2),1)="V"
SET J=1
+4 IF $EXTRACT($PIECE(%,U,2),1)="W"
SET J=1
+5 IF $EXTRACT($PIECE(%,U,2),1)="X"
SET J=1
+6 IF $EXTRACT($PIECE(%,U,2),1)="Y"
SET J=1
+7 IF 'J
QUIT 0
+8 ;STATUS IS INACTIVE
IF '$PIECE(%,U,10)
QUIT 0
+9 QUIT 1
FHCHK ;PEP - called from input tx on FAMILY HISTORY .01 field
+1 ;screen out all codes but V16-V19 and make sure it is active as of date being entered
+2 ;IHS/CMI/LAB - AUPN*99.1*7 - begin mods 02/15/2002
+3 IF $$CHKFH(Y)
+4 IF $DATA(^ICD9(Y))
QUIT
+5 QUIT
HELP ;EP
+1 DO HELP^AUPNSICH
+2 QUIT
HELPFH ;EP
+1 DO HELPFH^AUPNSICH
+2 QUIT
HELPE ;EP
+1 DO HELPE^AUPNSICH
+2 QUIT
RFBH ;EP
+1 DO HELPRFB^AUPNSICH
+2 QUIT
EOP ;
+1 SET AUPNQ=0
+2 NEW DIR
+3 NEW DIRUT,DFOUT,DLOUT,DTOUT,DUOUT
+4 SET DIR(0)="E"
DO ^DIR
KILL DIR
+5 IF $DATA(DUOUT)
SET AUPNQ=1
QUIT
+6 IF $DATA(IOF)
WRITE @IOF
+7 QUIT
+8 ;
HELPPL ;EP
+1 DO HELPPL^AUPNSICH
+2 QUIT
PLACE ;EP - ECODE SCREEN
+1 IF $$CHKPL(Y)
+2 IF $DATA(^ICD9(Y))
QUIT
+3 QUIT
CHKPL(Y) ; SCREEN OUT E CODES AND INACTIVE CODES
+1 NEW A,I,D,%
+2 ;in filegrams so take code and accept it
IF $DATA(DIFGLINE)
QUIT 1
+3 ;in CHS so take code and accept it
IF $DATA(ACHSDIEN)
QUIT 1
+4 IF $GET(DUZ("AG"))'="I"
QUIT 1
+5 ;use date if available
+6 ;get visit date if known, if not known, use DT to determine whether to use
+7 ;ICD9 vs ICD10
+8 SET D=""
+9 IF $GET(APCDVSIT)
IF $DATA(^AUPNVSIT(APCDVSIT))
Begin DoDot:1
+10 IF $PIECE(^AUPNVSIT(APCDVSIT,0),U,7)="H"
IF $$DSCHDATE^APCLV(APCDVSIT)]""
SET D=$$DSCHDATE^APCLV(APCDVSIT)
QUIT
+11 SET D=$PIECE($PIECE(^AUPNVSIT(APCDVSIT,0),U),".")
End DoDot:1
+12 IF D=""
SET D=$PIECE($GET(APCDDATE),".")
+13 IF D=""
SET D=DT
+14 ;;S D=3140101
+15 ;get ien of coding system
SET I=$$IMP(D)
+16 SET %=$$ICDDX^ICDEX(Y,D,,"I")
+17 ;not correct coding system
IF $PIECE(%,U,20)]""
IF $PIECE(%,U,20)'=I
QUIT 0
+18 SET I="CHKPL"_I
GOTO @I
+19 ;Q
CHKPL1 ;CODING SYSTEM 1 - ICD9
+1 ;only place of occurence
IF $EXTRACT($PIECE(%,U,2),1,4)'="E849"
QUIT 0
+2 ;STATUS IS INACTIVE
IF '$PIECE(%,U,10)
QUIT 0
+3 QUIT 1
+4 ;
CHKPL30 ;coding system 30 - ICD10
+1 NEW J
+2 SET J=0
+3 ;only codes XXX per Leslie Racine.
IF $EXTRACT($PIECE(%,U,2),1,3)="Y92"
SET J=1
+4 IF 'J
QUIT 0
+5 ;STATUS IS INACTIVE
IF '$PIECE(%,U,10)
QUIT 0
+6 QUIT 1
HELPOP ;EP
+1 DO HELPOP^AUPNSICH
+2 QUIT
RFB ;EP - ECODE SCREEN
+1 IF $$CHKRFB(Y)
+2 IF $DATA(^ICD9(Y))
QUIT
+3 QUIT
CHKRFB(Y) ; SCREEN Z18-Z18.9
+1 NEW A,I,D,%
+2 ;in filegrams so take code and accept it
IF $DATA(DIFGLINE)
QUIT 1
+3 ;in CHS so take code and accept it
IF $DATA(ACHSDIEN)
QUIT 1
+4 IF $GET(DUZ("AG"))'="I"
QUIT 1
+5 ;use date if available
+6 ;get visit date if known, if not known, use DT to determine whether to use
+7 ;ICD9 vs ICD10
+8 SET D=""
+9 IF $GET(APCDVSIT)
IF $DATA(^AUPNVSIT(APCDVSIT))
Begin DoDot:1
+10 IF $PIECE(^AUPNVSIT(APCDVSIT,0),U,7)="H"
IF $$DSCHDATE^APCLV(APCDVSIT)]""
SET D=$$DSCHDATE^APCLV(APCDVSIT)
QUIT
+11 SET D=$PIECE($PIECE(^AUPNVSIT(APCDVSIT,0),U),".")
End DoDot:1
+12 IF D=""
SET D=$PIECE($GET(APCDDATE),".")
+13 IF D=""
SET D=DT
+14 ;get ien of coding system
SET I=$$IMP(D)
+15 IF I'=30
QUIT 0
+16 SET %=$$ICDDX^ICDEX(Y,D,,"I")
+17 ;not correct coding system
IF $PIECE(%,U,20)'=I
QUIT 0
+18 SET I="CHKRFB"_I
GOTO @I
+19 ;Q
CHKRFB1 ;CODING SYSTEM 1 - ICD9
+1 ;
CHKRFB30 ;coding system 30 - ICD10
+1 NEW J
+2 SET J=0
+3 ;only codes Z18 per Leslie Racine.
IF $EXTRACT($PIECE(%,U,2),1,3)="Z18"
SET J=1
+4 IF 'J
QUIT 0
+5 ;STATUS IS INACTIVE
IF '$PIECE(%,U,10)
QUIT 0
+6 QUIT 1
CONC(IN) ;PEP - called to return ICD codes for a snomed concept ID
+1 ;Input
+2 ; OUT - Output variable/global to return information in (VAR)
+3 ; IN - P1 - The Concept Id to look up
+4 ; - P2 (Optional) - The code set Id (default SNOMED '36')
+5 ; - P3 (Optional) - Snapshot Date to check (default DT)
+6 ; - P4 (Optional) - LOCAL - Pass 1 to perform local listing, otherwise leave
+7 ; blank for remote listing
+8 ; - P5 (Optional) - DEBUG - Pass 1 to display debug information
+9 ; - P6 (Optional) - Mapping Parameters
+10 ;
+11 ;Output
+12 ; Function returns - [1]^[2]^[3]^[4]
+13 ; [1] - Description Id of Fully Specified Name
+14 ; [2] - Fully Specified Name
+15 ; [3] - Description Id of Preferred Term
+16 ; [4] - Preferred Term
+17 ; [5] - Mapped ICD Values (based on P3 Snapshot Date)
+18 ; [6] - Mapped ICD9 Values
+19 NEW AUPNP,AUPNIN1,AUPNV,AUPND,AUPNI,AUPNIMP,AUPNZ,AUPNY
+20 ;value to pass to BSTS
SET AUPNIN1=$PIECE(IN,U,1,6)
+21 ;DATE FOR CODES
SET AUPND=$PIECE(IN,U,3)
IF AUPND=""
SET AUPND=DT
+22 SET AUPNV=$$CONC^BSTSAPI(AUPNIN1)
+23 ;GET ICD CODES FROM 5TH PIECE
+24 ;ICD CODES RETURNED
SET AUPNI=$PIECE(AUPNV,U,5)
+25 ;if there are no icd codes pass back the uncoded in 5th piece
IF AUPNI=""
SET $PIECE(AUPNV,U,5)=$$UNCODE(AUPND)
QUIT AUPNV
+26 ;PARSE OUT ALL CODES AND SET TO UNCODED IF IT FAILS INPUT TRANSFORM OF .01 OF V POV
+27 ;ICD IMPLEMENTATION
SET AUPNIMP=$$IMP(AUPND)
+28 FOR AUPNZ=1:1
SET AUPNY=$PIECE(AUPNI,";",AUPNZ)
IF AUPNY=""
QUIT
Begin DoDot:1
+29 IF AUPNY'["."
SET AUPNY=AUPNY_"."
SET $PIECE(AUPNI,";",AUPNZ)=AUPNY
+30 SET AUPNP=$$ICDDX^ICDEX(AUPNY,AUPND,,"E")
+31 ;NOT AN ICD CODE
IF $PIECE(AUPNP,U,1)="-1"
SET $PIECE(AUPNI,";",AUPNZ)=$$UNCODE(AUPND)
QUIT
+32 ;INACTIVE AS OF AUPND
IF '$PIECE(AUPNP,U,10)
SET $PIECE(AUPNI,";",AUPNZ)=$$UNCODE(AUPND)
QUIT
+33 QUIT
End DoDot:1
+34 SET $PIECE(AUPNV,U,5)=AUPNI
+35 QUIT AUPNV
UNCODE(D) ;
+1 IF $GET(D)=""
SET D=DT
+2 NEW I
+3 SET I=$$IMP(D)
+4 QUIT $SELECT(I=30:"ZZZ.999",1:".9999")
