- FBAAPIP ;AISC/GRR - ESTABLISH BATCH FOR INVOICE AND CLOSE-OUT ;11/24/2014
- ;;3.5;FEE BASIS;**116,154**;JAN 30, 1995;Build 12
- ;;Per VA Directive 6402, this routine should not be modified.
- D DT^DICRW S FBSW=1
- RD1 W !! S DIC="^FBAA(162.1,",DIC(0)="AEQM",DIC("S")="I $P(^(0),U,5)=3" D ^DIC K DIC G Q:X="^"!(X=""),RD1:Y<0 S (DA,IN,FBIN)=+Y,FBINTOT=0 D CALC^FBAAPIE1,WRT
- ;
- ; loop thru Rx and enforce separation of duty
- I $$SODPINV^FBAAEPI(FBIN) D G RD1
- . W !!,"You cannot process this payment due to separation of duties."
- . W !,"You previously entered/edited an associated authorization."
- ;
- D EN1
- G RD1
- EN1 ;ENTRY FROM THE MAS CLOSE-OUT OPTION (FBAACIE)
- ;FB*3.5*116 - check for $0 invoice and stop close-out
- I +FBINTOT=0 W !!,*7,"Invoice must be greater than 0.00. Invoice cannot be closed out." Q
- ; end of changes
- S FY=$E(DT,1,3)+1700+$S($E(DT,4,5)>9:1,1:0)
- S FBAAMPI=$S($D(^FBAA(161.4,1,"FBNUM")):$P(^("FBNUM"),"^",3),1:100),FBAAMPI=$S(FBAAMPI]"":FBAAMPI,1:100),FBSW=1
- D BT Q:'$D(FBBN) D WAIT^DICD S (TIC,TAC,TAP,FBSW,FBAATPV)=0 D GO Q
- BT W !! S DIC="^FBAA(161.7,",DIC(0)="AEQM",DIC("A")="Select Batch for this Invoice: ",DIC("S")="I $P(^(0),U,3)=""B5""&($G(^(""ST""))=""O"")"
- S DIC("W")="W !,"" Obligation #: "",$P(^(0),U,2)" D ^DIC K DIC G Q:X="^"!(X=""),BT:Y<0 S (DA,FBBN)=+Y
- I $P(Y,"^",3)'=1 G NOTYOU:$P(^FBAA(161.7,DA,0),"^",5)'=DUZ,NOTPH:$P(^(0),"^",3)'="B5",NOTOP:$P(^("ST"),"^",1)'="O"
- S Z(0)=^FBAA(161.7,DA,0),FBAABO=$P(Z(0),"^",2),FBBTA=$P(Z(0),"^",9),FBBIC=$P(Z(0),"^",10)+1,FBBLC=$P(Z(0),"^",11)
- G:FBBLC>(FBAAMPI-1) WARN
- Q
- GO ; HIPAA 5010 - count line items that have 0.00 amount paid
- ;S FBAAVIN=$P(^FBAA(162.1,FBIN,0),"^",4) F FBJ=0:0 S FBJ=$O(^FBAA(162.1,FBIN,"RX",FBJ)) Q:FBJ'>0 S Y(0)=^FBAA(162.1,FBIN,"RX",FBJ,0) D:$P(Y(0),"^",16)>0 GOT
- S FBAAVIN=$P(^FBAA(162.1,FBIN,0),"^",4) F FBJ=0:0 S FBJ=$O(^FBAA(162.1,FBIN,"RX",FBJ)) Q:FBJ'>0 S Y(0)=^FBAA(162.1,FBIN,"RX",FBJ,0) D GOT
- D RSET W !!,"Invoice Closed out!!" S FBSW=1
- Q Q:'FBSW K J,FBAABO,FBBN,FBIN,TAC,TAP,TIC,DIC,D0,DA,DI,DIE,DQ,DR,IN,FBINTOT,FBAAMPI,FBAATPV,FBAAVIN,FBBIC,FBBLC,FBBTA,FBJ,FY,FBZZ,X,Y,Z,FBSTN Q
- GOT S TAC=TAC+$P(Y(0),"^",4),TAP=TAP+$P(Y(0),"^",16),TIC=TIC+1,FBBLC=FBBLC+1,FBSW=0 I $P(Y(0),"^",20)'="R" S FBAATPV=FBAATPV+$P(Y(0),"^",16)
- S DIC="^FBAA(162.1,"_FBIN_",""RX"",",DA=FBJ,DA(1)=FBIN,DIE=DIC,DR="13////^S X=FBBN;14////^S X=FBAABO;15////^S X=DT;8////^S X=4"
- D ^DIE
- I FBBLC>(FBAAMPI-1) D FULL
- Q
- RSET S DIC="^FBAA(162.1,",DA=FBIN,DIE=DIC,DR="5////^S X=4;6///^S X=TAC;7///^S X=TAP;8///^S X=TIC" D ^DIE
- RSET2 S FBBTA=FBBTA+TAP,$P(Z(0),"^",9)=FBBTA,$P(Z(0),"^",10)=FBBIC,$P(Z(0),"^",11)=FBBLC,^FBAA(161.7,FBBN,0)=Z(0)
- Q
- NOTYOU W !!,*7,"Batch selected established by another user, choose another." G BT
- NOTPH W !!,*7,"Batch selected is NOT a Pharmacy type batch, choose another." G BT
- NOTOP W !!,*7,"Batch selected not in Open status, choose another." G BT
- FULL D RSET2 W !!,*7,"Batch has reached maximum allowable payment entries!",!,"Now openning another batch for you.",! K FBBN
- D NEWBT G BT:'$D(FBBN)
- Q
- WARN W !!,*7,"That Batch already has maximum allowable payment items!" K FBBN G BT
- OUT Q
- WRT W !,?20,"Invoice Totals: $ "_$J(FBINTOT,1,2) Q
- NEWBT ;OPEN NEW BATCH IF NEEDED TO CLOSEOUT INVOICE
- S FBSTN=$P(Z(0),"^",8),FBAAOB=$P(Z(0),"^",2) W ! D GETNXB^FBAAUTL W !!,*7,"New Batch to closeout invoice is: ",FBBN
- S DIC="^FBAA(161.7,",DLAYGO=161.7,X=FBBN,DIC(0)="LQ",DIC("DR")="1////^S X=FBAAOB;2////^S X=""B5"";3////^S X=DT;4////^S X=DUZ;11////^S X=""O"";16////^S X=FBSTN"
- K DD,DO D FILE^DICN K DLAYGO S FBBN=+Y,Z(0)=^FBAA(161.7,FBBN,0)
- S FBAAOB=$P(Z(0),"^",2),FBBTA=$P(Z(0),"^",9),FBBIC=$P(Z(0),"^",10)+1,FBBLC=$P(Z(0),"^",11)
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBAAPIP 3712 printed Feb 18, 2025@23:22:35 Page 2
- FBAAPIP ;AISC/GRR - ESTABLISH BATCH FOR INVOICE AND CLOSE-OUT ;11/24/2014
- +1 ;;3.5;FEE BASIS;**116,154**;JAN 30, 1995;Build 12
- +2 ;;Per VA Directive 6402, this routine should not be modified.
- +3 DO DT^DICRW
- SET FBSW=1
- RD1 WRITE !!
- SET DIC="^FBAA(162.1,"
- SET DIC(0)="AEQM"
- SET DIC("S")="I $P(^(0),U,5)=3"
- DO ^DIC
- KILL DIC
- if X="^"!(X="")
- GOTO Q
- if Y<0
- GOTO RD1
- SET (DA,IN,FBIN)=+Y
- SET FBINTOT=0
- DO CALC^FBAAPIE1
- DO WRT
- +1 ;
- +2 ; loop thru Rx and enforce separation of duty
- +3 IF $$SODPINV^FBAAEPI(FBIN)
- Begin DoDot:1
- +4 WRITE !!,"You cannot process this payment due to separation of duties."
- +5 WRITE !,"You previously entered/edited an associated authorization."
- End DoDot:1
- GOTO RD1
- +6 ;
- +7 DO EN1
- +8 GOTO RD1
- EN1 ;ENTRY FROM THE MAS CLOSE-OUT OPTION (FBAACIE)
- +1 ;FB*3.5*116 - check for $0 invoice and stop close-out
- +2 IF +FBINTOT=0
- WRITE !!,*7,"Invoice must be greater than 0.00. Invoice cannot be closed out."
- QUIT
- +3 ; end of changes
- +4 SET FY=$EXTRACT(DT,1,3)+1700+$SELECT($EXTRACT(DT,4,5)>9:1,1:0)
- +5 SET FBAAMPI=$SELECT($DATA(^FBAA(161.4,1,"FBNUM")):$PIECE(^("FBNUM"),"^",3),1:100)
- SET FBAAMPI=$SELECT(FBAAMPI]"":FBAAMPI,1:100)
- SET FBSW=1
- +6 DO BT
- if '$DATA(FBBN)
- QUIT
- DO WAIT^DICD
- SET (TIC,TAC,TAP,FBSW,FBAATPV)=0
- DO GO
- QUIT
- BT WRITE !!
- SET DIC="^FBAA(161.7,"
- SET DIC(0)="AEQM"
- SET DIC("A")="Select Batch for this Invoice: "
- SET DIC("S")="I $P(^(0),U,3)=""B5""&($G(^(""ST""))=""O"")"
- +1 SET DIC("W")="W !,"" Obligation #: "",$P(^(0),U,2)"
- DO ^DIC
- KILL DIC
- if X="^"!(X="")
- GOTO Q
- if Y<0
- GOTO BT
- SET (DA,FBBN)=+Y
- +2 IF $PIECE(Y,"^",3)'=1
- if $PIECE(^FBAA(161.7,DA,0),"^",5)'=DUZ
- GOTO NOTYOU
- if $PIECE(^(0),"^",3)'="B5"
- GOTO NOTPH
- if $PIECE(^("ST"),"^",1)'="O"
- GOTO NOTOP
- +3 SET Z(0)=^FBAA(161.7,DA,0)
- SET FBAABO=$PIECE(Z(0),"^",2)
- SET FBBTA=$PIECE(Z(0),"^",9)
- SET FBBIC=$PIECE(Z(0),"^",10)+1
- SET FBBLC=$PIECE(Z(0),"^",11)
- +4 if FBBLC>(FBAAMPI-1)
- GOTO WARN
- +5 QUIT
- GO ; HIPAA 5010 - count line items that have 0.00 amount paid
- +1 ;S FBAAVIN=$P(^FBAA(162.1,FBIN,0),"^",4) F FBJ=0:0 S FBJ=$O(^FBAA(162.1,FBIN,"RX",FBJ)) Q:FBJ'>0 S Y(0)=^FBAA(162.1,FBIN,"RX",FBJ,0) D:$P(Y(0),"^",16)>0 GOT
- +2 SET FBAAVIN=$PIECE(^FBAA(162.1,FBIN,0),"^",4)
- FOR FBJ=0:0
- SET FBJ=$ORDER(^FBAA(162.1,FBIN,"RX",FBJ))
- if FBJ'>0
- QUIT
- SET Y(0)=^FBAA(162.1,FBIN,"RX",FBJ,0)
- DO GOT
- +3 DO RSET
- WRITE !!,"Invoice Closed out!!"
- SET FBSW=1
- Q if 'FBSW
- QUIT
- KILL J,FBAABO,FBBN,FBIN,TAC,TAP,TIC,DIC,D0,DA,DI,DIE,DQ,DR,IN,FBINTOT,FBAAMPI,FBAATPV,FBAAVIN,FBBIC,FBBLC,FBBTA,FBJ,FY,FBZZ,X,Y,Z,FBSTN
- QUIT
- GOT SET TAC=TAC+$PIECE(Y(0),"^",4)
- SET TAP=TAP+$PIECE(Y(0),"^",16)
- SET TIC=TIC+1
- SET FBBLC=FBBLC+1
- SET FBSW=0
- IF $PIECE(Y(0),"^",20)'="R"
- SET FBAATPV=FBAATPV+$PIECE(Y(0),"^",16)
- +1 SET DIC="^FBAA(162.1,"_FBIN_",""RX"","
- SET DA=FBJ
- SET DA(1)=FBIN
- SET DIE=DIC
- SET DR="13////^S X=FBBN;14////^S X=FBAABO;15////^S X=DT;8////^S X=4"
- +2 DO ^DIE
- +3 IF FBBLC>(FBAAMPI-1)
- DO FULL
- +4 QUIT
- RSET SET DIC="^FBAA(162.1,"
- SET DA=FBIN
- SET DIE=DIC
- SET DR="5////^S X=4;6///^S X=TAC;7///^S X=TAP;8///^S X=TIC"
- DO ^DIE
- RSET2 SET FBBTA=FBBTA+TAP
- SET $PIECE(Z(0),"^",9)=FBBTA
- SET $PIECE(Z(0),"^",10)=FBBIC
- SET $PIECE(Z(0),"^",11)=FBBLC
- SET ^FBAA(161.7,FBBN,0)=Z(0)
- +1 QUIT
- NOTYOU WRITE !!,*7,"Batch selected established by another user, choose another."
- GOTO BT
- NOTPH WRITE !!,*7,"Batch selected is NOT a Pharmacy type batch, choose another."
- GOTO BT
- NOTOP WRITE !!,*7,"Batch selected not in Open status, choose another."
- GOTO BT
- FULL DO RSET2
- WRITE !!,*7,"Batch has reached maximum allowable payment entries!",!,"Now openning another batch for you.",!
- KILL FBBN
- +1 DO NEWBT
- if '$DATA(FBBN)
- GOTO BT
- +2 QUIT
- WARN WRITE !!,*7,"That Batch already has maximum allowable payment items!"
- KILL FBBN
- GOTO BT
- OUT QUIT
- WRT WRITE !,?20,"Invoice Totals: $ "_$JUSTIFY(FBINTOT,1,2)
- QUIT
- NEWBT ;OPEN NEW BATCH IF NEEDED TO CLOSEOUT INVOICE
- +1 SET FBSTN=$PIECE(Z(0),"^",8)
- SET FBAAOB=$PIECE(Z(0),"^",2)
- WRITE !
- DO GETNXB^FBAAUTL
- WRITE !!,*7,"New Batch to closeout invoice is: ",FBBN
- +2 SET DIC="^FBAA(161.7,"
- SET DLAYGO=161.7
- SET X=FBBN
- SET DIC(0)="LQ"
- SET DIC("DR")="1////^S X=FBAAOB;2////^S X=""B5"";3////^S X=DT;4////^S X=DUZ;11////^S X=""O"";16////^S X=FBSTN"
- +3 KILL DD,DO
- DO FILE^DICN
- KILL DLAYGO
- SET FBBN=+Y
- SET Z(0)=^FBAA(161.7,FBBN,0)
- +4 SET FBAAOB=$PIECE(Z(0),"^",2)
- SET FBBTA=$PIECE(Z(0),"^",9)
- SET FBBIC=$PIECE(Z(0),"^",10)+1
- SET FBBLC=$PIECE(Z(0),"^",11)
- +5 QUIT
