- 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))
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBCH780 1870 printed Jan 18, 2025@02:58:40 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