AUPNSICA ; IHS/CMI/LAB - Screen Purpose of Visit/ICD9 codes 24-MAY-1993 ;
;;2.0;IHS PCC SUITE;**2,10,11**;MAY 14, 2009;Build 58
;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 '$D(^ICDS(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 '$D(^ICDS(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
;I $G(APCDINPE) S APCDTNQP=$G(INP)
S D=""
I $G(APCDVSIT),$D(^AUPNVSIT(APCDVSIT)) D
.S D=$P($P(^AUPNVSIT(APCDVSIT,0),U),".")
I D="" S D=$P($G(APCDDATE),".")
I D="",$G(BDGV),$D(^AUPNVSIT(BDGV,0)) D
.S D=$P($P(^AUPNVSIT(BDGV,0),U),".")
I D="" S D=DT
S I=$$IMP(D) ;get ien of coding system
S %=$$ICDDX^ICDEX(Y,+D)
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
;S %=$$ICDDATA^ICDXCODE("DIAG",Y,D)
I $E($P(%,U,2),1)="E" Q 0 ;no 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
;
CSEX ; IF 'USE WITH SEX' FIELD HAS A VALUE CHECK THAT VALUE AGAINST AUPNSEX
I '$D(AUPNSEX) Q 1
;I $P(^ICD9(Y,0),U,10)]"",$P(^ICD9(Y,0),U,10)'=AUPNSEX Q 0
I $P(%,U,11)]"",$P(%,U,11)'=AUPNSEX Q 0
Q 1
;
CHKDX30 ;coding system 30 - ICD10
;S %=$$ICDDATA^ICDXCODE("DIAG",Y,D)
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
HELPADX ;EP
NEW D,I,%
S D=""
I '$D(^ICDS(0)) Q
I $T(LST^ATXAPI)="" Q
I $G(APCDVSIT),$D(^AUPNVSIT(APCDVSIT)) D
.S D=$P($P(^AUPNVSIT(APCDVSIT,0),U),".")
I D="" S D=$P($G(APCDDATE),".")
I D="",$G(BDGV),$D(^AUPNVSIT(BDGV,0)) D
.S D=$P($P(^AUPNVSIT(BDGV,0),U),".")
I D="" S D=DT
S I=$$IMP(D) ;get ien of coding system
S %="Enter an active "_$$VAL^XBDIQ1(80.4,I,.01)_" diagnosis code or descriptive text. "
D EN^DDIOL(%)
I I=1 D
.D EN^DDIOL("DO NOT enter a code that begins with E (these are External cause of"),EN^DDIOL("Morbidity codes).")
.;D EN^DDIOL(" ")
I I=30 D
.D EN^DDIOL("DO NOT enter a code that begins with V, W, X or Y (these are External"),EN^DDIOL("cause of Morbidity codes).")
.;D EN^DDIOL(" ")
;Q:X="?"
Q:X="?BAD"
;ASK FOR LIST
Q:'$$ASKLIST()
NEW AUPNC
K ^TMP($J,"APCDCODE") S AUPNC=$NA(^TMP($J,"APCDCODE"))
D LST^ATXAPI(I,80,"*","CODE",AUPNC)
;display to screen until "^"
NEW AUPNX,AUPNY,AUPNQ,AUPNF,X
S AUPNX="",AUPNQ=0,AUPNF=0 F S AUPNX=$O(^TMP($J,"APCDCODE",AUPNX)) Q:AUPNX=""!($G(AUPNQ)) D
.I AUPNF,$Y>(IOSL-2) D EOP Q:AUPNQ
.;CHECK FOR ACTIVE STATUS
.S %=$$ICDDX^ICDEX($P(^TMP($J,"APCDCODE",AUPNX),U,1),D,,"I")
.I I=1 Q:$E(AUPNX)="E"
.I I=30,$E($P(%,U,2),1)="V" Q
.I I=30,$E($P(%,U,2),1)="W" Q
.I I=30,$E($P(%,U,2),1)="X" Q
.I I=30,$E($P(%,U,2),1)="Y" Q
.Q:'$P(%,U,10) ;inactive on this date
.S X=AUPNX,$E(X,12)=$P(%,U,4)
.D EN^DDIOL(X)
.S AUPNF=1
K ^TMP($J,"APCDCODE")
Q
ASKLIST() ;
NEW X,Y,%,I,D,DIR,DIE,DA,DIC,DIRUT,DUOUT
S DIR(0)="Y",DIR("A")="Do you want the entire ICD DIAGNOSIS List",DIR("B")="N" KILL DA D ^DIR KILL DIR
I $D(DIRUT) Q 0
I 'Y Q 0
Q 1
ASKLISTO() ;
NEW X,Y,%,I,D,DIR,DIE,DA,DIC,DIRUT,DUOUT
S DIR(0)="Y",DIR("A")="Do you want the entire ICD OPERATION/PROCEDURE List",DIR("B")="N" KILL DA D ^DIR KILL DIR
I $D(DIRUT) Q 0
I 'Y Q 0
Q 1
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
;
AUPNSICA ; IHS/CMI/LAB - Screen Purpose of Visit/ICD9 codes 24-MAY-1993 ;
+1 ;;2.0;IHS PCC SUITE;**2,10,11**;MAY 14, 2009;Build 58
+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 '$DATA(^ICDS(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 '$DATA(^ICDS(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 ;I $G(APCDINPE) S APCDTNQP=$G(INP)
+9 SET D=""
+10 IF $GET(APCDVSIT)
IF $DATA(^AUPNVSIT(APCDVSIT))
Begin DoDot:1
+11 SET D=$PIECE($PIECE(^AUPNVSIT(APCDVSIT,0),U),".")
End DoDot:1
+12 IF D=""
SET D=$PIECE($GET(APCDDATE),".")
+13 IF D=""
IF $GET(BDGV)
IF $DATA(^AUPNVSIT(BDGV,0))
Begin DoDot:1
+14 SET D=$PIECE($PIECE(^AUPNVSIT(BDGV,0),U),".")
End DoDot:1
+15 IF D=""
SET D=DT
+16 ;get ien of coding system
SET I=$$IMP(D)
+17 SET %=$$ICDDX^ICDEX(Y,+D)
+18 ;not correct coding system
IF $PIECE(%,U,20)]""
IF $PIECE(%,U,20)'=I
QUIT 0
+19 SET I="CHKDX"_I
+20 GOTO @I
+21 ;Q
CHKDX1 ;CODING SYSTEM 1 - ICD9
+1 ;S %=$$ICDDATA^ICDXCODE("DIAG",Y,D)
+2 ;no E codes
IF $EXTRACT($PIECE(%,U,2),1)="E"
QUIT 0
+3 ;STATUS IS INACTIVE
IF $$VERSION^XPDUTL("BCSV")]""
IF '$PIECE(%,U,10)
QUIT 0
+4 IF $$VERSION^XPDUTL("BCSV")]""
GOTO CSEX
+5 SET A=$PIECE($GET(^ICD9(Y,9999999)),U,4)
SET I=$PIECE(^ICD9(Y,0),U,11)
+6 IF D]""
IF I]""
IF D>I
QUIT 0
+7 IF D]""
IF A]""
IF D<A
QUIT 0
+8 ;
CSEX ; IF 'USE WITH SEX' FIELD HAS A VALUE CHECK THAT VALUE AGAINST AUPNSEX
+1 IF '$DATA(AUPNSEX)
QUIT 1
+2 ;I $P(^ICD9(Y,0),U,10)]"",$P(^ICD9(Y,0),U,10)'=AUPNSEX Q 0
+3 IF $PIECE(%,U,11)]""
IF $PIECE(%,U,11)'=AUPNSEX
QUIT 0
+4 QUIT 1
+5 ;
CHKDX30 ;coding system 30 - ICD10
+1 ;S %=$$ICDDATA^ICDXCODE("DIAG",Y,D)
+2 ;no codes V00-Y99 per Leslie Racine.
IF $EXTRACT($PIECE(%,U,2),1)="V"
QUIT 0
+3 IF $EXTRACT($PIECE(%,U,2),1)="W"
QUIT 0
+4 IF $EXTRACT($PIECE(%,U,2),1)="X"
QUIT 0
+5 IF $EXTRACT($PIECE(%,U,2),1)="Y"
QUIT 0
+6 ;STATUS IS INACTIVE
IF '$PIECE(%,U,10)
QUIT 0
+7 ;
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
HELPADX ;EP
+1 NEW D,I,%
+2 SET D=""
+3 IF '$DATA(^ICDS(0))
QUIT
+4 IF $TEXT(LST^ATXAPI)=""
QUIT
+5 IF $GET(APCDVSIT)
IF $DATA(^AUPNVSIT(APCDVSIT))
Begin DoDot:1
+6 SET D=$PIECE($PIECE(^AUPNVSIT(APCDVSIT,0),U),".")
End DoDot:1
+7 IF D=""
SET D=$PIECE($GET(APCDDATE),".")
+8 IF D=""
IF $GET(BDGV)
IF $DATA(^AUPNVSIT(BDGV,0))
Begin DoDot:1
+9 SET D=$PIECE($PIECE(^AUPNVSIT(BDGV,0),U),".")
End DoDot:1
+10 IF D=""
SET D=DT
+11 ;get ien of coding system
SET I=$$IMP(D)
+12 SET %="Enter an active "_$$VAL^XBDIQ1(80.4,I,.01)_" diagnosis code or descriptive text. "
+13 DO EN^DDIOL(%)
+14 IF I=1
Begin DoDot:1
+15 DO EN^DDIOL("DO NOT enter a code that begins with E (these are External cause of")
DO EN^DDIOL("Morbidity codes).")
+16 ;D EN^DDIOL(" ")
End DoDot:1
+17 IF I=30
Begin DoDot:1
+18 DO EN^DDIOL("DO NOT enter a code that begins with V, W, X or Y (these are External")
DO EN^DDIOL("cause of Morbidity codes).")
+19 ;D EN^DDIOL(" ")
End DoDot:1
+20 ;Q:X="?"
+21 IF X="?BAD"
QUIT
+22 ;ASK FOR LIST
+23 IF '$$ASKLIST()
QUIT
+24 NEW AUPNC
+25 KILL ^TMP($JOB,"APCDCODE")
SET AUPNC=$NAME(^TMP($JOB,"APCDCODE"))
+26 DO LST^ATXAPI(I,80,"*","CODE",AUPNC)
+27 ;display to screen until "^"
+28 NEW AUPNX,AUPNY,AUPNQ,AUPNF,X
+29 SET AUPNX=""
SET AUPNQ=0
SET AUPNF=0
FOR
SET AUPNX=$ORDER(^TMP($JOB,"APCDCODE",AUPNX))
IF AUPNX=""!($GET(AUPNQ))
QUIT
Begin DoDot:1
+30 IF AUPNF
IF $Y>(IOSL-2)
DO EOP
IF AUPNQ
QUIT
+31 ;CHECK FOR ACTIVE STATUS
+32 SET %=$$ICDDX^ICDEX($PIECE(^TMP($JOB,"APCDCODE",AUPNX),U,1),D,,"I")
+33 IF I=1
IF $EXTRACT(AUPNX)="E"
QUIT
+34 IF I=30
IF $EXTRACT($PIECE(%,U,2),1)="V"
QUIT
+35 IF I=30
IF $EXTRACT($PIECE(%,U,2),1)="W"
QUIT
+36 IF I=30
IF $EXTRACT($PIECE(%,U,2),1)="X"
QUIT
+37 IF I=30
IF $EXTRACT($PIECE(%,U,2),1)="Y"
QUIT
+38 ;inactive on this date
IF '$PIECE(%,U,10)
QUIT
+39 SET X=AUPNX
SET $EXTRACT(X,12)=$PIECE(%,U,4)
+40 DO EN^DDIOL(X)
+41 SET AUPNF=1
End DoDot:1
+42 KILL ^TMP($JOB,"APCDCODE")
+43 QUIT
ASKLIST() ;
+1 NEW X,Y,%,I,D,DIR,DIE,DA,DIC,DIRUT,DUOUT
+2 SET DIR(0)="Y"
SET DIR("A")="Do you want the entire ICD DIAGNOSIS List"
SET DIR("B")="N"
KILL DA
DO ^DIR
KILL DIR
+3 IF $DATA(DIRUT)
QUIT 0
+4 IF 'Y
QUIT 0
+5 QUIT 1
ASKLISTO() ;
+1 NEW X,Y,%,I,D,DIR,DIE,DA,DIC,DIRUT,DUOUT
+2 SET DIR(0)="Y"
SET DIR("A")="Do you want the entire ICD OPERATION/PROCEDURE List"
SET DIR("B")="N"
KILL DA
DO ^DIR
KILL DIR
+3 IF $DATA(DIRUT)
QUIT 0
+4 IF 'Y
QUIT 0
+5 QUIT 1
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 ;
