FBPATDAT.m

FBPATDAT ;WOIFO/SS-NOTIFICATION ABOUT PATIENT DATA CHANGE ;4/7/2003

 ;;3.5;FEE BASIS;**57,70**;JAN 30, 1995

 ;;Per VHA Directive 10-93-142, this routine should not be modified.

CHNG ;entry point

 I $G(DGFILE)=2.141 D UPDADR($G(DGDA)) Q  ;CONFIDENTIAL ADDRESS CATEGORY subfile fields

 Q:$G(DGFILE)'=2

 N FBFLAG S FBFLAG=0

 N FBFLD

 F FBFLD=.351,.03,.111,.112,.113,.114,.115,.116,.1112,.1411,.1412,.1413,.1414,.1415,.1416,.1417,.1418,2.141 I $G(DGFIELD)=FBFLD S FBFLAG=1 Q

 Q:'FBFLAG

 D UPDADR($G(DGDA))

 Q

 ;send patient MRA message to AAC

 ;

UPDADR(FBDFN) ;

 Q:+$G(FBDFN)=0

 N FBFRDT,FBTODT,FBTRTYP,FBZTH,FBDEL S (FBZTH,FBDEL)=""

 N FBAUTH,FBARR,FBLIMDT,FBTODAY,FB1 S (FBFRDT,FBTODT,FBTRTYP,FBAUTH,FBARR,FBTODAY,FBLIMDT,FB1)=0

 D  ;limit date is TODAY - 2 year

 . N X D NOW^%DTC S FBTODAY=X,FBLIMDT=+(($E(X,1,3)-2)_$E(X,4,7))

 ;go thru all authorizations for this patient

 ;and process all of them except SHORT TERM (i.e. only ID, HOME HEALTH and STATE HOME)

 F  S FBAUTH=$O(^FBAAA(FBDFN,1,FBAUTH)) Q:+FBAUTH=0  D

 . ;get zeroth node

 . S FBZTH=$G(^FBAAA(FBDFN,1,FBAUTH,0))

 . ;TO DATE, FROM DATE, Treatment type

 . S FBTODT=$P(FBZTH,"^",2),FBFRDT=$P(FBZTH,"^"),FBTRTYP=$P(FBZTH,"^",13)

 . Q:FBTRTYP<1!(FBTRTYP>4)

 . Q:FBTRTYP=1  ;short terms will be processed via file #161.26

 . ;apply to different rules depend on treatment type

 . Q:FBTODT<FBLIMDT&((FBTRTYP=2)!(FBTRTYP=3))  ;ID and HOME HEALTH

 . Q:(FBTRTYP=4)&(FBTODT<FBTODAY)  ;STATE HOME

 . S FBDEL=$G(^FBAAA(FBDFN,1,FBAUTH,"ADEL"))

 . Q:$P(FBDEL,"^")=1!($P(FBDEL,"^")="Y")  ;the 'Delete MRA' was transmitted to Austin DPC.

 . ;store AUTHORIZATION details in the local array

 . S FB1=+$O(FBARR(FBTRTYP,0))

 . I FB1 I FBTODT'>$P(FBARR(FBTRTYP,FB1),"^",4) Q  ;more recent one already there

 . I FB1 K FBARR(FBTRTYP,FB1) ;kill this one and then replace it (below)

 . S FBARR(FBTRTYP,9999999-FBTODT)=FBDFN_"^"_FBAUTH_"^"_FBFRDT_"^"_FBTODT

 ;add SHORT TERM authorizations to the local array from file #161.26

 D DOSHORT(.FBARR,FBDFN,FBTODAY)

 ;go thru all authorizations selected and saved in the local array

 F FBTRTYP=1,2,3,4 D DOEACH(.FBARR,FBTRTYP)

 Q

 ;

 ;SHORT-TERM (1) Authorizations

