Routine: APCPHOS1

APCPHOS1 ; IHS/TUCSON/LAB - REVIEW HOSPITALIZATIONS - CONT. AUGUST 14, 1992 ; [ 09/08/99 7:41 AM ]

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

START ;

CHKDXOP ; CHECK DX VS OPERATIONS AND CHECK FOR DUPLICATE POVS

 K APCPDUPE,APCPPOVS,APCPHDXP S APCPDX=0 F  S APCPDX=$O(^AUPNVPOV("AD",APCP("V DFN"),APCPDX)) Q:APCPDX=""!($D(APCPE))  S APCPPOVS(APCPDX)="" D CHKDXOP1

 K APCPDUPO,APCPVPRC,APCPOPP

 I $D(APCPE) G XIT

 S APCPOPX=0 F  S APCPOPX=$O(^AUPNVPRC("AD",APCP("V DFN"),APCPOPX)) Q:APCPOPX=""!$D(APCPE)  D CHKDXOP2

 G:$D(APCPE) XIT

 I $D(APCPDUPE),'$D(APCPV("ACC")) D DUPE G XIT

 I $D(APCPDUPO),'$D(APCPV("ACC")) D DUPEOP G XIT

 D C567

XIT ;

 K APCP1,APCP2,APCPDX,APCPOPX,APCPODX,APCPDUPE,APCPDUPO,APCPHDXP,APCPOPP,APCPHIT,APCPOPC,APCPPR,APCPPRC,APCPVPRC,APCPPOVS,APCPOPC

CHKDXOP1 ;

 I $D(APCPHDXP($P(^AUPNVPOV(APCPDX,0),U))) S APCPDUPE=1

 S APCPHDXP($P(^AUPNVPOV(APCPDX,0),U))=""

CHKDXOP2 ;

 S APCPODX=$P(^AUPNVPRC(APCPOPX,0),U,5) S:APCPODX]"" APCPVPRC(APCPOPX)=APCPODX_"^"_$P(^ICD9(APCPODX,0),U)

 I APCPODX="" S APCPE("EDFN")=APCPOPX,APCPE("FILE")=9000010.08,APCPE("ERROR")="E044" Q

 I $D(APCPOPP($P(^AUPNVPRC(APCPOPX,0),U))) S APCPDUPO=1

 S APCPOPP($P(^AUPNVPRC(APCPOPX,0),U))=""

 K APCPHIT F  S APCPDX=$O(APCPHDXP(APCPDX)) Q:APCPDX=""  I APCPDX=APCPODX S APCPHIT=1

 ;I '$D(APCPHIT) S APCPE("FILE")=9000010,APCPE("EDFN")=APCP("V DFN"),APCPE("ERROR")="E314" Q ;IHS/CMI/LAB - commented out

DUPE ;

 S APCPE("FILE")=9000010,APCPE("EDFN")=APCP("V DFN"),APCPE("ERROR")="E315" Q

DUPEOP ;WARNING RE:  DUPLICATE OPERATIONS USED - ACCEPT REQUIRED

 S APCPE("FILE")=9000010,APCPE("EDFN")=APCP("V DFN"),APCPE("ERROR")="E316" Q

C567 ;CHK DX VS OPS

 S APCP1=0 F  S APCP1=$O(APCPVPRC(APCP1)) Q:APCP1=""!$D(APCPE)  S APCP2=$P(APCPVPRC(APCP1),U,2),APCPOPC=$P(^ICD0($P(^AUPNVPRC(APCP1,0),U),0),U) D

 .I $D(^APCDINPT(5,11,"AC",APCP2)),'$D(^APCDINPT(5,12,"AC",APCPOPC)) S APCPE("ERROR")="E317",APCPE("EDFN")=APCP1,APCPE("FILE")=9000010.08

 .I $D(^APCDINPT(6,11,"AC",APCP2)),'$D(^APCDINPT(6,12,"AC",APCPOPC)) S APCPE("ERROR")="E317",APCPE("EDFN")=APCP1,APCPE("FILE")=9000010.08

 .I $D(^APCDINPT(7,11,"AC",APCP2)),'$D(^APCDINPT(7,12,"AC",APCPOPC)) S APCPE("ERROR")="E317",APCPE("EDFN")=APCP1,APCPE("FILE")=9000010.08

 Q:$D(APCPE)

 S APCP1=0 F  S APCP1=$O(APCPPOVS(APCP1)) Q:APCP1=""  S APCPDX=$P(^AUPNVPOV(APCP1,0),U) I $D(^APCDINPT(6,11,"AC",$P(^ICD9(APCPDX,0),U))) D C6ERR

