IBCEP9A.m

IBCEP9A ;ALB/CXW - PROVIDER EXTRACT ;26-SEP-00

 ;;2.0;INTEGRATED BILLING;**137**;21-MAR-94

 ; This routine is to build an extract file with provider information

 ; by looking at different file sources

 ; DBIA's used: DBIA418, DBIA419, 2546

 ;

START(IBRAW) ; Extract a list of providers from existing VistA data

 ; IBRAW = 0 or "" if display format

 ;       = 1 if raw data format

 ; Variables:

 ;      IBYR1/IBYR3 - the first date of next year

 ;      IBYR2       - the last date two years ago

 ;      IBPID       - provider entry number

 ;      HFLE        - host file name

 ;

 N IBCONT,IBYR1,IBYR2,IBYR3,IBPTF,IBPID,IBPINT,IBDFN,IBDT,IBIEN

 S IBCONT=0,IBRAW=$G(IBRAW)

 D NOW^%DTC

 S (IBYR1,IBYR3)=$E(X,1,3)+1_"0101"

 S IBYR2=$E(X,1,3)-2_"1230"

 K ^TMP("IBPID",$J)

 D PTF,VST

 Q:IBRAW

 D DATA

 I '$D(^TMP("IBPID",$J)) W "No data found"

 Q

 ;

PTF ;PTF (file 45/field 50) with admission within last two years DBIA419

 F  S IBYR1=$O(^DGPM("AMV1",IBYR1),-1) Q:'IBYR1!(IBYR1\1<IBYR2)  S IBDFN=0 F  S IBDFN=$O(^DGPM("AMV1",IBYR1,IBDFN)) Q:'IBDFN  S IBIEN=0 F  S IBIEN=$O(^DGPM("AMV1",IBYR1,IBDFN,IBIEN)) Q:'IBIEN  D

 . ; DBIA418

 . S IBPTF=+$P($G(^DGPM(IBIEN,0)),U,16)

 . Q:'IBPTF

 . S IBPID=$G(^DGPT(IBPTF,70)),IBPID=$P(IBPID,"^",15)

 . I IBPID S ^TMP("IBPID",$J,IBPID)=""

 . ;501 movement (file 45.02)

 . S IBDT=0 F  S IBDT=$O(^DGPT(IBPTF,"M","AM",IBDT)) Q:'IBDT  S IBPINT=0 F  S IBPINT=$O(^DGPT(IBPTF,"M","AM",IBDT,IBPINT)) Q:'IBPINT  D

 .. S IBPID=$G(^DGPT(IBPTF,"M",IBPINT,"P")),IBPID=$P(IBPID,"^",5)

 .. I IBPID S ^TMP("IBPID",$J,IBPID)=""

 Q

 ;

VST ; get providers associated with outpatient encntrs within the last 2 yrs

 ;

 N IBVAL,IBCBK

 S IBVAL("BDT")=IBYR2,IBVAL("EDT")=IBYR3

 S IBCBK="D VSTPRV^IBCEP9A(Y)"

 D SCAN^IBSDU("DATE/TIME",.IBVAL,"",IBCBK,1) ; Get all encntrs in dt rnge

 Q

 ;

VSTPRV(IBOE) ; Get all providers for an encounter IBOE

 N IBPID,Z

 D GETPRV^SDOE(IBOE,"IBPID")

 S Z=0 F  S Z=$O(IBPID(Z)) Q:'Z  I +IBPID(Z) S ^TMP("IBPID",$J,+IBPID(Z))=""

 Q

 ;

DATA ;store data in file

 N IBNAM,IBSSN,IBDGE

 S IBPID=0

 F  S IBPID=$O(^TMP("IBPID",$J,IBPID)) Q:'IBPID  D

 . S IBNAM=$P($G(^VA(200,IBPID,0)),"^")

 . S IBSSN=$P($G(^VA(200,IBPID,1)),"^",9)

 . S IBDGE=$P($G(^VA(200,IBPID,3.1)),"^",6)

 . S ^TMP("IBPID",$J,IBPID)=IBNAM_$J("",40-$L(IBNAM))_IBSSN_$J("",9-$L(IBSSN))_IBDGE_$J("",10-$L(IBDGE))

 Q

 ;

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---IBCEP9A   2381     printed  Apr 23, 2025@18:26:28                                                                                                                                                                                                     Page 2

IBCEP9A   ;ALB/CXW - PROVIDER EXTRACT ;26-SEP-00

 +1       ;;2.0;INTEGRATED BILLING;**137**;21-MAR-94

 +2       ; This routine is to build an extract file with provider information

 +3       ; by looking at different file sources

 +4       ; DBIA's used: DBIA418, DBIA419, 2546

 +5       ;

