APCPAPRO.m

APCPAPRO ; IHS/TUCSON/LAB - get provider information for APC record AUGUST 14, 1992 ; [ 04/03/98  08:39 AM ]

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

 ;

PROV ;

 S (APCPAS1,APCPAS2,APCPAS3)="  ",APCPT("A PROVS")=""

 S (APCPT(1),APCPT(2))=0 F  S APCPT(2)=$O(^AUPNVPRV("AD",APCP("V DFN"),APCPT(2))) Q:APCPT(2)'=+APCPT(2)!(APCPT(1)=3)  D SEC

 I $D(APCPE("ERROR")) S APCPT("FILE")=9000010.06 D EOJ Q

 S APCPT("A PROVS")=APCPV("PP DISC")_APCPAS1_APCPAS2_APCPAS3

 D EOJ

 Q

EOJ ;

 K APCPAS1,APCPAS2,APCPAS3

 Q

SEC ;

 I $P(^AUPNVPRV(APCPT(2),0),U,4)="S" S APCPT("AP")=$P(^(0),U) D DISC I '$D(APCPE("ERROR")),APCPT("DISC")'=88 S APCPT(1)=APCPT(1)+1,APCPT("VAR")="APCPAS"_APCPT(1),@APCPT("VAR")=APCPT("DISC")

 Q

DISC ;

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

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

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

 Q

APCPAPRO  ; IHS/TUCSON/LAB - get provider information for APC record AUGUST 14, 1992 ; [ 04/03/98  08:39 AM ]

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

 +2       ;

PROV      ;

 +1        SET (APCPAS1,APCPAS2,APCPAS3)="  "

           SET APCPT("A PROVS")=""

 +2        SET (APCPT(1),APCPT(2))=0

           FOR 

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

               IF APCPT(2)'=+APCPT(2)!(APCPT(1)=3)

                   QUIT 

               DO SEC

 +3        IF $DATA(APCPE("ERROR"))

               SET APCPT("FILE")=9000010.06

               DO EOJ

               QUIT 

 +4        SET APCPT("A PROVS")=APCPV("PP DISC")_APCPAS1_APCPAS2_APCPAS3

 +5        DO EOJ

 +6        QUIT 

EOJ       ;

 +1        KILL APCPAS1,APCPAS2,APCPAS3

 +2        QUIT 

SEC       ;

 +1        IF $PIECE(^AUPNVPRV(APCPT(2),0),U,4)="S"

               SET APCPT("AP")=$PIECE(^(0),U)

               DO DISC

               IF '$DATA(APCPE("ERROR"))

                   IF APCPT("DISC")'=88

                       SET APCPT(1)=APCPT(1)+1

                       SET APCPT("VAR")="APCPAS"_APCPT(1)

                       SET @APCPT("VAR")=APCPT("DISC")

 +2        QUIT 

DISC      ;

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

               IF '$DATA(^VA(200,APCPT("AP")))

                   SET APCPE("ERROR")="E002"

                   QUIT 

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

               IF '$DATA(^DIC(6,APCPT("AP")))

                   SET APCPE("ERROR")="E002"

                   QUIT 

 +3        SET APCPT("DISC")=$$VAL^XBDIQ1(APCPS("PROV FILE"),APCPT("AP"),9999999.03)

           IF APCPT("DISC")=""

               SET APCPE("ERROR")="E027"

               QUIT 

 +4        QUIT