AUPNSICH.m

AUPNSICH ; IHS/CMI/LAB - Screen Purpose of Visit/ICD9 codes 24-MAY-1993 ; 

 ;;2.0;IHS PCC SUITE;**2,10,11,16**;MAY 14, 2009;Build 9

 ;IHS/TUCSON/LAB - added checks for filegram and CHS, do not

 ;

HELP ;EP

 NEW D,I,%

 S D=""

 I '$O(^ICDS("F",80,0)) Q

 I $T(LST^ATXAPI)="" Q

 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^AUPNSICD(D)  ;get ien of coding system

 S %="Enter an active "_$S(I=1:"ICD-9-CM",1:"ICD-10-CM")_" 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

HELPFH ;EP

 NEW D,I,%

 S D=""

 I '$O(^ICDS("F",80,0)) Q

 I $T(LST^ATXAPI)="" Q

 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^AUPNSICD(D)  ;get ien of coding system

 ;S %="Enter a valid "_$$VAL^XBDIQ1(80.4,I,.01)_" Family History Diagnosis code.  "

 ;D EN^DDIOL(%)

 D EN^DDIOL(" ")

 I I=1 D

 .D EN^DDIOL("Enter the Family History ICD that best describes the diagnosis."),EN^DDIOL("Select an active code, must be V16*, V17*, V18* or V19*.")

 .D EN^DDIOL("  ")

 I I=30 D

 .D EN^DDIOL("Enter the Family History ICD that best describes the diagnosis."),EN^DDIOL("Select an active code in the Z80 to Z84 range.")

 .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(I,80,$S(I=1:"V16-V19.Z",1:"Z80-Z84.ZZZZ"),"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

HELPE ;EP

 NEW D,I,%

 S D=""

 I '$O(^ICDS("F",80,0)) Q

 I $T(LST^ATXAPI)="" Q

 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^AUPNSICD(D)  ;get ien of coding system

 I I=1 D  Q

 .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")

 I I=30 D  Q

 .D EN^DDIOL("Must be an external cause of morbidity code.  The code range is V00-Y99.")

 .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(30,80,"V01-Y99.Z","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

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

 NEW D,I,%

 S D=""

 I '$O(^ICDS("F",80,0)) Q

 I $T(LST^ATXAPI)="" Q

 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^AUPNSICD(D)  ;get ien of coding system

 S %="Enter a valid "_$$VAL^XBDIQ1(80.4,I,.01)_" Place of Occurrence code.  "

 I I=30 D EN^DDIOL(%)

 I I=1 D  Q

 .D EN^DDIOL("Enter a Place or Occurrence code in the range E849.0-E849.9.")

 .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,"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")

 I I=30 D  Q

 .D EN^DDIOL("Must be in the code range Y92-Y92.9.")

 .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(30,80,"Y92-Y92.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

HELPOP ;EP

 NEW D,I,%

 S D=""

 I '$O(^ICDS("F",80.1,0)) Q

 I $T(LST^ATXAPI)="" Q

 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^AUPNSICD(D)  ;get ien of coding system

 S %="Enter an active "_$S(I=2:"ICD-9",1:"ICD-10")_" 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

HELPRFB ;EP

 NEW D,I,%

 S D=""

 I '$O(^ICDS("F",80,0)) Q

 I $T(LST^ATXAPI)="" Q

 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^AUPNSICD(D)  ;get ien of coding system

 ;S %="Enter a valid "_$$VAL^XBDIQ1(80.4,I,.01)_" Place of Occurrence code.  "

 ;D EN^DDIOL(%)

 I I=1 Q

 I I=30 D  Q

 .D EN^DDIOL("Must be in the code range Z18-Z18.9.")

 .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(30,80,"Z18-Z18.Z","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

HELPLEX ;EP

 NEW D,I,%

 S D=""

 I '$O(^ICDS("F",80,0)) Q

 I $T(LST^ATXAPI)="" Q

 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^AUPNSICD(D)  ;get ien of coding system

 ;Q:X="?"

 Q:X="?BAD"

 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

 .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

 .S %=$$ICDDX^ICDEX($P(AUPNC(AUPNX),U,1),D)

 .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

AUPNSICH  ; IHS/CMI/LAB - Screen Purpose of Visit/ICD9 codes 24-MAY-1993 ; 

 +1       ;;2.0;IHS PCC SUITE;**2,10,11,16**;MAY 14, 2009;Build 9

 +2       ;IHS/TUCSON/LAB - added checks for filegram and CHS, do not

 +3       ;

HELP      ;EP

 +1        NEW D,I,%

 +2        SET D=""

 +3        IF '$ORDER(^ICDS("F",80,0))

               QUIT 

 +4        IF $TEXT(LST^ATXAPI)=""

               QUIT 

 +5        IF $GET(APCDVSIT)

               IF $DATA(^AUPNVSIT(APCDVSIT))

                   Begin DoDot:1

 +6                    IF $PIECE(^AUPNVSIT(APCDVSIT,0),U,7)="H"

                           IF $$DSCHDATE^APCLV(APCDVSIT)]""

                               SET D=$$DSCHDATE^APCLV(APCDVSIT)

                               QUIT 

 +7                    SET D=$PIECE($PIECE(^AUPNVSIT(APCDVSIT,0),U),".")

                   End DoDot:1

 +8        IF D=""

               SET D=$PIECE($GET(APCDDATE),".")

 +9        IF D=""

               SET D=DT

 +10      ;get ien of coding system

           SET I=$$IMP^AUPNSICD(D)

 +11       SET %="Enter an active "_$SELECT(I=1:"ICD-9-CM",1:"ICD-10-CM")_" diagnosis code or descriptive text.  "

 +12       DO EN^DDIOL(%)

 +13       IF I=1

               Begin DoDot:1

 +14               DO EN^DDIOL("DO NOT enter a code that begins with E (these are External cause of")

                   DO EN^DDIOL("Morbidity codes).")

 +15      ;D EN^DDIOL("  ")

               End DoDot:1

 +16       IF I=30

               Begin DoDot:1

 +17               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).")

 +18      ;D EN^DDIOL("  ")

               End DoDot:1

 +19      ;Q:X="?"

 +20       IF X="?BAD"

               QUIT 

 +21      ;ASK FOR LIST

 +22       IF '$$ASKLIST()

               QUIT 

 +23       NEW AUPNC

 +24       KILL ^TMP($JOB,"APCDCODE")

           SET AUPNC=$NAME(^TMP($JOB,"APCDCODE"))

 +25       DO LST^ATXAPI(I,80,"*","CODE",AUPNC)

 +26      ;display to screen until "^"

 +27       NEW AUPNX,AUPNY,AUPNQ,AUPNF,X

 +28       SET AUPNX=""

           SET AUPNQ=0

           SET AUPNF=0

           FOR 

               SET AUPNX=$ORDER(^TMP($JOB,"APCDCODE",AUPNX))

               IF AUPNX=""!($GET(AUPNQ))

                   QUIT 

               Begin DoDot:1

 +29               IF AUPNF

                       IF $Y>(IOSL-2)

                           DO EOP

                           IF AUPNQ

                               QUIT 

 +30      ;CHECK FOR ACTIVE STATUS

 +31               SET %=$$ICDDX^ICDEX($PIECE(^TMP($JOB,"APCDCODE",AUPNX),U,1),D,,"I")

 +32               IF I=1

                       IF $EXTRACT(AUPNX)="E"

                           QUIT 

 +33               IF I=30

                       IF $EXTRACT($PIECE(%,U,2),1)="V"

                           QUIT 

 +34               IF I=30

                       IF $EXTRACT($PIECE(%,U,2),1)="W"

                           QUIT 

 +35               IF I=30

                       IF $EXTRACT($PIECE(%,U,2),1)="X"

                           QUIT 

 +36               IF I=30

                       IF $EXTRACT($PIECE(%,U,2),1)="Y"

                           QUIT 

 +37      ;inactive on this date

                   IF '$PIECE(%,U,10)

                       QUIT 

 +38               SET X=AUPNX

                   SET $EXTRACT(X,12)=$PIECE(%,U,4)

 +39               DO EN^DDIOL(X)

 +40               SET AUPNF=1

               End DoDot:1

 +41       KILL ^TMP($JOB,"APCDCODE")

 +42       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

HELPFH    ;EP

 +1        NEW D,I,%

 +2        SET D=""

 +3        IF '$ORDER(^ICDS("F",80,0))

               QUIT 

 +4        IF $TEXT(LST^ATXAPI)=""

               QUIT 

 +5        IF $GET(APCDVSIT)

               IF $DATA(^AUPNVSIT(APCDVSIT))

                   Begin DoDot:1

 +6                    IF $PIECE(^AUPNVSIT(APCDVSIT,0),U,7)="H"

                           IF $$DSCHDATE^APCLV(APCDVSIT)]""

                               SET D=$$DSCHDATE^APCLV(APCDVSIT)

                               QUIT 

 +7                    SET D=$PIECE($PIECE(^AUPNVSIT(APCDVSIT,0),U),".")

                   End DoDot:1

 +8        IF D=""

               SET D=$PIECE($GET(APCDDATE),".")

 +9        IF D=""

               SET D=DT

 +10      ;get ien of coding system

           SET I=$$IMP^AUPNSICD(D)

 +11      ;S %="Enter a valid "_$$VAL^XBDIQ1(80.4,I,.01)_" Family History Diagnosis code.  "

 +12      ;D EN^DDIOL(%)

 +13       DO EN^DDIOL(" ")

 +14       IF I=1

               Begin DoDot:1

 +15               DO EN^DDIOL("Enter the Family History ICD that best describes the diagnosis.")

                   DO EN^DDIOL("Select an active code, must be V16*, V17*, V18* or V19*.")

 +16               DO EN^DDIOL("  ")

               End DoDot:1

 +17       IF I=30

               Begin DoDot:1

 +18               DO EN^DDIOL("Enter the Family History ICD that best describes the diagnosis.")

                   DO EN^DDIOL("Select an active code in the Z80 to Z84 range.")

 +19               DO EN^DDIOL("  ")

               End DoDot:1

 +20      ;Q:X="?"

 +21       IF X="?BAD"

               QUIT 

 +22       IF '$$ASKLIST()

               QUIT 

 +23       NEW AUPNC

 +24       KILL ^TMP($JOB,"APCDCODE")

           SET AUPNC=$NAME(^TMP($JOB,"APCDCODE"))

 +25       DO LST^ATXAPI(I,80,$SELECT(I=1:"V16-V19.Z",1:"Z80-Z84.ZZZZ"),"CODE",AUPNC)

 +26      ;display to screen until "^"

 +27       NEW AUPNX,AUPNY,AUPNQ,AUPNF,X

 +28       SET AUPNX=""

           SET AUPNQ=0

           SET AUPNF=0

           FOR 

               SET AUPNX=$ORDER(^TMP($JOB,"APCDCODE",AUPNX))

               IF AUPNX=""!($GET(AUPNQ))

                   QUIT 

               Begin DoDot:1

 +29               IF AUPNF

                       IF $Y>(IOSL-2)

                           DO EOP

                           IF AUPNQ

                               QUIT 

 +30      ;CHECK FOR ACTIVE STATUS

 +31               SET %=$$ICDDX^ICDEX($PIECE(^TMP($JOB,"APCDCODE",AUPNX),U,1),D,,"I")

 +32      ;inactive on this date

                   IF '$PIECE(%,U,10)

                       QUIT 

 +33               SET X=AUPNX

                   SET $EXTRACT(X,12)=$PIECE(%,U,4)

 +34               DO EN^DDIOL(X)

 +35               SET AUPNF=1

               End DoDot:1

 +36       KILL ^TMP($JOB,"APCDCODE")

 +37       QUIT 