DOSHORT(FBARR1,FBDFN,FBTODAY) ;

 Q:+$G(FBDFN)=0

 Q:'$D(FBARR1)

 Q:+$G(FBTODAY)=0

 N FBDT30  ;30 days back

 D

 . N X1,X2,X S X1=FBTODAY,X2=-30 D C^%DTC S FBDT30=X

 ;go thru file #161.26

 N FB1,FB2,FB3,FBDT S (FB2,FB1,FB3)=0

 F  S FB1=$O(^FBAA(161.26,"B",FBDFN,FB1)) Q:+FB1=0  D

 . S FB2=^FBAA(161.26,FB1,0)

 . Q:$P(FB2,"^",7)'="Y"  ;only SHORT TERM

 . Q:$P(FB2,"^",4)="D"  ;we are not interested in DELETE transactions

 . S FBDT=+$P(FB2,"^",5)

 . Q:'FBDT  ;no date

 . ; store in local array

 . I FBDT>FBDT30 D

 . . S FB3=+$O(FBARR1(1,0))

 . . I FB3 I FBDT'>$P(FBARR1(1,FB3),"^",4) Q

 . . I FB1 K FBARR1(1,FB3)

 . . S FBARR1(1,9999999-FBDT)=FBDFN_"^"_$P(FB2,"^",3)_"^^"_FBDT

 Q

 ;SHOR TERM (1)

 ;ID CARD (3) Authorizations

 ;HOME HEALTH (2) Authorizations

 ;STATE HOME (4) Authorizations 

DOEACH(FBARR2,FBTYPE) ;

 Q:'$D(FBARR2)

 N FB1,FBAUTH,FBDFN

 S FB1=$O(FBARR2(FBTYPE,0))

 Q:+FB1=0

 S FBDFN=$P($G(FBARR2(FBTYPE,FB1)),"^")

 S FBAUTH=$P($G(FBARR2(FBTYPE,FB1)),"^",2)

 ;check if there is a pending tramsmission in file

 Q:$$ISPEND(FBDFN,FBAUTH)  ;quit if it is there

 ;send patient MRA to AAC

 D SENDMRA(FBDFN,FBAUTH,FBTYPE)

 Q

 ;

 ;returns 1 if pending or if it is "delete" transaction

 ;returns 0 if was transmitted or there are no transmission at all

ISPEND(FBDFN,FBAUTH) ;

 N FB1,FB2,FBFLGP,FBFLGD S (FB2,FB1,FBFLGP,FBFLGD)=0

 F  S FB1=$O(^FBAA(161.26,"B",FBDFN,FB1)) Q:+FB1=0  D  Q:FBFLGP!FBFLGD

 . S FB2=$G(^FBAA(161.26,FB1,0))

 . I +$P(FB2,"^",3)'=FBAUTH Q

 . S:$P(FB2,"^",2)="P" FBFLGP=1

 . S:$P(FB2,"^",4)="D" FBFLGD=1

 Q:FBFLGP 1

 Q:FBFLGD 1

 Q 0

 ;

SENDMRA(FBDFN,FBAUTH,FBTRTYPE) ;

 N DD,DO,DIC,DLAYGO,DDER,DA

 ;SHORT TERM auth-tions:

 I FBTRTYPE=1 D  Q

 . S DIC="^FBAA(161.26,",DIC(0)="L",DLAYGO=161.26,X=FBDFN

 . S DIC("DR")="1///^S X=""P"";2///^S X=FBAUTH;3///^S X=""A"";6////^S X=""Y"""

 . D FILE^DICN

 ;all other types of auth-tions:

 I $$QMRA^FBSHAUT(FBDFN,FBAUTH,"C")

 Q

 ;

 ;FBPATDAT

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---FBPATDAT   4156     printed  Apr 23, 2025@18:13:58                                                                                                                                                                                                    Page 2

FBPATDAT  ;WOIFO/SS-NOTIFICATION ABOUT PATIENT DATA CHANGE ;4/7/2003

 +1       ;;3.5;FEE BASIS;**57,70**;JAN 30, 1995

 +2       ;;Per VHA Directive 10-93-142, this routine should not be modified.

CHNG      ;entry point

 +1       ;CONFIDENTIAL ADDRESS CATEGORY subfile fields

           IF $GET(DGFILE)=2.141

               DO UPDADR($GET(DGDA))

               QUIT 

 +2        if $GET(DGFILE)'=2

               QUIT 

 +3        NEW FBFLAG

           SET FBFLAG=0

 +4        NEW FBFLD

 +5        FOR FBFLD=.351,.03,.111,.112,.113,.114,.115,.116,.1112,.1411,.1412,.1413,.1414,.1415,.1416,.1417,.1418,2.141

               IF $GET(DGFIELD)=FBFLD

                   SET FBFLAG=1

                   QUIT 

 +6        if 'FBFLAG

               QUIT 

 +7        DO UPDADR($GET(DGDA))

 +8        QUIT 

 +9       ;send patient MRA message to AAC

 +10      ;

