APCPSR2.m

APCPSR2 ; IHS/TUCSON/LAB - CONT. APCPSR1 AUGUST 14, 1992 ; [ 05/18/99 8:54 AM ]

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

 ;IHS/TUCSON/LAB - patch 3 made file 200 compatible

TYPE ;EP

 K ^UTILITY("DIQ1",$J)

 K DIQ,DIC,DA,DR

 S DIC="^AUPNVSIT(",DR=".03",DA=APCPSR("V"),DIQ(0)="E" D EN^DIQ1 K DIC,DA,DR,DIQ

 S APCPSR("TYPE")=^UTILITY("DIQ1",$J,9000010,APCPSR("V"),.03,"E")

 S X="^XTMP("_APCPSR("PROC")_",APCPVAR,APCPSR(""TYPE""))" D COUNT

 Q

SC ;EP

 K ^UTILITY("DIQ1",$J)

 K DIQ,DIC,DA,DR

 S DIC="^AUPNVSIT(",DR=".07",DA=APCPSR("V"),DIQ(0)="E" D EN^DIQ1 K DIC,DA,DR,DIQ

 S APCPSR("SC")=^UTILITY("DIQ1",$J,9000010,APCPSR("V"),.07,"E")

 S X="^XTMP("_APCPSR("PROC")_",APCPVAR,APCPSR(""SC""))" D COUNT

 K ^UTILITY("DIQ1",$J)

 Q

CLINIC ;EP

 S APCPSR("CLN")=$P(^AUPNVSIT(APCPSR("V"),0),U,8) I APCPSR("CLN")="" S APCPSR("CLN")="NO CLINIC",APCPSR("CLN CODE")="" G SETCLIN

 S APCPSR("CLN CODE")=$P(^DIC(40.7,APCPSR("CLN"),0),U,2),APCPSR("CLN")=$P(^DIC(40.7,APCPSR("CLN"),0),U)

 I APCPSR("CLN CODE")=56,$D(^AUPNVMED("AD",APCPSR("V"))),APCPVAR="CLINIC" D DENTAL^APCPSR1 S APCPSR("CLN")=APCPSR("PHARM NAME"),APCPSR("CLN CODE")=39

 ;Q:APCPSR("CLN CODE")=56

SETCLIN ;EP

 S X="^XTMP("_APCPSR("PROC")_",APCPVAR,APCPSR(""CLN""))" D COUNT

 ;

 Q

LOC ;EP

 S APCPSR("LOC")=$P(^AUPNVSIT(APCPSR("V"),0),U,6)

 S X="^XTMP("_APCPSR("PROC")_",APCPVAR,APCPSR(""LOC""))" D COUNT

 ;

 Q

PROV ;EP -provider type

 S APCPSR("X")=0 F  S APCPSR("X")=$O(^AUPNVPRV("AD",APCPSR("V"),APCPSR("X"))) Q:APCPSR("X")'=+APCPSR("X")  I $P(^AUPNVPRV(APCPSR("X"),0),U,4)="P" D PROV1

 Q

VD ;EP -tally by visit date

 S APCPSR("V DATE")=$P($P(^AUPNVSIT(APCPSR("V"),0),U),".")

 S X="^XTMP("_APCPSR("PROC")_",APCPVAR,APCPSR(""V DATE""))" D COUNT

 Q

PROV1 ;

 S APCPSR("PROV")=$P(^AUPNVPRV(APCPSR("X"),0),U)

 S APCPSR("DISC")=$$VAL^XBDIQ1(APCPS("PROV FILE"),APCPSR("PROV"),9999999.03)

 Q:APCPSR("DISC")=88

 Q:APCPSR("DISC")=""

 S APCPSR("DISC")=$$VAL^XBDIQ1(APCPS("PROV FILE"),APCPSR("PROV"),$S(APCPS("PROV FILE")=200:53.5,1:2))

 Q:APCPSR("DISC")=""

 S X="^XTMP("_APCPSR("PROC")_",APCPVAR,APCPSR(""DISC""))" D COUNT

 Q

 Q

COUNT ;

 I '$D(@X) S @X=0

 S %=@X,%=%+1,@X=%

 Q

C42 ;;

C51 ;

C52 ;;

C53 ;;

C54 ;;

C56 ;;

C60 ;;

C68 ;;

APCPSR2   ; IHS/TUCSON/LAB - CONT. APCPSR1 AUGUST 14, 1992 ; [ 05/18/99 8:54 AM ]

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

 +2       ;IHS/TUCSON/LAB - patch 3 made file 200 compatible