C6ERR ;

 I '$D(APCPVPRC) S APCPE("ERROR")="E333",APCPE("FILE")=9000010,APCPE("EDFN")=APCP("V DFN") Q

 K APCPHIT S APCP2=0 F  S APCP2=$O(APCPVPRC(APCP2)) Q:APCP2=""  S APCPOPC=$P(^ICD0($P(^AUPNVPRC(APCP2,0),U),0),U) I $D(^APCDINPT(6,12,"AC",APCPOPC)),$P(APCPVPRC(APCP2),U)=APCPDX S APCPHIT=1

 I '$D(APCPHIT) S APCPE("ERROR")="E333",APCPE("FILE")=9000010,APCPE("EDFN")=APCP("V DFN")

APCPHOS1  ; IHS/TUCSON/LAB - REVIEW HOSPITALIZATIONS - CONT. AUGUST 14, 1992 ; [ 09/08/99 7:41 AM ]

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

 +2       ;

START     ;

CHKDXOP   ; CHECK DX VS OPERATIONS AND CHECK FOR DUPLICATE POVS

 +1        KILL APCPDUPE,APCPPOVS,APCPHDXP

           SET APCPDX=0

FOR

               SET APCPDX=$ORDER(^AUPNVPOV("AD",APCP("V DFN"),APCPDX))

               IF APCPDX=""!($DATA(APCPE))

                   QUIT

               SET APCPPOVS(APCPDX)=""

               DO CHKDXOP1

 +2        KILL APCPDUPO,APCPVPRC,APCPOPP

 +3        IF $DATA(APCPE)

               GOTO XIT

 +4        SET APCPOPX=0

FOR

               SET APCPOPX=$ORDER(^AUPNVPRC("AD",APCP("V DFN"),APCPOPX))

               IF APCPOPX=""!$DATA(APCPE)

                   QUIT

               DO CHKDXOP2

 +5        IF $DATA(APCPE)

               GOTO XIT

 +6        IF $DATA(APCPDUPE)

               IF '$DATA(APCPV("ACC"))

                   DO DUPE

                   GOTO XIT

 +7        IF $DATA(APCPDUPO)

               IF '$DATA(APCPV("ACC"))

                   DO DUPEOP

                   GOTO XIT

 +8        DO C567

XIT       ;

 +1        KILL APCP1,APCP2,APCPDX,APCPOPX,APCPODX,APCPDUPE,APCPDUPO,APCPHDXP,APCPOPP,APCPHIT,APCPOPC,APCPPR,APCPPRC,APCPVPRC,APCPPOVS,APCPOPC

 +2        QUIT

CHKDXOP1  ;

 +1        IF $DATA(APCPHDXP($PIECE(^AUPNVPOV(APCPDX,0),U)))

               SET APCPDUPE=1

 +2        SET APCPHDXP($PIECE(^AUPNVPOV(APCPDX,0),U))=""

 +3        QUIT

CHKDXOP2  ;

 +1        SET APCPODX=$PIECE(^AUPNVPRC(APCPOPX,0),U,5)

           IF APCPODX]""

               SET APCPVPRC(APCPOPX)=APCPODX_"^"_$PIECE(^ICD9(APCPODX,0),U)

 +2        IF APCPODX=""

               SET APCPE("EDFN")=APCPOPX

               SET APCPE("FILE")=9000010.08

               SET APCPE("ERROR")="E044"

               QUIT

 +3        IF $DATA(APCPOPP($PIECE(^AUPNVPRC(APCPOPX,0),U)))

               SET APCPDUPO=1

 +4        SET APCPOPP($PIECE(^AUPNVPRC(APCPOPX,0),U))=""

 +5        KILL APCPHIT