UPDADR(FBDFN) ;

 +1        if +$GET(FBDFN)=0

               QUIT 

 +2        NEW FBFRDT,FBTODT,FBTRTYP,FBZTH,FBDEL

           SET (FBZTH,FBDEL)=""

 +3        NEW FBAUTH,FBARR,FBLIMDT,FBTODAY,FB1

           SET (FBFRDT,FBTODT,FBTRTYP,FBAUTH,FBARR,FBTODAY,FBLIMDT,FB1)=0

 +4       ;limit date is TODAY - 2 year

           Begin DoDot:1

 +5            NEW X

               DO NOW^%DTC

               SET FBTODAY=X

               SET FBLIMDT=+(($EXTRACT(X,1,3)-2)_$EXTRACT(X,4,7))

           End DoDot:1

 +6       ;go thru all authorizations for this patient

 +7       ;and process all of them except SHORT TERM (i.e. only ID, HOME HEALTH and STATE HOME)

 +8        FOR 

               SET FBAUTH=$ORDER(^FBAAA(FBDFN,1,FBAUTH))

               if +FBAUTH=0

                   QUIT 

               Begin DoDot:1

 +9       ;get zeroth node

 +10               SET FBZTH=$GET(^FBAAA(FBDFN,1,FBAUTH,0))

 +11      ;TO DATE, FROM DATE, Treatment type

 +12               SET FBTODT=$PIECE(FBZTH,"^",2)

                   SET FBFRDT=$PIECE(FBZTH,"^")

                   SET FBTRTYP=$PIECE(FBZTH,"^",13)

 +13               if FBTRTYP<1!(FBTRTYP>4)

                       QUIT 

 +14      ;short terms will be processed via file #161.26

                   if FBTRTYP=1

                       QUIT 

 +15      ;apply to different rules depend on treatment type

 +16      ;ID and HOME HEALTH

                   if FBTODT<FBLIMDT&((FBTRTYP=2)!(FBTRTYP=3))

                       QUIT 

 +17      ;STATE HOME

                   if (FBTRTYP=4)&(FBTODT<FBTODAY)

                       QUIT 

 +18               SET FBDEL=$GET(^FBAAA(FBDFN,1,FBAUTH,"ADEL"))

 +19      ;the 'Delete MRA' was transmitted to Austin DPC.

                   if $PIECE(FBDEL,"^")=1!($PIECE(FBDEL,"^")="Y")

                       QUIT 

 +20      ;store AUTHORIZATION details in the local array

 +21               SET FB1=+$ORDER(FBARR(FBTRTYP,0))

 +22      ;more recent one already there

                   IF FB1

                       IF FBTODT'>$PIECE(FBARR(FBTRTYP,FB1),"^",4)

                           QUIT 

 +23      ;kill this one and then replace it (below)

                   IF FB1

                       KILL FBARR(FBTRTYP,FB1)

 +24               SET FBARR(FBTRTYP,9999999-FBTODT)=FBDFN_"^"_FBAUTH_"^"_FBFRDT_"^"_FBTODT

               End DoDot:1

 +25      ;add SHORT TERM authorizations to the local array from file #161.26

 +26       DO DOSHORT(.FBARR,FBDFN,FBTODAY)

 +27      ;go thru all authorizations selected and saved in the local array

 +28       FOR FBTRTYP=1,2,3,4

               DO DOEACH(.FBARR,FBTRTYP)

 +29       QUIT 

 +30      ;

 +31      ;SHORT-TERM (1) Authorizations