TYPE      ;EP

 +1        KILL ^UTILITY("DIQ1",$JOB)

 +2        KILL DIQ,DIC,DA,DR

 +3        SET DIC="^AUPNVSIT("

           SET DR=".03"

           SET DA=APCPSR("V")

           SET DIQ(0)="E"

           DO EN^DIQ1

           KILL DIC,DA,DR,DIQ

 +4        SET APCPSR("TYPE")=^UTILITY("DIQ1",$JOB,9000010,APCPSR("V"),.03,"E")

 +5        SET X="^XTMP("_APCPSR("PROC")_",APCPVAR,APCPSR(""TYPE""))"

           DO COUNT

 +6        QUIT 

SC        ;EP

 +1        KILL ^UTILITY("DIQ1",$JOB)

 +2        KILL DIQ,DIC,DA,DR

 +3        SET DIC="^AUPNVSIT("

           SET DR=".07"

           SET DA=APCPSR("V")

           SET DIQ(0)="E"

           DO EN^DIQ1

           KILL DIC,DA,DR,DIQ

 +4        SET APCPSR("SC")=^UTILITY("DIQ1",$JOB,9000010,APCPSR("V"),.07,"E")

 +5        SET X="^XTMP("_APCPSR("PROC")_",APCPVAR,APCPSR(""SC""))"

           DO COUNT

 +6        KILL ^UTILITY("DIQ1",$JOB)

 +7        QUIT 

CLINIC    ;EP

 +1        SET APCPSR("CLN")=$PIECE(^AUPNVSIT(APCPSR("V"),0),U,8)

           IF APCPSR("CLN")=""

               SET APCPSR("CLN")="NO CLINIC"

               SET APCPSR("CLN CODE")=""

               GOTO SETCLIN

 +2        SET APCPSR("CLN CODE")=$PIECE(^DIC(40.7,APCPSR("CLN"),0),U,2)

           SET APCPSR("CLN")=$PIECE(^DIC(40.7,APCPSR("CLN"),0),U)

 +3        IF APCPSR("CLN CODE")=56

               IF $DATA(^AUPNVMED("AD",APCPSR("V")))

                   IF APCPVAR="CLINIC"

                       DO DENTAL^APCPSR1

                       SET APCPSR("CLN")=APCPSR("PHARM NAME")

                       SET APCPSR("CLN CODE")=39

 +4       ;Q:APCPSR("CLN CODE")=56

SETCLIN   ;EP

 +1        SET X="^XTMP("_APCPSR("PROC")_",APCPVAR,APCPSR(""CLN""))"

           DO COUNT

 +2       ;

 +3        QUIT 

LOC       ;EP

 +1        SET APCPSR("LOC")=$PIECE(^AUPNVSIT(APCPSR("V"),0),U,6)

 +2        SET X="^XTMP("_APCPSR("PROC")_",APCPVAR,APCPSR(""LOC""))"

           DO COUNT

 +3       ;

 +4        QUIT 

PROV      ;EP -provider type

 +1        SET APCPSR("X")=0

           FOR 

               SET APCPSR("X")=$ORDER(^AUPNVPRV("AD",APCPSR("V"),APCPSR("X")))

               IF APCPSR("X")'=+APCPSR("X")

                   QUIT 

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

                   DO PROV1

 +2        QUIT 

VD        ;EP -tally by visit date

 +1        SET APCPSR("V DATE")=$PIECE($PIECE(^AUPNVSIT(APCPSR("V"),0),U),".")

 +2        SET X="^XTMP("_APCPSR("PROC")_",APCPVAR,APCPSR(""V DATE""))"

           DO COUNT

 +3        QUIT 

PROV1     ;

 +1        SET APCPSR("PROV")=$PIECE(^AUPNVPRV(APCPSR("X"),0),U)

 +2        SET APCPSR("DISC")=$$VAL^XBDIQ1(APCPS("PROV FILE"),APCPSR("PROV"),9999999.03)

 +3        IF APCPSR("DISC")=88

               QUIT 

 +4        IF APCPSR("DISC")=""

               QUIT 

 +5        SET APCPSR("DISC")=$$VAL^XBDIQ1(APCPS("PROV FILE"),APCPSR("PROV"),$SELECT(APCPS("PROV FILE")=200:53.5,1:2))

 +6        IF APCPSR("DISC")=""

               QUIT 

 +7        SET X="^XTMP("_APCPSR("PROC")_",APCPVAR,APCPSR(""DISC""))"

           DO COUNT

 +8        QUIT 

 +9        QUIT 

COUNT     ;

 +1        IF '$DATA(@X)

               SET @X=0

 +2        SET %=@X

           SET %=%+1

           SET @X=%

 +3        QUIT 

C42       ;;

C51       ;

C52       ;;

C53       ;;

C54       ;;

C56       ;;

C60       ;;

C68       ;;