START(IBRAW) ; Extract a list of providers from existing VistA data

 +1       ; IBRAW = 0 or "" if display format

 +2       ;       = 1 if raw data format

 +3       ; Variables:

 +4       ;      IBYR1/IBYR3 - the first date of next year

 +5       ;      IBYR2       - the last date two years ago

 +6       ;      IBPID       - provider entry number

 +7       ;      HFLE        - host file name

 +8       ;

 +9        NEW IBCONT,IBYR1,IBYR2,IBYR3,IBPTF,IBPID,IBPINT,IBDFN,IBDT,IBIEN

 +10       SET IBCONT=0

           SET IBRAW=$GET(IBRAW)

 +11       DO NOW^%DTC

 +12       SET (IBYR1,IBYR3)=$EXTRACT(X,1,3)+1_"0101"

 +13       SET IBYR2=$EXTRACT(X,1,3)-2_"1230"

 +14       KILL ^TMP("IBPID",$JOB)

 +15       DO PTF

           DO VST

 +16       if IBRAW

               QUIT 

 +17       DO DATA

 +18       IF '$DATA(^TMP("IBPID",$JOB))

               WRITE "No data found"

 +19       QUIT 

 +20      ;

PTF       ;PTF (file 45/field 50) with admission within last two years DBIA419

 +1        FOR 

               SET IBYR1=$ORDER(^DGPM("AMV1",IBYR1),-1)

               if 'IBYR1!(IBYR1\1<IBYR2)

                   QUIT 

               SET IBDFN=0

               FOR 

                   SET IBDFN=$ORDER(^DGPM("AMV1",IBYR1,IBDFN))

                   if 'IBDFN

                       QUIT 

                   SET IBIEN=0

                   FOR 

                       SET IBIEN=$ORDER(^DGPM("AMV1",IBYR1,IBDFN,IBIEN))

                       if 'IBIEN

                           QUIT 

                       Begin DoDot:1

 +2       ; DBIA418

 +3                        SET IBPTF=+$PIECE($GET(^DGPM(IBIEN,0)),U,16)

 +4                        if 'IBPTF

                               QUIT 

 +5                        SET IBPID=$GET(^DGPT(IBPTF,70))

                           SET IBPID=$PIECE(IBPID,"^",15)

 +6                        IF IBPID

                               SET ^TMP("IBPID",$JOB,IBPID)=""

 +7       ;501 movement (file 45.02)

 +8                        SET IBDT=0

                           FOR 

                               SET IBDT=$ORDER(^DGPT(IBPTF,"M","AM",IBDT))

                               if 'IBDT

                                   QUIT 

                               SET IBPINT=0

                               FOR 

                                   SET IBPINT=$ORDER(^DGPT(IBPTF,"M","AM",IBDT,IBPINT))

                                   if 'IBPINT

                                       QUIT 

                                   Begin DoDot:2

 +9                                    SET IBPID=$GET(^DGPT(IBPTF,"M",IBPINT,"P"))

                                       SET IBPID=$PIECE(IBPID,"^",5)

 +10                                   IF IBPID

                                           SET ^TMP("IBPID",$JOB,IBPID)=""

                                   End DoDot:2

                       End DoDot:1

 +11       QUIT 

 +12      ;

VST       ; get providers associated with outpatient encntrs within the last 2 yrs

 +1       ;

 +2        NEW IBVAL,IBCBK

 +3        SET IBVAL("BDT")=IBYR2

           SET IBVAL("EDT")=IBYR3

 +4        SET IBCBK="D VSTPRV^IBCEP9A(Y)"

 +5       ; Get all encntrs in dt rnge

           DO SCAN^IBSDU("DATE/TIME",.IBVAL,"",IBCBK,1)

 +6        QUIT 

 +7       ;

VSTPRV(IBOE) ; Get all providers for an encounter IBOE

 +1        NEW IBPID,Z

 +2        DO GETPRV^SDOE(IBOE,"IBPID")

 +3        SET Z=0

           FOR 

               SET Z=$ORDER(IBPID(Z))

               if 'Z

                   QUIT 

               IF +IBPID(Z)

                   SET ^TMP("IBPID",$JOB,+IBPID(Z))=""

 +4        QUIT 

 +5       ;

DATA      ;store data in file

 +1        NEW IBNAM,IBSSN,IBDGE

 +2        SET IBPID=0

 +3        FOR 

               SET IBPID=$ORDER(^TMP("IBPID",$JOB,IBPID))

               if 'IBPID

                   QUIT 

               Begin DoDot:1

 +4                SET IBNAM=$PIECE($GET(^VA(200,IBPID,0)),"^")

 +5                SET IBSSN=$PIECE($GET(^VA(200,IBPID,1)),"^",9)

 +6                SET IBDGE=$PIECE($GET(^VA(200,IBPID,3.1)),"^",6)

 +7                SET ^TMP("IBPID",$JOB,IBPID)=IBNAM_$JUSTIFY("",40-$LENGTH(IBNAM))_IBSSN_$JUSTIFY("",9-$LENGTH(IBSSN))_IBDGE_$JUSTIFY("",10-$LENGTH(IBDGE))

               End DoDot:1

 +8        QUIT 

 +9       ;