DOSHORT(FBARR1,FBDFN,FBTODAY) ;

 +1        if +$GET(FBDFN)=0

               QUIT 

 +2        if '$DATA(FBARR1)

               QUIT 

 +3        if +$GET(FBTODAY)=0

               QUIT 

 +4       ;30 days back

           NEW FBDT30

 +5        Begin DoDot:1

 +6            NEW X1,X2,X

               SET X1=FBTODAY

               SET X2=-30

               DO C^%DTC

               SET FBDT30=X

           End DoDot:1

 +7       ;go thru file #161.26

 +8        NEW FB1,FB2,FB3,FBDT

           SET (FB2,FB1,FB3)=0

 +9        FOR 

               SET FB1=$ORDER(^FBAA(161.26,"B",FBDFN,FB1))

               if +FB1=0

                   QUIT 

               Begin DoDot:1

 +10               SET FB2=^FBAA(161.26,FB1,0)

 +11      ;only SHORT TERM

                   if $PIECE(FB2,"^",7)'="Y"

                       QUIT 

 +12      ;we are not interested in DELETE transactions

                   if $PIECE(FB2,"^",4)="D"

                       QUIT 

 +13               SET FBDT=+$PIECE(FB2,"^",5)

 +14      ;no date

                   if 'FBDT

                       QUIT 

 +15      ; store in local array

 +16               IF FBDT>FBDT30

                       Begin DoDot:2

 +17                       SET FB3=+$ORDER(FBARR1(1,0))

 +18                       IF FB3

                               IF FBDT'>$PIECE(FBARR1(1,FB3),"^",4)

                                   QUIT 

 +19                       IF FB1

                               KILL FBARR1(1,FB3)

 +20                       SET FBARR1(1,9999999-FBDT)=FBDFN_"^"_$PIECE(FB2,"^",3)_"^^"_FBDT

                       End DoDot:2

               End DoDot:1

 +21       QUIT 

 +22      ;SHOR TERM (1)

 +23      ;ID CARD (3) Authorizations

 +24      ;HOME HEALTH (2) Authorizations

 +25      ;STATE HOME (4) Authorizations 

DOEACH(FBARR2,FBTYPE) ;

 +1        if '$DATA(FBARR2)

               QUIT 

 +2        NEW FB1,FBAUTH,FBDFN

 +3        SET FB1=$ORDER(FBARR2(FBTYPE,0))

 +4        if +FB1=0

               QUIT 

 +5        SET FBDFN=$PIECE($GET(FBARR2(FBTYPE,FB1)),"^")

 +6        SET FBAUTH=$PIECE($GET(FBARR2(FBTYPE,FB1)),"^",2)

 +7       ;check if there is a pending tramsmission in file

 +8       ;quit if it is there

           if $$ISPEND(FBDFN,FBAUTH)

               QUIT 

 +9       ;send patient MRA to AAC

 +10       DO SENDMRA(FBDFN,FBAUTH,FBTYPE)

 +11       QUIT 

 +12      ;

 +13      ;returns 1 if pending or if it is "delete" transaction

 +14      ;returns 0 if was transmitted or there are no transmission at all

ISPEND(FBDFN,FBAUTH) ;

 +1        NEW FB1,FB2,FBFLGP,FBFLGD

           SET (FB2,FB1,FBFLGP,FBFLGD)=0

 +2        FOR 

               SET FB1=$ORDER(^FBAA(161.26,"B",FBDFN,FB1))

               if +FB1=0

                   QUIT 

               Begin DoDot:1

 +3                SET FB2=$GET(^FBAA(161.26,FB1,0))

 +4                IF +$PIECE(FB2,"^",3)'=FBAUTH

                       QUIT 

 +5                if $PIECE(FB2,"^",2)="P"

                       SET FBFLGP=1

 +6                if $PIECE(FB2,"^",4)="D"

                       SET FBFLGD=1

               End DoDot:1

               if FBFLGP!FBFLGD

                   QUIT 

 +7        if FBFLGP

               QUIT 1

 +8        if FBFLGD

               QUIT 1

 +9        QUIT 0

 +10      ;

SENDMRA(FBDFN,FBAUTH,FBTRTYPE) ;

 +1        NEW DD,DO,DIC,DLAYGO,DDER,DA

 +2       ;SHORT TERM auth-tions:

 +3        IF FBTRTYPE=1

               Begin DoDot:1

 +4                SET DIC="^FBAA(161.26,"

                   SET DIC(0)="L"

                   SET DLAYGO=161.26

                   SET X=FBDFN

 +5                SET DIC("DR")="1///^S X=""P"";2///^S X=FBAUTH;3///^S X=""A"";6////^S X=""Y"""

 +6                DO FILE^DICN

               End DoDot:1

               QUIT 

 +7       ;all other types of auth-tions:

 +8        IF $$QMRA^FBSHAUT(FBDFN,FBAUTH,"C")

 +9        QUIT 

 +10      ;

 +11      ;FBPATDAT