AUPNSIC9.m

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      ;