Routine: FBCH780

FBCH780 ;AISC/DMK-7078/AUTHORIZATION CON'T ;8/18/2004

 ;;3.5;FEE BASIS;**82**;JAN 30, 1995

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

DISP D HOME^%ZIS W @IOF

 W !! S DA=FBAA78,DR="0;1",DIC="^FB7078(" D EN^DIQ

ASK S DIR(0)="Y",DIR("A")="Is this Correct",DIR("B")="NO" D ^DIR K DIR S:$D(DIRUT) FBOUT=1 Q:$G(FBOUT)  G EDIT:'Y

 S DFN=+$P($G(^FB7078(+FBAA78,0)),"^",3)

 W !,?2,"....Posting to 1358",! D WAIT^DICD,POST Q

END W ! Q

EDIT W ! S (DIC,DIE)="^FB7078(",DA=FBAA78,DR="[FBCH EDIT 7078]" D ^DIE

 G DISP

HELP W !!,"Select one of the following: ",!,?18,"'00' FOR SURGICAL",!,?18,"'10' FOR MEDICAL",!,?18,"'86' FOR PSYCHIATRY",! Q

POST S PRCS("X")=FBCHOB,PRCS("TYPE")="FB" D EN3^PRCS58 I Y=-1 W !!,*7,"1358 not available for posting!",! Q

 S FBCOMM=$S($D(FBNAME):FBNAME_" - "_FBSSN,1:"Estimated amount")

 D NOW^%DTC S X=FBCHOB_"^"_%_"^"_FBEST_"^"_""_"^"_FBSEQ_"^"_FBCOMM_"^"_DFN_";"_+FBAA78_";"_$P(FBCHOB,"-",2),PRCS("TYPE")="FB"

 D EN2^PRCS58 Q

NULL W !,*7,"Enter the reason for pending disposition or an '^' to exit",! G FBPDIS^FBCH78

NULL1 W !,*7,"This is a required response. Enter an '^' to exit.",! Q

DISCH(X) ;X = Pointer for 7078

 ;output = patient's Type of Discharge

N Y

 S Y=$O(^FBAAI("E",X_";FB7078(",0))

 I 'Y Q Y

 S Y=+$P($G(^FBAAI(Y,0)),U,21)

 Q $S($P($G(^FBAA(162.6,Y,0)),U)]"":$P(^(0),U),1:"")

PTF ;called to create a non-va ptf record at admission time for an

 ;authorized claim.  Called from FBCH78.

 ; input

 ;   DFN    - ien of patient in file #2

 ;   FBAA78 - ien of 7078 authorization in file #162.4

 N FBDT

 ; obtain Authorization From Date from 7078 authorization to use

 ; as the admission date on the PTF record

 S:$G(FBAA78) FBDT=$P($G(^FB7078(+FBAA78,0)),U,4)

 ; call utility to attempt creation of a Non-VA PTF record

 D PTFC^FBUTL6($G(DFN),$G(FBDT))

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBCH780   1870     printed  Apr 09, 2024@21:00:59                                                                                                                                                                                                     Page 2

FBCH780   ;AISC/DMK-7078/AUTHORIZATION CON'T ;8/18/2004

 +1       ;;3.5;FEE BASIS;**82**;JAN 30, 1995

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

DISP       DO HOME^%ZIS

           WRITE @IOF

 +1        WRITE !!

           SET DA=FBAA78

           SET DR="0;1"

           SET DIC="^FB7078("

           DO EN^DIQ

ASK        SET DIR(0)="Y"

           SET DIR("A")="Is this Correct"

           SET DIR("B")="NO"

           DO ^DIR

           KILL DIR

           if $DATA(DIRUT)

               SET FBOUT=1

           if $GET(FBOUT)

               QUIT

           if 'Y

               GOTO EDIT

 +1        SET DFN=+$PIECE($GET(^FB7078(+FBAA78,0)),"^",3)

 +2        WRITE !,?2,"....Posting to 1358",!

           DO WAIT^DICD

           DO POST

           QUIT

END        WRITE !

           QUIT

EDIT       WRITE !

           SET (DIC,DIE)="^FB7078("

           SET DA=FBAA78

           SET DR="[FBCH EDIT 7078]"

           DO ^DIE

 +1        GOTO DISP

HELP       WRITE !!,"Select one of the following: ",!,?18,"'00' FOR SURGICAL",!,?18,"'10' FOR MEDICAL",!,?18,"'86' FOR PSYCHIATRY",!

           QUIT

POST       SET PRCS("X")=FBCHOB

           SET PRCS("TYPE")="FB"

           DO EN3^PRCS58

           IF Y=-1

               WRITE !!,*7,"1358 not available for posting!",!

               QUIT

 +1        SET FBCOMM=$SELECT($DATA(FBNAME):FBNAME_" - "_FBSSN,1:"Estimated amount")

 +2        DO NOW^%DTC

           SET X=FBCHOB_"^"_%_"^"_FBEST_"^"_""_"^"_FBSEQ_"^"_FBCOMM_"^"_DFN_";"_+FBAA78_";"_$PIECE(FBCHOB,"-",2)

           SET PRCS("TYPE")="FB"

 +3        DO EN2^PRCS58

           QUIT

NULL       WRITE !,*7,"Enter the reason for pending disposition or an '^' to exit",!

           GOTO FBPDIS^FBCH78

NULL1      WRITE !,*7,"This is a required response. Enter an '^' to exit.",!

           QUIT

 +1       ;

DISCH(X)  ;X = Pointer for 7078

 +1       ;output = patient's Type of Discharge

 +2        NEW Y

 +3        SET Y=$ORDER(^FBAAI("E",X_";FB7078(",0))

 +4        IF 'Y

               QUIT Y

 +5        SET Y=+$PIECE($GET(^FBAAI(Y,0)),U,21)

 +6        QUIT $SELECT($PIECE($GET(^FBAA(162.6,Y,0)),U)]"":$PIECE(^(0),U),1:"")

 +7       ;

PTF       ;called to create a non-va ptf record at admission time for an

 +1       ;authorized claim.  Called from FBCH78.

 +2       ;

 +3       ; input

 +4       ;   DFN    - ien of patient in file #2

 +5       ;   FBAA78 - ien of 7078 authorization in file #162.4

 +6       ;

 +7        NEW FBDT

 +8       ;

 +9       ; obtain Authorization From Date from 7078 authorization to use

 +10      ; as the admission date on the PTF record

 +11       if $GET(FBAA78)

               SET FBDT=$PIECE($GET(^FB7078(+FBAA78,0)),U,4)

 +12      ;

 +13      ; call utility to attempt creation of a Non-VA PTF record

 +14       DO PTFC^FBUTL6($GET(DFN),$GET(FBDT))

 +15       QUIT

FBCH780.m