FBAAPM.m

FBAAPM ;AISC/DMK,GRR - CREATE PATIENT MRA TRANSACTION ;6/5/2009

 ;;3.5;FEE BASIS;**13,108**;JAN 30, 1995;Build 115

 ;;Per VHA Directive 2004-038, this routine should not be modified.

1 Q:'$D(FBMTYPE)

 D GETVET^FBAAUTL1 G END:'DFN

 D GETAUTH^FBAAUTL1 G 1:FTP']""

 S FBD1=+FTP

3 W ! S DIR("A")="Are you sure you want to create a '"_$S(FBMTYPE="A":"Add",FBMTYPE="D":"Delete",FBMTYPE="C":"Change",FBMTYPE="R":"Reinstate",1:"")_"' type MRA for this patient",DIR("B")="Yes",DIR(0)="Y"

 D ^DIR K DIR G 1:$D(DIRUT)!('Y)

 S FBMST=$S($P(^FBAAA(DFN,1,FBD1,0),"^",13)=1:"Y",1:"")

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

 S DR="1////^S X=""P"";2////^S X=FBD1;S Y=$S(FBMST="""":3,1:6);6////^S X=FBMST;3////^S X=FBMTYPE"

 ; for Change MRA (expect State Home) ask if From Date was changed

 I FBMTYPE="C",$P($G(^FBAAA(DFN,1,FBD1,0)),U,13)'=4 S DR=DR_";5"

 S DIE=DIC K DD,DO D FILE^DICN K DLAYGO G:Y<0 END S DA=+Y

 D ^DIE I $D(Y)>0 S DIK=DIE D ^DIK W !,*7,"MRA deleted.",! G 1

 W !!,"Transaction Created!"

 I FBMTYPE="D" S $P(^FBAAA(DFN,1,FBD1,"ADEL"),"^",1,2)="Y^"_DT

 I FBMTYPE="R"!(FBMTYPE="A") S:$D(^FBAAA(DFN,1,FBD1,"ADEL")) ^("ADEL")=""

 G 1

END K DIC,CNT,Y,X,I,DIC,D0,DFN,F,C,FBD1,DA,DAT,DI,DIE,DQ,DR,PE,FBMST,FBMTYPE,FBVEN,FTP,FBPSA,FBLOC,FBASSOC,FB7078,FBAABDT,FBAAEDT,FBAAOUT,FBAUT,FBPOV,FBPROG,FBPT,FBTT,FBTYPE,PI,TA,Z,FBDMRA

 D GETAUTHK^FBAAUTL1

 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---FBAAPM   1380     printed  Apr 09, 2024@21:07:15                                                                                                                                                                                                      Page 2

FBAAPM    ;AISC/DMK,GRR - CREATE PATIENT MRA TRANSACTION ;6/5/2009

 +1       ;;3.5;FEE BASIS;**13,108**;JAN 30, 1995;Build 115

 +2       ;;Per VHA Directive 2004-038, this routine should not be modified.

1          if '$DATA(FBMTYPE)

               QUIT 

 +1        DO GETVET^FBAAUTL1

           if 'DFN

               GOTO END

 +2        DO GETAUTH^FBAAUTL1

           if FTP']""

               GOTO 1

 +3        SET FBD1=+FTP

3          WRITE !

           SET DIR("A")="Are you sure you want to create a '"_$SELECT(FBMTYPE="A":"Add",FBMTYPE="D":"Delete",FBMTYPE="C":"Change",FBMTYPE="R":"Reinstate",1:"")_"' type MRA for this patient"

           SET DIR("B")="Yes"

           SET DIR(0)="Y"

 +1        DO ^DIR

           KILL DIR

           if $DATA(DIRUT)!('Y)

               GOTO 1

 +2        SET FBMST=$SELECT($PIECE(^FBAAA(DFN,1,FBD1,0),"^",13)=1:"Y",1:"")

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

           SET DIC(0)="L"

           SET DLAYGO=161.26

           SET X=DFN

 +4        SET DR="1////^S X=""P"";2////^S X=FBD1;S Y=$S(FBMST="""":3,1:6);6////^S X=FBMST;3////^S X=FBMTYPE"

 +5       ; for Change MRA (expect State Home) ask if From Date was changed

 +6        IF FBMTYPE="C"

               IF $PIECE($GET(^FBAAA(DFN,1,FBD1,0)),U,13)'=4

                   SET DR=DR_";5"

 +7        SET DIE=DIC

           KILL DD,DO

           DO FILE^DICN

           KILL DLAYGO

           if Y<0

               GOTO END

           SET DA=+Y

 +8        DO ^DIE

           IF $DATA(Y)>0

               SET DIK=DIE

               DO ^DIK

               WRITE !,*7,"MRA deleted.",!

               GOTO 1

 +9        WRITE !!,"Transaction Created!"

 +10       IF FBMTYPE="D"

               SET $PIECE(^FBAAA(DFN,1,FBD1,"ADEL"),"^",1,2)="Y^"_DT

 +11       IF FBMTYPE="R"!(FBMTYPE="A")

               if $DATA(^FBAAA(DFN,1,FBD1,"ADEL"))

                   SET ^("ADEL")=""

 +12       GOTO 1

END        KILL DIC,CNT,Y,X,I,DIC,D0,DFN,F,C,FBD1,DA,DAT,DI,DIE,DQ,DR,PE,FBMST,FBMTYPE,FBVEN,FTP,FBPSA,FBLOC,FBASSOC,FB7078,FBAABDT,FBAAEDT,FBAAOUT,FBAUT,FBPOV,FBPROG,FBPT,FBTT,FBTYPE,PI,TA,Z,FBDMRA

 +1        DO GETAUTHK^FBAAUTL1

 +2        QUIT