- FBCKDIS1 ;AISC/CMR - OUTPUT BY CHECK # cont. ;20APR94
- ;;3.5;FEE BASIS;;JAN 30, 1995
- ;;Per VHA Directive 10-93-142, this routine should not be modified.
- D OPT,INPT,PHARM,TRAV
- Q
- OPT ;find outpatient payments for check #
- Q:'$D(^FBAAC("ACK",FBCN))
- S FBPROG="OPT",FBCNT=0
- S FB1=0 F S FB1=$O(^FBAAC("ACK",FBCN,FB1)) Q:'FB1 S FB2=0 F S FB2=$O(^FBAAC("ACK",FBCN,FB1,FB2)) Q:'FB2 S FB3=0 F S FB3=$O(^FBAAC("ACK",FBCN,FB1,FB2,FB3)) Q:'FB3 S FB4=0 F S FB4=$O(^FBAAC("ACK",FBCN,FB1,FB2,FB3,FB4)) Q:'FB4 D
- .Q:$S('$D(^FBAAC(FB1,1,FB2,1,FB3,1,FB4,0)):1,'$D(^FBAAC(FB1,1,FB2,1,FB3,1,FB4,2)):1,'$D(^FBAAC(FB1,1,FB2,1,FB3,0)):1,1:0)
- .S FBCNT=FBCNT+1,FBDA=FB1_"^"_FB2_"^"_FB3_"^"_FB4,DFN=FB1,FBV=FB2
- .D SETMP
- D CLN Q
- INPT ;find inpatient payments for check #
- Q:'$D(^FBAAI("ACK",FBCN))
- S (FBCNTCH,FBCNTCNH)=0
- S FB1=0 F S FB1=$O(^FBAAI("ACK",FBCN,FB1)) Q:'FB1 D
- .Q:$S('$D(^FBAAI(FB1,0)):1,'$D(^FBAAI(FB1,2)):1,1:0)
- .S FBA=^FBAAI(FB1,0),DFN=$P(FBA,U,4),FBV=$P(FBA,U,3)
- .S FBPROG=$S($P(FBA,U,12)=6:"CH",$P(FBA,U,12)=7:"CNH",1:"") Q:FBPROG']""
- .I FBPROG="CH" S FBCNTCH=FBCNTCH+1,FBCNT=FBCNTCH
- .I FBPROG="CNH" S FBCNTCNH=FBCNTCNH+1,FBCNT=FBCNTCNH
- .S FBDA=FB1
- .D SETMP
- D CLN Q
- PHARM ;find pharmacy payments for check #
- Q:'$D(^FBAA(162.1,"ACK",FBCN))
- S FBCNT=0,FBPROG="PHAR"
- S FB1=0 F S FB1=$O(^FBAA(162.1,"ACK",FBCN,FB1)) Q:'FB1 S FB2=0 F S FB2=$O(^FBAA(162.1,"ACK",FBCN,FB1,FB2)) Q:'FB2 D
- .Q:$S('$D(^FBAA(162.1,FB1,"RX",FB2,0)):1,'$D(^FBAA(162.1,FB1,"RX",FB2,2)):1,'$D(^FBAA(162.1,FB1,0)):1,1:0)
- .S FBCNT=FBCNT+1
- .S FBA=^FBAA(162.1,FB1,"RX",FB2,0),DFN=$P(FBA,U,5),FBV=$P(^FBAA(162.1,FB1,0),U,4)
- .S FBDA=FB1_"^"_FB2
- .D SETMP
- D CLN Q
- TRAV ;find travel payments for check #
- Q:'$D(^FBAAC("ACKT",FBCN))
- S FBCNT=0,FBPROG="TRAV"
- S FB1=0 F S FB1=$O(^FBAAC("ACKT",FBCN,FB1)) Q:'FB1 S FB2=0 F S FB2=$O(^FBAAC("ACKT",FBCN,FB1,FB2)) Q:'FB2 D
- .Q:'$D(^FBAAC(FB1,3,FB2,0))
- .S FBCNT=FBCNT+1
- .S DFN=FB1,FBV="R"
- .S FBDA=FB1_"^"_FB2
- .D SETMP
- D CLN Q
- SETMP ;set up tmp global
- S ^TMP($J,"FBCK",FBPROG,FBV,DFN,FBCNT)=FBDA
- Q
- CLN K FB1,FB2,FB3,FB4,FBA,FBCNT,DFN,FBCNTCH,FBCNTCNH,FBPROG Q
- SUSP ;get suspense code
- S FBSUSP=$S(FBSUSP="":"",$D(^FBAA(161.27,FBSUSP,0)):^FBAA(161.27,FBSUSP,0),1:"")
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBCKDIS1 2260 printed Mar 13, 2025@21:03 Page 2
- FBCKDIS1 ;AISC/CMR - OUTPUT BY CHECK # cont. ;20APR94
- +1 ;;3.5;FEE BASIS;;JAN 30, 1995
- +2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
- +3 DO OPT
- DO INPT
- DO PHARM
- DO TRAV
- +4 QUIT
- OPT ;find outpatient payments for check #
- +1 if '$DATA(^FBAAC("ACK",FBCN))
- QUIT
- +2 SET FBPROG="OPT"
- SET FBCNT=0
- +3 SET FB1=0
- FOR
- SET FB1=$ORDER(^FBAAC("ACK",FBCN,FB1))
- if 'FB1
- QUIT
- SET FB2=0
- FOR
- SET FB2=$ORDER(^FBAAC("ACK",FBCN,FB1,FB2))
- if 'FB2
- QUIT
- SET FB3=0
- FOR
- SET FB3=$ORDER(^FBAAC("ACK",FBCN,FB1,FB2,FB3))
- if 'FB3
- QUIT
- SET FB4=0
- FOR
- SET FB4=$ORDER(^FBAAC("ACK",FBCN,FB1,FB2,FB3,FB4))
- if 'FB4
- QUIT
- Begin DoDot:1
- +4 if $SELECT('$DATA(^FBAAC(FB1,1,FB2,1,FB3,1,FB4,0))
- QUIT
- +5 SET FBCNT=FBCNT+1
- SET FBDA=FB1_"^"_FB2_"^"_FB3_"^"_FB4
- SET DFN=FB1
- SET FBV=FB2
- +6 DO SETMP
- End DoDot:1
- +7 DO CLN
- QUIT
- INPT ;find inpatient payments for check #
- +1 if '$DATA(^FBAAI("ACK",FBCN))
- QUIT
- +2 SET (FBCNTCH,FBCNTCNH)=0
- +3 SET FB1=0
- FOR
- SET FB1=$ORDER(^FBAAI("ACK",FBCN,FB1))
- if 'FB1
- QUIT
- Begin DoDot:1
- +4 if $SELECT('$DATA(^FBAAI(FB1,0))
- QUIT
- +5 SET FBA=^FBAAI(FB1,0)
- SET DFN=$PIECE(FBA,U,4)
- SET FBV=$PIECE(FBA,U,3)
- +6 SET FBPROG=$SELECT($PIECE(FBA,U,12)=6:"CH",$PIECE(FBA,U,12)=7:"CNH",1:"")
- if FBPROG']""
- QUIT
- +7 IF FBPROG="CH"
- SET FBCNTCH=FBCNTCH+1
- SET FBCNT=FBCNTCH
- +8 IF FBPROG="CNH"
- SET FBCNTCNH=FBCNTCNH+1
- SET FBCNT=FBCNTCNH
- +9 SET FBDA=FB1
- +10 DO SETMP
- End DoDot:1
- +11 DO CLN
- QUIT
- PHARM ;find pharmacy payments for check #
- +1 if '$DATA(^FBAA(162.1,"ACK",FBCN))
- QUIT
- +2 SET FBCNT=0
- SET FBPROG="PHAR"
- +3 SET FB1=0
- FOR
- SET FB1=$ORDER(^FBAA(162.1,"ACK",FBCN,FB1))
- if 'FB1
- QUIT
- SET FB2=0
- FOR
- SET FB2=$ORDER(^FBAA(162.1,"ACK",FBCN,FB1,FB2))
- if 'FB2
- QUIT
- Begin DoDot:1
- +4 if $SELECT('$DATA(^FBAA(162.1,FB1,"RX",FB2,0))
- QUIT
- +5 SET FBCNT=FBCNT+1
- +6 SET FBA=^FBAA(162.1,FB1,"RX",FB2,0)
- SET DFN=$PIECE(FBA,U,5)
- SET FBV=$PIECE(^FBAA(162.1,FB1,0),U,4)
- +7 SET FBDA=FB1_"^"_FB2
- +8 DO SETMP
- End DoDot:1
- +9 DO CLN
- QUIT
- TRAV ;find travel payments for check #
- +1 if '$DATA(^FBAAC("ACKT",FBCN))
- QUIT
- +2 SET FBCNT=0
- SET FBPROG="TRAV"
- +3 SET FB1=0
- FOR
- SET FB1=$ORDER(^FBAAC("ACKT",FBCN,FB1))
- if 'FB1
- QUIT
- SET FB2=0
- FOR
- SET FB2=$ORDER(^FBAAC("ACKT",FBCN,FB1,FB2))
- if 'FB2
- QUIT
- Begin DoDot:1
- +4 if '$DATA(^FBAAC(FB1,3,FB2,0))
- QUIT
- +5 SET FBCNT=FBCNT+1
- +6 SET DFN=FB1
- SET FBV="R"
- +7 SET FBDA=FB1_"^"_FB2
- +8 DO SETMP
- End DoDot:1
- +9 DO CLN
- QUIT
- SETMP ;set up tmp global
- +1 SET ^TMP($JOB,"FBCK",FBPROG,FBV,DFN,FBCNT)=FBDA
- +2 QUIT
- CLN KILL FB1,FB2,FB3,FB4,FBA,FBCNT,DFN,FBCNTCH,FBCNTCNH,FBPROG
- QUIT
- SUSP ;get suspense code
- +1 SET FBSUSP=$SELECT(FBSUSP="":"",$DATA(^FBAA(161.27,FBSUSP,0)):^FBAA(161.27,FBSUSP,0),1:"")
- +2 QUIT
