AUPNSICA.m

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       ;