APCPDRPP.m

APCPDRPP ; IHS/TUCSON/LAB - OHPRD-TUCSON/LAB Check PV and Prov prior to tx generation AUGUST 14, 1992 ; [ 02/14/00 2:26 PM ]

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

 ;IHS/CMI/LAB - took out check for 2N on disc code only check for null

START ;

 K APCPE

 D CHKPROV

 G:$D(APCPE) EOJ

 I '$D(^AUPNVPOV("AD",APCP("V DFN"))) S APCPE("ERROR")="E102" Q

EOJ ;

 K APCPV("TX"),APCP1,APCP2

 Q

CHKPROV ;EP

 S (APCP1,APCP2)=0 F  S APCP2=$O(^AUPNVPRV("AD",APCP("V DFN"),APCP2)) Q:APCP2=""  I $P(^AUPNVPRV(APCP2,0),U,4)="P" S APCP1=APCP1+1,APCPV("PP VPRV DFN")=APCP2,APCPV("PP DFN")=$P(^AUPNVPRV(APCP2,0),U)

 I APCP1=0 S APCPE("ERROR")="E101" Q

 E  I APCP1>1 S APCPE("ERROR")="E103" Q

 ;store and save primary provider information

POS ; Provider Code. CP

 I APCPS("PROV FILE")=200,'$D(^VA(200,APCPV("PP DFN"))) S APCPE("ERROR")="E002" Q

 I APCPS("PROV FILE")=6,'$D(^DIC(6,APCPV("PP DFN"))) S APCPE("ERROR")="E002" Q

 S APCPV("PP AFFL")=$$VALI^XBDIQ1(APCPS("PROV FILE"),APCPV("PP DFN"),9999999.01) I APCPV("PP AFFL")="" S APCPE("ERROR")="E028" Q

 S APCPV("PP DISC")=$$VAL^XBDIQ1(APCPS("PROV FILE"),APCPV("PP DFN"),9999999.03) I APCPV("PP DISC")="" S APCPE("ERROR")="E027" Q

 S APCPV("PP CODE")=$$VAL^XBDIQ1(APCPS("PROV FILE"),APCPV("PP DFN"),9999999.02) I APCPV("PP CODE")="" S APCPE("ERROR")="E002" Q

 S I=$L(APCPV("PP CODE"))+1 F L=I:1:3 S APCPV("PP CODE")=APCPV("PP CODE")_" "

 S APCPV("PP POS")=APCPV("PP AFFL")_APCPV("PP DISC")_APCPV("PP CODE")

 K APCPL

 Q

APCPDRPP  ; IHS/TUCSON/LAB - OHPRD-TUCSON/LAB Check PV and Prov prior to tx generation AUGUST 14, 1992 ; [ 02/14/00 2:26 PM ]

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

 +2       ;IHS/CMI/LAB - took out check for 2N on disc code only check for null

START     ;

 +1        KILL APCPE

 +2        DO CHKPROV

 +3        IF $DATA(APCPE)

               GOTO EOJ

 +4        IF '$DATA(^AUPNVPOV("AD",APCP("V DFN")))

               SET APCPE("ERROR")="E102"

               QUIT 

EOJ       ;

 +1        KILL APCPV("TX"),APCP1,APCP2

 +2        QUIT 

CHKPROV   ;EP

 +1        SET (APCP1,APCP2)=0

           FOR 

               SET APCP2=$ORDER(^AUPNVPRV("AD",APCP("V DFN"),APCP2))

               IF APCP2=""

                   QUIT 

               IF $PIECE(^AUPNVPRV(APCP2,0),U,4)="P"

                   SET APCP1=APCP1+1

                   SET APCPV("PP VPRV DFN")=APCP2

                   SET APCPV("PP DFN")=$PIECE(^AUPNVPRV(APCP2,0),U)

 +2        IF APCP1=0

               SET APCPE("ERROR")="E101"

               QUIT 

 +3       IF '$TEST

               IF APCP1>1

                   SET APCPE("ERROR")="E103"

                   QUIT 

 +4       ;store and save primary provider information

POS       ; Provider Code. CP

 +1        IF APCPS("PROV FILE")=200

               IF '$DATA(^VA(200,APCPV("PP DFN")))

                   SET APCPE("ERROR")="E002"

                   QUIT 

 +2        IF APCPS("PROV FILE")=6

               IF '$DATA(^DIC(6,APCPV("PP DFN")))

                   SET APCPE("ERROR")="E002"

                   QUIT 

 +3        SET APCPV("PP AFFL")=$$VALI^XBDIQ1(APCPS("PROV FILE"),APCPV("PP DFN"),9999999.01)

           IF APCPV("PP AFFL")=""

               SET APCPE("ERROR")="E028"

               QUIT 

 +4        SET APCPV("PP DISC")=$$VAL^XBDIQ1(APCPS("PROV FILE"),APCPV("PP DFN"),9999999.03)

           IF APCPV("PP DISC")=""

               SET APCPE("ERROR")="E027"

               QUIT 

 +5        SET APCPV("PP CODE")=$$VAL^XBDIQ1(APCPS("PROV FILE"),APCPV("PP DFN"),9999999.02)

           IF APCPV("PP CODE")=""

               SET APCPE("ERROR")="E002"

               QUIT 

 +6        SET I=$LENGTH(APCPV("PP CODE"))+1

           FOR L=I:1:3

               SET APCPV("PP CODE")=APCPV("PP CODE")_" "

 +7        SET APCPV("PP POS")=APCPV("PP AFFL")_APCPV("PP DISC")_APCPV("PP CODE")

 +8        KILL APCPL

 +9        QUIT