APCPCICD.m

APCPCICD ; IHS/TUCSON/LAB - CHECK ICD9 DIAGNOSIS CODE AUGUST 14, 1992 ; [ 04/03/98  08:39 AM ]

 ;;2.0;IHS PCC DATA EXTRACTION SYSTEM;;APR 03, 1998

 ;CALLED BY APCP16,APCP23,APCP31,APCP32,APCPACHA,APCPAH,APCPAPOV

 ;   - APCPHOP,APCPHPOV

EIN ; SCREEN OUT E CODES AND INACTIVE CODES

 I $E(APCPT("ICD"))="E" S APCPE("ERROR")="E047" Q

 I APCPT("ICD")=.9999 S APCPE("ERROR")="E026" Q

 I $P(^ICD9(APCPT("ICD PTR"),0),U,9)]"" S APCPE("ERROR")="E041" Q

 G:$E(APCPT("ICD"))="." SEX I $L($P(APCPT("ICD"),".",2))>2 S APCPE("ERROR")="E003" Q

SEX I $P(^ICD9(APCPT("ICD PTR"),0),U,10)]"",AUPNSEX'=$P(^ICD9(APCPT("ICD PTR"),0),U,10) S APCPE("ERROR")="E042" Q

AGE ; IF THERE IS AGE CRITERIA DATA AVAILABLE CHECK TO SEE THAT IT FITS THE CRITERIA

 K APCPT("AGEE")

 Q:'$D(^ICD9(APCPT("ICD PTR"),9999999))

 I $P(^ICD9(APCPT("ICD PTR"),9999999),U)]"",($P(^ICD9(APCPT("ICD PTR"),9999999),U)>AUPNDAYS) S APCPT("AGEE")="" Q

 I $P(^ICD9(APCPT("ICD PTR"),9999999),U,2)]"",($P(^ICD9(APCPT("ICD PTR"),9999999),U,2)<AUPNDAYS) S APCPT("AGEE")="" Q

 ;

APCPCICD  ; IHS/TUCSON/LAB - CHECK ICD9 DIAGNOSIS CODE AUGUST 14, 1992 ; [ 04/03/98  08:39 AM ]

 +1       ;;2.0;IHS PCC DATA EXTRACTION SYSTEM;;APR 03, 1998

 +2       ;CALLED BY APCP16,APCP23,APCP31,APCP32,APCPACHA,APCPAH,APCPAPOV

 +3       ;   - APCPHOP,APCPHPOV

EIN       ; SCREEN OUT E CODES AND INACTIVE CODES

 +1        IF $EXTRACT(APCPT("ICD"))="E"

               SET APCPE("ERROR")="E047"

               QUIT 

 +2        IF APCPT("ICD")=.9999

               SET APCPE("ERROR")="E026"

               QUIT 

 +3        IF $PIECE(^ICD9(APCPT("ICD PTR"),0),U,9)]""

               SET APCPE("ERROR")="E041"

               QUIT 

 +4        IF $EXTRACT(APCPT("ICD"))="."

               GOTO SEX

           IF $LENGTH($PIECE(APCPT("ICD"),".",2))>2

               SET APCPE("ERROR")="E003"

               QUIT 

SEX        IF $PIECE(^ICD9(APCPT("ICD PTR"),0),U,10)]""

               IF AUPNSEX'=$PIECE(^ICD9(APCPT("ICD PTR"),0),U,10)

                   SET APCPE("ERROR")="E042"

                   QUIT 

AGE       ; IF THERE IS AGE CRITERIA DATA AVAILABLE CHECK TO SEE THAT IT FITS THE CRITERIA

 +1        KILL APCPT("AGEE")

 +2        IF '$DATA(^ICD9(APCPT("ICD PTR"),9999999))

               QUIT 

 +3        IF $PIECE(^ICD9(APCPT("ICD PTR"),9999999),U)]""

               IF ($PIECE(^ICD9(APCPT("ICD PTR"),9999999),U)>AUPNDAYS)

                   SET APCPT("AGEE")=""

                   QUIT 

 +4        IF $PIECE(^ICD9(APCPT("ICD PTR"),9999999),U,2)]""

               IF ($PIECE(^ICD9(APCPT("ICD PTR"),9999999),U,2)<AUPNDAYS)

                   SET APCPT("AGEE")=""

                   QUIT 

 +5       ;