AUPNSIC9 ; 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
;
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,D
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
CHK9 ;EP
I $$CHK91(Y)
Q:$D(^ICD9(Y))
Q
CHK91(Y) ;EP
NEW A,I,D,%
S D=""
S D=$$FMADD^XLFDT($$IMP^ICDEX(30),-2)
S I=1
S %=$$ICDDX^ICDEX(Y,D)
I $P(%,U,20)]"",$P(%,U,20)'=I Q 0 ;not correct coding system
S I="CHKDX9"_I
G @I
;Q
CHKDX91 ;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(^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
;
HELP9 ;EP
NEW D,I,%
I '$O(^ICDS("F",80,0)) Q
I $T(LST^ATXAPI)="" Q
S D=$$FMADD^XLFDT($$IMP^ICDEX(30),-2)
S I=1
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).")
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"
.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
CHKE9 ;EP
I $$CHKE91(Y)
Q:$D(^ICD9(Y))
Q
CHKE91(Y) ;
NEW A,I,D,%
S D=""
S D=$$FMADD^XLFDT($$IMP^ICDEX(30),-2)
S I=1
S %=$$ICDDX^ICDEX(Y,D)
I $P(%,U,20)]"",$P(%,U,20)'=I Q 0 ;not correct coding system
;
I $E($P(%,U,2),1)'="E" Q 0 ;no E codes
I '$P(%,U,10) Q 0 ;STATUS IS INACTIVE
;
I '$D(AUPNSEX) Q 1
I $P(%,U,11)]"",$P(%,U,11)'=AUPNSEX Q 0
Q 1
;
HELPE9 ;EP
NEW D,I,%
I '$O(^ICDS("F",80,0)) Q
I $T(LST^ATXAPI)="" Q
S D=$$FMADD^XLFDT($$IMP^ICDEX(30),-2)
D EN^DDIOL("Enter a cause of injury ""E"" code.")
D EN^DDIOL(" ")
;Q:X="?"
Q:X="?BAD"
Q:'$$ASKLIST()
NEW AUPNC
K ^TMP($J,"APCDCODE") S AUPNC=$NA(^TMP($J,"APCDCODE"))
D LST^ATXAPI(1,80,"E*","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")
.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
CHKPL9 ;EP
I $$CHKPL91(Y)
Q:$D(^ICD9(Y))
Q
CHKPL91(Y) ;
NEW A,I,D,%
S D=""
S D=$$FMADD^XLFDT($$IMP^ICDEX(30),-2)
S I=1
S %=$$ICDDX^ICDEX(Y,D)
I $P(%,U,20)]"",$P(%,U,20)'=I Q 0 ;not correct coding system
;
I $E($P(%,U,2),1,4)'="E849" Q 0
I '$P(%,U,10) Q 0 ;STATUS IS INACTIVE
;
I '$D(AUPNSEX) Q 1
I $P(%,U,11)]"",$P(%,U,11)'=AUPNSEX Q 0
Q 1
;
HELPPL9 ;EP
NEW D,I,%
I '$O(^ICDS("F",80,0)) Q
I $T(LST^ATXAPI)="" Q
S D=$$FMADD^XLFDT($$IMP^ICDEX(30),-2)
S I=1
Q:X="?BAD"
Q:'$$ASKLIST()
NEW AUPNC
K ^TMP($J,"APCDCODE") S AUPNC=$NA(^TMP($J,"APCDCODE"))
D LST^ATXAPI(1,80,"E849-E849.ZZ","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")
.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
HELPOP9 ;EP
NEW D,I,%
I '$O(^ICDS("F",80,0)) Q
I $T(LST^ATXAPI)="" Q
S D=""
S I=2 ;get ien of coding system
S D=$S($T(IMP^ICDEX)]"":$$FMADD^XLFDT($$IMP^ICDEX(31),-2),1:DT)
S %="Enter an active ICD-9 Procedure Code or descriptive text. "
D EN^DDIOL(%)
;D EN^DDIOL("Enter a Procedure name (2-245 characters in length), a Procedure")
;D EN^DDIOL("code, one or more keywords sufficient to select a Procedure name.")
;D EN^DDIOL(" ")
;Q:X="?"
Q:X="?BAD"
Q:'$$ASKLISTO()
NEW AUPNC
K ^TMP($J,"APCDCODE") S AUPNC=$NA(^TMP($J,"APCDCODE"))
D LST^ATXAPI(I,80.1,"*","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 %=$$ICDOP^ICDEX($P(^TMP($J,"APCDCODE",AUPNX),U,1),D,,"I")
.Q:'$P(%,U,10) ;inactive on this date
.S X=AUPNX,$E(X,12)=$P(%,U,5)
.D EN^DDIOL(X)
.S AUPNF=1
K ^TMP($J,"APCDCODE")
Q
CHKOP9 ;EP
I $$CHKOP91(Y)
Q:$D(^ICD9(Y))
Q
CHKOP91(Y) ;
NEW A,I,D,%
S D=""
S D=$$FMADD^XLFDT($$IMP^ICDEX(30),-2)
S I=2
S %=$$ICDOP^ICDEX(Y,,,"I")
I $P(%,U,15)]"",$P(%,U,15)'=I Q 0 ;not correct coding system
;
I '$P(%,U,10) Q 0 ;STATUS IS INACTIVE
;
I '$D(AUPNSEX) Q 1
I $P(%,U,11)]"",$P(%,U,11)'=AUPNSEX Q 0
Q 1
;
AUPNSIC9 ; 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 ;
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,D
+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
CHK9 ;EP
+1 IF $$CHK91(Y)
+2 IF $DATA(^ICD9(Y))
QUIT
+3 QUIT
CHK91(Y) ;EP
+1 NEW A,I,D,%
+2 SET D=""
+3 SET D=$$FMADD^XLFDT($$IMP^ICDEX(30),-2)
+4 SET I=1
+5 SET %=$$ICDDX^ICDEX(Y,D)
+6 ;not correct coding system
IF $PIECE(%,U,20)]""
IF $PIECE(%,U,20)'=I
QUIT 0
+7 SET I="CHKDX9"_I
+8 GOTO @I
+9 ;Q
CHKDX91 ;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 ;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 ;
HELP9 ;EP
+1 NEW D,I,%
+2 IF '$ORDER(^ICDS("F",80,0))
QUIT
+3 IF $TEXT(LST^ATXAPI)=""
QUIT
+4 SET D=$$FMADD^XLFDT($$IMP^ICDEX(30),-2)
+5 SET I=1
+6 SET %="Enter an active "_$$VAL^XBDIQ1(80.4,I,.01)_" diagnosis code or descriptive text. "
+7 DO EN^DDIOL(%)
+8 IF I=1
Begin DoDot:1
+9 DO EN^DDIOL("DO NOT enter a code that begins with E (these are External cause of")
DO EN^DDIOL("Morbidity codes).")
End DoDot:1
+10 IF X="?BAD"
QUIT
+11 ;ASK FOR LIST
+12 IF '$$ASKLIST()
QUIT
+13 NEW AUPNC
+14 KILL ^TMP($JOB,"APCDCODE")
SET AUPNC=$NAME(^TMP($JOB,"APCDCODE"))
+15 DO LST^ATXAPI(I,80,"*","CODE",AUPNC)
+16 ;display to screen until "^"
+17 NEW AUPNX,AUPNY,AUPNQ,AUPNF,X
+18 SET AUPNX=""
SET AUPNQ=0
SET AUPNF=0
FOR
SET AUPNX=$ORDER(^TMP($JOB,"APCDCODE",AUPNX))
IF AUPNX=""!($GET(AUPNQ))
QUIT
Begin DoDot:1
+19 IF AUPNF
IF $Y>(IOSL-2)
DO EOP
IF AUPNQ
QUIT
+20 ;CHECK FOR ACTIVE STATUS
+21 SET %=$$ICDDX^ICDEX($PIECE(^TMP($JOB,"APCDCODE",AUPNX),U,1),D,,"I")
+22 IF I=1
IF $EXTRACT(AUPNX)="E"
QUIT
+23 ;inactive on this date
IF '$PIECE(%,U,10)
QUIT
+24 SET X=AUPNX
SET $EXTRACT(X,12)=$PIECE(%,U,4)
+25 DO EN^DDIOL(X)
+26 SET AUPNF=1
End DoDot:1
+27 KILL ^TMP($JOB,"APCDCODE")
+28 QUIT
CHKE9 ;EP
+1 IF $$CHKE91(Y)
+2 IF $DATA(^ICD9(Y))
QUIT
+3 QUIT
CHKE91(Y) ;
+1 NEW A,I,D,%
+2 SET D=""
+3 SET D=$$FMADD^XLFDT($$IMP^ICDEX(30),-2)
+4 SET I=1
+5 SET %=$$ICDDX^ICDEX(Y,D)
+6 ;not correct coding system
IF $PIECE(%,U,20)]""
IF $PIECE(%,U,20)'=I
QUIT 0
+7 ;
+8 ;no E codes
IF $EXTRACT($PIECE(%,U,2),1)'="E"
QUIT 0
+9 ;STATUS IS INACTIVE
IF '$PIECE(%,U,10)
QUIT 0
+10 ;
+11 IF '$DATA(AUPNSEX)
QUIT 1
+12 IF $PIECE(%,U,11)]""
IF $PIECE(%,U,11)'=AUPNSEX
QUIT 0
+13 QUIT 1
+14 ;
HELPE9 ;EP
+1 NEW D,I,%
+2 IF '$ORDER(^ICDS("F",80,0))
QUIT
+3 IF $TEXT(LST^ATXAPI)=""
QUIT
+4 SET D=$$FMADD^XLFDT($$IMP^ICDEX(30),-2)
+5 DO EN^DDIOL("Enter a cause of injury ""E"" code.")
+6 DO EN^DDIOL(" ")
+7 ;Q:X="?"
+8 IF X="?BAD"
QUIT
+9 IF '$$ASKLIST()
QUIT
+10 NEW AUPNC
+11 KILL ^TMP($JOB,"APCDCODE")
SET AUPNC=$NAME(^TMP($JOB,"APCDCODE"))
+12 DO LST^ATXAPI(1,80,"E*","CODE",AUPNC)
+13 ;display to screen until "^"
+14 NEW AUPNX,AUPNY,AUPNQ,AUPNF,X
+15 SET AUPNX=""
SET AUPNQ=0
SET AUPNF=0
FOR
SET AUPNX=$ORDER(^TMP($JOB,"APCDCODE",AUPNX))
IF AUPNX=""!($GET(AUPNQ))
QUIT
Begin DoDot:1
+16 IF AUPNF
IF $Y>(IOSL-2)
DO EOP
IF AUPNQ
QUIT
+17 ;CHECK FOR ACTIVE STATUS
+18 SET %=$$ICDDX^ICDEX($PIECE(^TMP($JOB,"APCDCODE",AUPNX),U,1),D,,"I")
+19 ;inactive on this date
IF '$PIECE(%,U,10)
QUIT
+20 SET X=AUPNX
SET $EXTRACT(X,12)=$PIECE(%,U,4)
+21 DO EN^DDIOL(X)
+22 SET AUPNF=1
End DoDot:1
+23 KILL ^TMP($JOB,"APCDCODE")
+24 QUIT
CHKPL9 ;EP
+1 IF $$CHKPL91(Y)
+2 IF $DATA(^ICD9(Y))
QUIT
+3 QUIT
CHKPL91(Y) ;
+1 NEW A,I,D,%
+2 SET D=""
+3 SET D=$$FMADD^XLFDT($$IMP^ICDEX(30),-2)
+4 SET I=1
+5 SET %=$$ICDDX^ICDEX(Y,D)
+6 ;not correct coding system
IF $PIECE(%,U,20)]""
IF $PIECE(%,U,20)'=I
QUIT 0
+7 ;
+8 IF $EXTRACT($PIECE(%,U,2),1,4)'="E849"
QUIT 0
+9 ;STATUS IS INACTIVE
IF '$PIECE(%,U,10)
QUIT 0
+10 ;
+11 IF '$DATA(AUPNSEX)
QUIT 1
+12 IF $PIECE(%,U,11)]""
IF $PIECE(%,U,11)'=AUPNSEX
QUIT 0
+13 QUIT 1
+14 ;
HELPPL9 ;EP
+1 NEW D,I,%
+2 IF '$ORDER(^ICDS("F",80,0))
QUIT
+3 IF $TEXT(LST^ATXAPI)=""
QUIT
+4 SET D=$$FMADD^XLFDT($$IMP^ICDEX(30),-2)
+5 SET I=1
+6 IF X="?BAD"
QUIT
+7 IF '$$ASKLIST()
QUIT
+8 NEW AUPNC
+9 KILL ^TMP($JOB,"APCDCODE")
SET AUPNC=$NAME(^TMP($JOB,"APCDCODE"))
+10 DO LST^ATXAPI(1,80,"E849-E849.ZZ","CODE",AUPNC)
+11 ;display to screen until "^"
+12 NEW AUPNX,AUPNY,AUPNQ,AUPNF,X
+13 SET AUPNX=""
SET AUPNQ=0
SET AUPNF=0
FOR
SET AUPNX=$ORDER(^TMP($JOB,"APCDCODE",AUPNX))
IF AUPNX=""!($GET(AUPNQ))
QUIT
Begin DoDot:1
+14 IF AUPNF
IF $Y>(IOSL-2)
DO EOP
IF AUPNQ
QUIT
+15 ;CHECK FOR ACTIVE STATUS
+16 SET %=$$ICDDX^ICDEX($PIECE(^TMP($JOB,"APCDCODE",AUPNX),U,1),D,,"I")
+17 ;inactive on this date
IF '$PIECE(%,U,10)
QUIT
+18 SET X=AUPNX
SET $EXTRACT(X,12)=$PIECE(%,U,4)
+19 DO EN^DDIOL(X)
+20 SET AUPNF=1
End DoDot:1
+21 KILL ^TMP($JOB,"APCDCODE")
+22 QUIT
HELPOP9 ;EP
+1 NEW D,I,%
+2 IF '$ORDER(^ICDS("F",80,0))
QUIT
+3 IF $TEXT(LST^ATXAPI)=""
QUIT
+4 SET D=""
+5 ;get ien of coding system
SET I=2
+6 SET D=$SELECT($TEXT(IMP^ICDEX)]"":$$FMADD^XLFDT($$IMP^ICDEX(31),-2),1:DT)
+7 SET %="Enter an active ICD-9 Procedure Code or descriptive text. "
+8 DO EN^DDIOL(%)
+9 ;D EN^DDIOL("Enter a Procedure name (2-245 characters in length), a Procedure")
+10 ;D EN^DDIOL("code, one or more keywords sufficient to select a Procedure name.")
+11 ;D EN^DDIOL(" ")
+12 ;Q:X="?"
+13 IF X="?BAD"
QUIT
+14 IF '$$ASKLISTO()
QUIT
+15 NEW AUPNC
+16 KILL ^TMP($JOB,"APCDCODE")
SET AUPNC=$NAME(^TMP($JOB,"APCDCODE"))
+17 DO LST^ATXAPI(I,80.1,"*","CODE",AUPNC)
+18 ;display to screen until "^"
+19 NEW AUPNX,AUPNY,AUPNQ,AUPNF,X
+20 SET AUPNX=""
SET AUPNQ=0
SET AUPNF=0
FOR
SET AUPNX=$ORDER(^TMP($JOB,"APCDCODE",AUPNX))
IF AUPNX=""!($GET(AUPNQ))
QUIT
Begin DoDot:1
+21 IF AUPNF
IF $Y>(IOSL-2)
DO EOP
IF AUPNQ
QUIT
+22 ;CHECK FOR ACTIVE STATUS
+23 SET %=$$ICDOP^ICDEX($PIECE(^TMP($JOB,"APCDCODE",AUPNX),U,1),D,,"I")
+24 ;inactive on this date
IF '$PIECE(%,U,10)
QUIT
+25 SET X=AUPNX
SET $EXTRACT(X,12)=$PIECE(%,U,5)
+26 DO EN^DDIOL(X)
+27 SET AUPNF=1
End DoDot:1
+28 KILL ^TMP($JOB,"APCDCODE")
+29 QUIT
CHKOP9 ;EP
+1 IF $$CHKOP91(Y)
+2 IF $DATA(^ICD9(Y))
QUIT
+3 QUIT
CHKOP91(Y) ;
+1 NEW A,I,D,%
+2 SET D=""
+3 SET D=$$FMADD^XLFDT($$IMP^ICDEX(30),-2)
+4 SET I=2
+5 SET %=$$ICDOP^ICDEX(Y,,,"I")
+6 ;not correct coding system
IF $PIECE(%,U,15)]""
IF $PIECE(%,U,15)'=I
QUIT 0
+7 ;
+8 ;STATUS IS INACTIVE
IF '$PIECE(%,U,10)
QUIT 0
+9 ;
+10 IF '$DATA(AUPNSEX)
QUIT 1
+11 IF $PIECE(%,U,11)]""
IF $PIECE(%,U,11)'=AUPNSEX
QUIT 0
+12 QUIT 1
+13 ;