HELPE     ;EP

 +1        NEW D,I,%

 +2        SET D=""

 +3        IF '$ORDER(^ICDS("F",80,0))

               QUIT 

 +4        IF $TEXT(LST^ATXAPI)=""

               QUIT 

 +5        IF $GET(APCDVSIT)

               IF $DATA(^AUPNVSIT(APCDVSIT))

                   Begin DoDot:1

 +6                    IF $PIECE(^AUPNVSIT(APCDVSIT,0),U,7)="H"

                           IF $$DSCHDATE^APCLV(APCDVSIT)]""

                               SET D=$$DSCHDATE^APCLV(APCDVSIT)

                               QUIT 

 +7                    SET D=$PIECE($PIECE(^AUPNVSIT(APCDVSIT,0),U),".")

                   End DoDot:1

 +8        IF D=""

               SET D=$PIECE($GET(APCDDATE),".")

 +9        IF D=""

               SET D=DT

 +10      ;get ien of coding system

           SET I=$$IMP^AUPNSICD(D)

 +11       IF I=1

               Begin DoDot:1

 +12               DO EN^DDIOL("Enter a cause of injury ""E"" code.")

 +13               DO EN^DDIOL("  ")

 +14      ;Q:X="?"

 +15               IF X="?BAD"

                       QUIT 

 +16               IF '$$ASKLIST()

                       QUIT 

 +17               NEW AUPNC

 +18               KILL ^TMP($JOB,"APCDCODE")

                   SET AUPNC=$NAME(^TMP($JOB,"APCDCODE"))

 +19               DO LST^ATXAPI(1,80,"E*","CODE",AUPNC)

 +20      ;display to screen until "^"

 +21               NEW AUPNX,AUPNY,AUPNQ,AUPNF,X

 +22               SET AUPNX=""

                   SET AUPNQ=0

                   SET AUPNF=0

                   FOR 

                       SET AUPNX=$ORDER(^TMP($JOB,"APCDCODE",AUPNX))

                       IF AUPNX=""!($GET(AUPNQ))

                           QUIT 

                       Begin DoDot:2

 +23                       IF AUPNF

                               IF $Y>(IOSL-2)

                                   DO EOP

                                   IF AUPNQ

                                       QUIT 

 +24      ;CHECK FOR ACTIVE STATUS

 +25                       SET %=$$ICDDX^ICDEX($PIECE(^TMP($JOB,"APCDCODE",AUPNX),U,1),D,,"I")

 +26      ;inactive on this date

                           IF '$PIECE(%,U,10)

                               QUIT 

 +27                       SET X=AUPNX

                           SET $EXTRACT(X,12)=$PIECE(%,U,4)

 +28                       DO EN^DDIOL(X)

 +29                       SET AUPNF=1

                       End DoDot:2

 +30               KILL ^TMP($JOB,"APCDCODE")

               End DoDot:1

               QUIT 

 +31       IF I=30

               Begin DoDot:1

 +32               DO EN^DDIOL("Must be an external cause of morbidity code.  The code range is V00-Y99.")

 +33               DO EN^DDIOL("  ")

 +34      ;Q:X="?"

 +35               IF X="?BAD"

                       QUIT 

 +36               IF '$$ASKLIST()

                       QUIT 

 +37               NEW AUPNC

 +38               KILL ^TMP($JOB,"APCDCODE")

                   SET AUPNC=$NAME(^TMP($JOB,"APCDCODE"))

 +39               DO LST^ATXAPI(30,80,"V01-Y99.Z","CODE",AUPNC)

 +40      ;display to screen until "^"

 +41               NEW AUPNX,AUPNY,AUPNQ,AUPNF,X

 +42               SET AUPNX=""

                   SET AUPNQ=0

                   SET AUPNF=0

                   FOR 

                       SET AUPNX=$ORDER(^TMP($JOB,"APCDCODE",AUPNX))

                       IF AUPNX=""!($GET(AUPNQ))

                           QUIT 

                       Begin DoDot:2

 +43                       IF AUPNF

                               IF $Y>(IOSL-2)

                                   DO EOP

                                   IF AUPNQ

                                       QUIT 

 +44      ;CHECK FOR ACTIVE STATUS

 +45                       SET %=$$ICDDX^ICDEX($PIECE(^TMP($JOB,"APCDCODE",AUPNX),U,1),D,,"I")

 +46      ;inactive on this date

                           IF '$PIECE(%,U,10)

                               QUIT 

 +47                       SET X=AUPNX