FOR

               SET APCPDX=$ORDER(APCPHDXP(APCPDX))

               IF APCPDX=""

                   QUIT

               IF APCPDX=APCPODX

                   SET APCPHIT=1

 +6       ;I '$D(APCPHIT) S APCPE("FILE")=9000010,APCPE("EDFN")=APCP("V DFN"),APCPE("ERROR")="E314" Q ;IHS/CMI/LAB - commented out

 +7        QUIT

DUPE      ;

 +1        SET APCPE("FILE")=9000010

           SET APCPE("EDFN")=APCP("V DFN")

           SET APCPE("ERROR")="E315"

           QUIT

 +2        QUIT

DUPEOP    ;WARNING RE:  DUPLICATE OPERATIONS USED - ACCEPT REQUIRED

 +1        SET APCPE("FILE")=9000010

           SET APCPE("EDFN")=APCP("V DFN")

           SET APCPE("ERROR")="E316"

           QUIT

 +2        QUIT

 +3       ;

C567      ;CHK DX VS OPS

 +1        SET APCP1=0

FOR

               SET APCP1=$ORDER(APCPVPRC(APCP1))

               IF APCP1=""!$DATA(APCPE)

                   QUIT

               SET APCP2=$PIECE(APCPVPRC(APCP1),U,2)

               SET APCPOPC=$PIECE(^ICD0($PIECE(^AUPNVPRC(APCP1,0),U),0),U)

               Begin DoDot:1

 +2                IF $DATA(^APCDINPT(5,11,"AC",APCP2))

                       IF '$DATA(^APCDINPT(5,12,"AC",APCPOPC))

                           SET APCPE("ERROR")="E317"

                           SET APCPE("EDFN")=APCP1

                           SET APCPE("FILE")=9000010.08

 +3                IF $DATA(^APCDINPT(6,11,"AC",APCP2))

                       IF '$DATA(^APCDINPT(6,12,"AC",APCPOPC))

                           SET APCPE("ERROR")="E317"

                           SET APCPE("EDFN")=APCP1

                           SET APCPE("FILE")=9000010.08

 +4                IF $DATA(^APCDINPT(7,11,"AC",APCP2))

                       IF '$DATA(^APCDINPT(7,12,"AC",APCPOPC))

                           SET APCPE("ERROR")="E317"

                           SET APCPE("EDFN")=APCP1

                           SET APCPE("FILE")=9000010.08

               End DoDot:1

 +5        IF $DATA(APCPE)

               QUIT

 +6        SET APCP1=0

FOR

               SET APCP1=$ORDER(APCPPOVS(APCP1))

               IF APCP1=""

                   QUIT

               SET APCPDX=$PIECE(^AUPNVPOV(APCP1,0),U)

               IF $DATA(^APCDINPT(6,11,"AC",$PIECE(^ICD9(APCPDX,0),U)))

                   DO C6ERR

 +7        QUIT

C6ERR     ;

 +1        IF '$DATA(APCPVPRC)

               SET APCPE("ERROR")="E333"

               SET APCPE("FILE")=9000010

               SET APCPE("EDFN")=APCP("V DFN")

               QUIT

 +2        KILL APCPHIT

           SET APCP2=0

FOR

               SET APCP2=$ORDER(APCPVPRC(APCP2))

               IF APCP2=""

                   QUIT

               SET APCPOPC=$PIECE(^ICD0($PIECE(^AUPNVPRC(APCP2,0),U),0),U)

               IF $DATA(^APCDINPT(6,12,"AC",APCPOPC))

                   IF $PIECE(APCPVPRC(APCP2),U)=APCPDX

                       SET APCPHIT=1

 +3        IF '$DATA(APCPHIT)

               SET APCPE("ERROR")="E333"

               SET APCPE("FILE")=9000010

               SET APCPE("EDFN")=APCP("V DFN")

 +4        QUIT

APCPHOS1.m