- FBAACCB1 ;AISC/GRR-CLERK CLOSE BATCH CONTINUED ; 11/24/10 10:27am
- ;;3.5;FEE BASIS;**55,61,116,108,164**;JAN 30, 1995;Build 28
- ;;Per VHA Directive 2004-038, this routine should not be modified.
- PHARM ;ENTRY FOR PHARMACY BATCH CALCULATE TOTAL DOLLARS AND LINE COUNT
- ; HIPAA 5010 - count line items that have 0.00 amount paid
- F A=0:0 S A=$O(^FBAA(162.1,"AE",B,A)) Q:A'>0 F B2=0:0 S B2=$O(^FBAA(162.1,"AE",B,A,B2)) Q:B2'>0 I $D(^FBAA(162.1,A,"RX",B2,0)) S Z(0)=^(0) D MOREP
- G FIN^FBAACCB
- MOREP S T=T+$P(Z(0),"^",16),C=C+1 Q
- ;
- TRAV ;ENTRY FOR TRAVEL BATCH CALCULATE TOTAL DOLLARS AND LINE COUNT
- ; HIPAA 5010 - count line items that have 0.00 amount paid
- F J=0:0 S J=$O(^FBAAC("AD",B,J)) Q:J'>0 F K=0:0 S K=$O(^FBAAC("AD",B,J,K)) Q:K'>0 I $D(^FBAAC(J,3,K,0)) S Z(0)=^(0) D MORET
- G FIN^FBAACCB
- ;
- MORET S T=T+$P(Z(0),"^",3),C=C+1 Q
- LISTC S Q="",$P(Q,"=",80)="=",(FBAAOUT,FBLISTC)=0,IOP=$S($D(ION):ION,1:"HOME") D ^%ZIS K IOP
- PRTC D HEDC
- F I=0:0 S I=$O(^FBAAI("AC",B,I)) Q:I'>0!(FBAAOUT) I $D(^FBAAI(I,0)) S Z(0)=^(0) D CMORE
- Q
- CMORE N FBADJLR,FBFPPSC,FBFPPSL,FBX,FBY3,FBDX,FBPOA,FBADMTDX
- S K=$P(Z(0),"^",3),J=$P(Z(0),"^",4) D ENV^FBAACCB0 S N=$$NAME^FBCHREQ2(J),S=$$SSN^FBAAUTL(J),FBIN=I,FBAC=$P(Z(0),"^",8)+.0001,FBAP=$P(Z(0),"^",9)+.0001,FBVP=$P(Z(0),"^",14),ZS=$P(Z(0),"^",13)
- S FBAC=$P(FBAC,".",1)_"."_$E($P(FBAC,".",2),1,2),FBAP=$P(FBAP,".",1)_"."_$E($P(FBAP,".",2),1,2)
- S FBSC=$P(Z(0),"^",11),FBSC=$S(FBSC="":"",$D(^FBAA(161.27,FBSC,0)):$P(^(0),"^",1),1:""),FBFD=$P(Z(0),"^",6),FBTD=$P(Z(0),"^",7) S FBPDT=FBFD D CDAT S FBFD=FBPDT,FBPDT=FBTD D CDAT S FBTD=FBPDT
- S FBY3=$G(^FBAAI(I,3))
- S FBFPPSC=$P(FBY3,U)
- S FBFPPSL=$P(FBY3,U,2)
- S FBX=$$ADJLRA^FBCHFA(I_",")
- S FBADJLR=$P(FBX,U)
- D FBCKI(I)
- S B(1617)=$S(B="":"",$D(^FBAA(161.7,B,0)):$P(^(0),"^"),1:"")
- S FBIN(1)=$P(Z(0),"^",2)
- D WRITC
- Q
- WRITC I $Y+7>IOSL D ASKH^FBAACCB0:$E(IOST,1,2)["C-" Q:FBAAOUT W @IOF D HEDC
- W !!,$S('$D(ZS):"",ZS="R":"*",1:"")
- W N,?35,S,?60,B(1617)
- W !,?3,V,?45,VID,?58,FBIN,?70,$$DATX^FBAAUTL($E(FBIN(1),1,7))
- I FBFPPSC]"" W !,?4,"FPPS Claim ID: ",FBFPPSC," FPPS Line: ",FBFPPSL
- W !,$S($D(QQ):QQ_")",1:""),FBVP,$S(FBCAN]"":"+",1:""),?4,FBFD,?13,FBTD,?22,$J(FBAC,6),?32,$J(FBAP,6),?45,$S(FBADJLR]"":FBADJLR,1:FBSC)
- W:$P(Z(0),"^",24) ?56,"Discharge ",$$ICD^FBCSV1(+$P(Z(0),"^",24),$P(Z(0),"^",6)) W ! ;CSV
- ; write admitting diagnosis
- N P7,P8
- S P7=$G(^FBAAI(I,5))
- S FBADMTDX=$P(P7,"^",9)
- S P8=$$ICD9^FBCSV1(FBADMTDX,$P($G(Z(0)),"^",6))
- I P8'="" W !,?4,"Admit Dx: ",P8
- ; set diagnosis code and present on admission code
- N P1,P2
- S P1=$G(^FBAAI(I,"DX"))
- S P2=$G(^FBAAI(I,"POA"))
- F FBK=1:1:25 D WRTDX
- ; set procedure code
- N P5
- S P5=$G(^FBAAI(I,"PROC"))
- F FBL=1:1:25 D WRTPC
- ; write attachment IDs
- I $D(^FBAAI(I,10)) D
- . N AI,AID,AITI,WRTPC
- . S AI=0 S WRTPC="Attachment ID:"
- . F S AI=$O(^FBAAI(I,10,AI)) Q:'AI D
- . . S AID=$P($G(^FBAAI(I,10,AI,0)),"^") I AI>1 S WRTPC=WRTPC_","
- . . S WRTPC=WRTPC_" "_AID
- . . S AITI=$P($G(^FBAAI(I,10,AI,0)),"^",2) I AITI D
- . . . S WRTPC=WRTPC_" ("_$P($G(^IBE(353.3,AITI,0)),"^")
- . . . S WRTPC=WRTPC_" - "
- . . . S WRTPC=WRTPC_$P($G(^IBE(353.3,AITI,0)),"^",2)_")"
- . . I $L(WRTPC)>IOM D WRTSTR(.WRTPC,IOM)
- . I $L(WRTPC)>0 D WRTSTR(.WRTPC,IOM)
- S A2=FBAP D PMNT^FBAACCB2 K A2
- Q
- WRTSTR(STR,MX) ; Wordwrap string
- N RM,I
- WRTSTR1 S RM=$S(STR?1"Attachment ID:".E:MX-4,1:MX-7)
- F I=1:1:$L(STR," ") Q:$L($P(STR," ",1,I))>RM
- W !,?4 W:STR'?1"Attachment ID:".E ?7
- I $L($P(STR," ",1,I))>RM W $P(STR," ",1,I-1) S STR=$P(STR," ",I,999)
- E W $P(STR," ",1,I) S STR=""
- I $L(STR)>(MX-3) G WRTSTR1
- Q
- CDAT S FBPDT=$E(FBPDT,4,5)_"/"_$S($E(FBPDT,6,7)="00":$E(FBPDT,2,3),1:$E(FBPDT,6,7)_"/"_$E(FBPDT,2,3))
- Q
- HEDC W "Patient Name",?20,"('*' Reimbursement to Veteran '+' Cancellation Activity)",!,?13,"('#' Voided Payment '&' Additional Payment)",?60,"Batch Number"
- W !,?3,"Vendor Name",?45,"Vendor ID",?57,"Invoice #",?68,"Dt Inv Rec'd",!,?3,"FR DATE",?14,"TO DATE CLAIMED PAID",?41,"ADJ CODE",!,Q,!
- Q
- CHNH ; FB*3.5*116
- S (J,FZ("CNT"))=0 F S J=$O(^FBAAI("AC",B,J)) Q:J'>0 I $D(^FBAAI(J,0)) S Z(0)=^(0) D MORECH D:$P(FZ,U,15)'="Y" INVCNT
- S:$G(FZ("CNT")) $P(FZ,U,10)=FZ("CNT") K FZ("CNT") ; CNH batch
- G FIN^FBAACCB
- ;
- MORECH ; HIPAA 5010 - count line items that have 0.00 amount paid
- S T=T+$P(Z(0),"^",9),C=C+1
- ; FB*3.5*116 - build array of invoices
- ;do not build array for CH batches not exempt from the pricer
- Q:($P(FZ,"^",18)'="Y")&($P(FZ,"^",15)="Y")
- S FBARY($P(Z(0),"^"))=+$P(Z(0),"^",9)
- Q
- ;
- WRTDX ; write diagnosis code and present on admission code
- N P3,P4
- S FBDX=$P(P1,"^",FBK)
- S FBPOA=$P(P2,"^",FBK)
- Q:FBDX=""
- S P3=$$ICD9^FBCSV1(FBDX,$P($G(Z(0)),"^",6))_"/"
- S P4=P3_$S(FBPOA:$P($G(^FB(161.94,FBPOA,0)),"^"),1:"")
- I FBK=1!($X+$L(P4)+2>IOM) W !,?4,"DX/POA: "
- W P4," "
- Q
- ;
- WRTPC ; write procedure code (if present)
- N P6
- S FBPROC=$P(P5,"^",FBL)
- Q:FBPROC=""
- S P6=$$ICD0^FBCSV1(FBPROC,$P($G(Z(0)),"^",6))
- I FBL=1!($X+$L(P6)+2>IOM) W !,?4,"PROC: "
- W P6," "
- Q
- MORE ;
- N FBADJLA,FBADJLR,FBFPPSC,FBFPPSL,FBX,TAMT
- S J=$P(Z(0),"^",5),D=$P(Z(0),"^",3),FBAACPT=$P(Z(0),"^",1),N=$S($D(^DPT(J,0)):$P(^(0),"^",1),1:""),S=$S(N]"":$P(^DPT(J,0),"^",9),1:""),FBIN=A,CPTDESC=$P(Z(0),"^",2)
- S Y="",$P(Y,"^",2)=$P(Z(0),"^",4),$P(Y,"^",3)=$P(Z(0),"^",16),$P(Y,"^",12)=0,T=$P(Z(0),"^",8),T=$S(T="":"",$D(^FBAA(161.27,T,0)):^(0),1:""),$P(Y,"^",9)=$P(Z(0),"^",1),ZS=$P(Z(0),"^",20),FBPV=""
- ;
- S FBFPPSC=$P($G(^FBAA(162.1,A,0)),U,13)
- S FBFPPSL=$P($G(^FBAA(162.1,A,"RX",B2,3)),U)
- S FBX=$$ADJLRA^FBRXFA(B2_","_A_",")
- S FBADJLR=$P(FBX,U)
- S FBADJLA=$P(FBX,U,2)
- S TAMT=$FN($P(Z(0),"^",7),"",2)
- ;
- D FBCKP(A,B2)
- S FBIN(1)=$P($G(^FBAA(162.1,+A,0)),"^",2)
- G GO^FBAACCB
- INVCNT ;set invoice count for cnh batch
- S FZ("CNT")=FZ("CNT")+1
- Q
- FBCKI(FBI) ;set inpatient check variables
- ;fbi=DA
- I '$G(FBI) S (FBCKDT,FBCK,FBCANDT,FBCANR,FBCAN,FBDIS,FBCKINT)="" Q
- S FBCKIN=$G(^FBAAI(FBI,2))
- S U="^",FBCKDT=+FBCKIN,FBCK=$P(FBCKIN,U,4),FBCANDT=$P(FBCKIN,U,5),FBCANR=$P(FBCKIN,U,6),FBCAN=$P(FBCKIN,U,7),FBDIS=$P(FBCKIN,U,8),FBCKINT=$P(FBCKIN,U,9) K FBCKIN
- Q
- FBCKP(J,K) ;set pharmacy check variables
- ;j,k required input variables to = da(1) and da respectively (162.1)
- I '$G(J)!('$G(K)) Q
- S FBCKIN=$G(^FBAA(162.1,J,"RX",K,2))
- S U="^",FBCKDT=$P(FBCKIN,U,8),FBCK=$P(FBCKIN,U,10),FBCANDT=$P(FBCKIN,U,11),FBCANR=$P(FBCKIN,U,12),FBCAN=$P(FBCKIN,U,13),FBDIS=$P(FBCKIN,U,14),FBCKINT=$P(FBCKIN,U,15) K FBCKIN
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBAACCB1 6507 printed Jan 18, 2025@02:56:15 Page 2
- FBAACCB1 ;AISC/GRR-CLERK CLOSE BATCH CONTINUED ; 11/24/10 10:27am
- +1 ;;3.5;FEE BASIS;**55,61,116,108,164**;JAN 30, 1995;Build 28
- +2 ;;Per VHA Directive 2004-038, this routine should not be modified.
- PHARM ;ENTRY FOR PHARMACY BATCH CALCULATE TOTAL DOLLARS AND LINE COUNT
- +1 ; HIPAA 5010 - count line items that have 0.00 amount paid
- +2 FOR A=0:0
- SET A=$ORDER(^FBAA(162.1,"AE",B,A))
- if A'>0
- QUIT
- FOR B2=0:0
- SET B2=$ORDER(^FBAA(162.1,"AE",B,A,B2))
- if B2'>0
- QUIT
- IF $DATA(^FBAA(162.1,A,"RX",B2,0))
- SET Z(0)=^(0)
- DO MOREP
- +3 GOTO FIN^FBAACCB
- MOREP SET T=T+$PIECE(Z(0),"^",16)
- SET C=C+1
- QUIT
- +1 ;
- TRAV ;ENTRY FOR TRAVEL BATCH CALCULATE TOTAL DOLLARS AND LINE COUNT
- +1 ; HIPAA 5010 - count line items that have 0.00 amount paid
- +2 FOR J=0:0
- SET J=$ORDER(^FBAAC("AD",B,J))
- if J'>0
- QUIT
- FOR K=0:0
- SET K=$ORDER(^FBAAC("AD",B,J,K))
- if K'>0
- QUIT
- IF $DATA(^FBAAC(J,3,K,0))
- SET Z(0)=^(0)
- DO MORET
- +3 GOTO FIN^FBAACCB
- +4 ;
- MORET SET T=T+$PIECE(Z(0),"^",3)
- SET C=C+1
- QUIT
- LISTC SET Q=""
- SET $PIECE(Q,"=",80)="="
- SET (FBAAOUT,FBLISTC)=0
- SET IOP=$SELECT($DATA(ION):ION,1:"HOME")
- DO ^%ZIS
- KILL IOP
- PRTC DO HEDC
- +1 FOR I=0:0
- SET I=$ORDER(^FBAAI("AC",B,I))
- if I'>0!(FBAAOUT)
- QUIT
- IF $DATA(^FBAAI(I,0))
- SET Z(0)=^(0)
- DO CMORE
- +2 QUIT
- CMORE NEW FBADJLR,FBFPPSC,FBFPPSL,FBX,FBY3,FBDX,FBPOA,FBADMTDX
- +1 SET K=$PIECE(Z(0),"^",3)
- SET J=$PIECE(Z(0),"^",4)
- DO ENV^FBAACCB0
- SET N=$$NAME^FBCHREQ2(J)
- SET S=$$SSN^FBAAUTL(J)
- SET FBIN=I
- SET FBAC=$PIECE(Z(0),"^",8)+.0001
- SET FBAP=$PIECE(Z(0),"^",9)+.0001
- SET FBVP=$PIECE(Z(0),"^",14)
- SET ZS=$PIECE(Z(0),"^",13)
- +2 SET FBAC=$PIECE(FBAC,".",1)_"."_$EXTRACT($PIECE(FBAC,".",2),1,2)
- SET FBAP=$PIECE(FBAP,".",1)_"."_$EXTRACT($PIECE(FBAP,".",2),1,2)
- +3 SET FBSC=$PIECE(Z(0),"^",11)
- SET FBSC=$SELECT(FBSC="":"",$DATA(^FBAA(161.27,FBSC,0)):$PIECE(^(0),"^",1),1:"")
- SET FBFD=$PIECE(Z(0),"^",6)
- SET FBTD=$PIECE(Z(0),"^",7)
- SET FBPDT=FBFD
- DO CDAT
- SET FBFD=FBPDT
- SET FBPDT=FBTD
- DO CDAT
- SET FBTD=FBPDT
- +4 SET FBY3=$GET(^FBAAI(I,3))
- +5 SET FBFPPSC=$PIECE(FBY3,U)
- +6 SET FBFPPSL=$PIECE(FBY3,U,2)
- +7 SET FBX=$$ADJLRA^FBCHFA(I_",")
- +8 SET FBADJLR=$PIECE(FBX,U)
- +9 DO FBCKI(I)
- +10 SET B(1617)=$SELECT(B="":"",$DATA(^FBAA(161.7,B,0)):$PIECE(^(0),"^"),1:"")
- +11 SET FBIN(1)=$PIECE(Z(0),"^",2)
- +12 DO WRITC
- +13 QUIT
- WRITC IF $Y+7>IOSL
- if $EXTRACT(IOST,1,2)["C-"
- DO ASKH^FBAACCB0
- if FBAAOUT
- QUIT
- WRITE @IOF
- DO HEDC
- +1 WRITE !!,$SELECT('$DATA(ZS):"",ZS="R":"*",1:"")
- +2 WRITE N,?35,S,?60,B(1617)
- +3 WRITE !,?3,V,?45,VID,?58,FBIN,?70,$$DATX^FBAAUTL($EXTRACT(FBIN(1),1,7))
- +4 IF FBFPPSC]""
- WRITE !,?4,"FPPS Claim ID: ",FBFPPSC," FPPS Line: ",FBFPPSL
- +5 WRITE !,$SELECT($DATA(QQ):QQ_")",1:""),FBVP,$SELECT(FBCAN]"":"+",1:""),?4,FBFD,?13,FBTD,?22,$JUSTIFY(FBAC,6),?32,$JUSTIFY(FBAP,6),?45,$SELECT(FBADJLR]"":FBADJLR,1:FBSC)
- +6 ;CSV
- if $PIECE(Z(0),"^",24)
- WRITE ?56,"Discharge ",$$ICD^FBCSV1(+$PIECE(Z(0),"^",24),$PIECE(Z(0),"^",6))
- WRITE !
- +7 ; write admitting diagnosis
- +8 NEW P7,P8
- +9 SET P7=$GET(^FBAAI(I,5))
- +10 SET FBADMTDX=$PIECE(P7,"^",9)
- +11 SET P8=$$ICD9^FBCSV1(FBADMTDX,$PIECE($GET(Z(0)),"^",6))
- +12 IF P8'=""
- WRITE !,?4,"Admit Dx: ",P8
- +13 ; set diagnosis code and present on admission code
- +14 NEW P1,P2
- +15 SET P1=$GET(^FBAAI(I,"DX"))
- +16 SET P2=$GET(^FBAAI(I,"POA"))
- +17 FOR FBK=1:1:25
- DO WRTDX
- +18 ; set procedure code
- +19 NEW P5
- +20 SET P5=$GET(^FBAAI(I,"PROC"))
- +21 FOR FBL=1:1:25
- DO WRTPC
- +22 ; write attachment IDs
- +23 IF $DATA(^FBAAI(I,10))
- Begin DoDot:1
- +24 NEW AI,AID,AITI,WRTPC
- +25 SET AI=0
- SET WRTPC="Attachment ID:"
- +26 FOR
- SET AI=$ORDER(^FBAAI(I,10,AI))
- if 'AI
- QUIT
- Begin DoDot:2
- +27 SET AID=$PIECE($GET(^FBAAI(I,10,AI,0)),"^")
- IF AI>1
- SET WRTPC=WRTPC_","
- +28 SET WRTPC=WRTPC_" "_AID
- +29 SET AITI=$PIECE($GET(^FBAAI(I,10,AI,0)),"^",2)
- IF AITI
- Begin DoDot:3
- +30 SET WRTPC=WRTPC_" ("_$PIECE($GET(^IBE(353.3,AITI,0)),"^")
- +31 SET WRTPC=WRTPC_" - "
- +32 SET WRTPC=WRTPC_$PIECE($GET(^IBE(353.3,AITI,0)),"^",2)_")"
- End DoDot:3
- +33 IF $LENGTH(WRTPC)>IOM
- DO WRTSTR(.WRTPC,IOM)
- End DoDot:2
- +34 IF $LENGTH(WRTPC)>0
- DO WRTSTR(.WRTPC,IOM)
- End DoDot:1
- +35 SET A2=FBAP
- DO PMNT^FBAACCB2
- KILL A2
- +36 QUIT
- WRTSTR(STR,MX) ; Wordwrap string
- +1 NEW RM,I
- WRTSTR1 SET RM=$SELECT(STR?1"Attachment ID:".E:MX-4,1:MX-7)
- +1 FOR I=1:1:$LENGTH(STR," ")
- if $LENGTH($PIECE(STR," ",1,I))>RM
- QUIT
- +2 WRITE !,?4
- if STR'?1"Attachment ID
- WRITE ?7
- +3 IF $LENGTH($PIECE(STR," ",1,I))>RM
- WRITE $PIECE(STR," ",1,I-1)
- SET STR=$PIECE(STR," ",I,999)
- +4 IF '$TEST
- WRITE $PIECE(STR," ",1,I)
- SET STR=""
- +5 IF $LENGTH(STR)>(MX-3)
- GOTO WRTSTR1
- +6 QUIT
- CDAT SET FBPDT=$EXTRACT(FBPDT,4,5)_"/"_$SELECT($EXTRACT(FBPDT,6,7)="00":$EXTRACT(FBPDT,2,3),1:$EXTRACT(FBPDT,6,7)_"/"_$EXTRACT(FBPDT,2,3))
- +1 QUIT
- HEDC WRITE "Patient Name",?20,"('*' Reimbursement to Veteran '+' Cancellation Activity)",!,?13,"('#' Voided Payment '&' Additional Payment)",?60,"Batch Number"
- +1 WRITE !,?3,"Vendor Name",?45,"Vendor ID",?57,"Invoice #",?68,"Dt Inv Rec'd",!,?3,"FR DATE",?14,"TO DATE CLAIMED PAID",?41,"ADJ CODE",!,Q,!
- +2 QUIT
- CHNH ; FB*3.5*116
- +1 SET (J,FZ("CNT"))=0
- FOR
- SET J=$ORDER(^FBAAI("AC",B,J))
- if J'>0
- QUIT
- IF $DATA(^FBAAI(J,0))
- SET Z(0)=^(0)
- DO MORECH
- if $PIECE(FZ,U,15)'="Y"
- DO INVCNT
- +2 ; CNH batch
- if $GET(FZ("CNT"))
- SET $PIECE(FZ,U,10)=FZ("CNT")
- KILL FZ("CNT")
- +3 GOTO FIN^FBAACCB
- +4 ;
- MORECH ; HIPAA 5010 - count line items that have 0.00 amount paid
- +1 SET T=T+$PIECE(Z(0),"^",9)
- SET C=C+1
- +2 ; FB*3.5*116 - build array of invoices
- +3 ;do not build array for CH batches not exempt from the pricer
- +4 if ($PIECE(FZ,"^",18)'="Y")&($PIECE(FZ,"^",15)="Y")
- QUIT
- +5 SET FBARY($PIECE(Z(0),"^"))=+$PIECE(Z(0),"^",9)
- +6 QUIT
- +7 ;
- WRTDX ; write diagnosis code and present on admission code
- +1 NEW P3,P4
- +2 SET FBDX=$PIECE(P1,"^",FBK)
- +3 SET FBPOA=$PIECE(P2,"^",FBK)
- +4 if FBDX=""
- QUIT
- +5 SET P3=$$ICD9^FBCSV1(FBDX,$PIECE($GET(Z(0)),"^",6))_"/"
- +6 SET P4=P3_$SELECT(FBPOA:$PIECE($GET(^FB(161.94,FBPOA,0)),"^"),1:"")
- +7 IF FBK=1!($X+$LENGTH(P4)+2>IOM)
- WRITE !,?4,"DX/POA: "
- +8 WRITE P4," "
- +9 QUIT
- +10 ;
- WRTPC ; write procedure code (if present)
- +1 NEW P6
- +2 SET FBPROC=$PIECE(P5,"^",FBL)
- +3 if FBPROC=""
- QUIT
- +4 SET P6=$$ICD0^FBCSV1(FBPROC,$PIECE($GET(Z(0)),"^",6))
- +5 IF FBL=1!($X+$LENGTH(P6)+2>IOM)
- WRITE !,?4,"PROC: "
- +6 WRITE P6," "
- +7 QUIT
- MORE ;
- +1 NEW FBADJLA,FBADJLR,FBFPPSC,FBFPPSL,FBX,TAMT
- +2 SET J=$PIECE(Z(0),"^",5)
- SET D=$PIECE(Z(0),"^",3)
- SET FBAACPT=$PIECE(Z(0),"^",1)
- SET N=$SELECT($DATA(^DPT(J,0)):$PIECE(^(0),"^",1),1:"")
- SET S=$SELECT(N]"":$PIECE(^DPT(J,0),"^",9),1:"")
- SET FBIN=A
- SET CPTDESC=$PIECE(Z(0),"^",2)
- +3 SET Y=""
- SET $PIECE(Y,"^",2)=$PIECE(Z(0),"^",4)
- SET $PIECE(Y,"^",3)=$PIECE(Z(0),"^",16)
- SET $PIECE(Y,"^",12)=0
- SET T=$PIECE(Z(0),"^",8)
- SET T=$SELECT(T="":"",$DATA(^FBAA(161.27,T,0)):^(0),1:"")
- SET $PIECE(Y,"^",9)=$PIECE(Z(0),"^",1)
- SET ZS=$PIECE(Z(0),"^",20)
- SET FBPV=""
- +4 ;
- +5 SET FBFPPSC=$PIECE($GET(^FBAA(162.1,A,0)),U,13)
- +6 SET FBFPPSL=$PIECE($GET(^FBAA(162.1,A,"RX",B2,3)),U)
- +7 SET FBX=$$ADJLRA^FBRXFA(B2_","_A_",")
- +8 SET FBADJLR=$PIECE(FBX,U)
- +9 SET FBADJLA=$PIECE(FBX,U,2)
- +10 SET TAMT=$FNUMBER($PIECE(Z(0),"^",7),"",2)
- +11 ;
- +12 DO FBCKP(A,B2)
- +13 SET FBIN(1)=$PIECE($GET(^FBAA(162.1,+A,0)),"^",2)
- +14 GOTO GO^FBAACCB
- INVCNT ;set invoice count for cnh batch
- +1 SET FZ("CNT")=FZ("CNT")+1
- +2 QUIT
- FBCKI(FBI) ;set inpatient check variables
- +1 ;fbi=DA
- +2 IF '$GET(FBI)
- SET (FBCKDT,FBCK,FBCANDT,FBCANR,FBCAN,FBDIS,FBCKINT)=""
- QUIT
- +3 SET FBCKIN=$GET(^FBAAI(FBI,2))
- +4 SET U="^"
- SET FBCKDT=+FBCKIN
- SET FBCK=$PIECE(FBCKIN,U,4)
- SET FBCANDT=$PIECE(FBCKIN,U,5)
- SET FBCANR=$PIECE(FBCKIN,U,6)
- SET FBCAN=$PIECE(FBCKIN,U,7)
- SET FBDIS=$PIECE(FBCKIN,U,8)
- SET FBCKINT=$PIECE(FBCKIN,U,9)
- KILL FBCKIN
- +5 QUIT
- FBCKP(J,K) ;set pharmacy check variables
- +1 ;j,k required input variables to = da(1) and da respectively (162.1)
- +2 IF '$GET(J)!('$GET(K))
- QUIT
- +3 SET FBCKIN=$GET(^FBAA(162.1,J,"RX",K,2))
- +4 SET U="^"
- SET FBCKDT=$PIECE(FBCKIN,U,8)
- SET FBCK=$PIECE(FBCKIN,U,10)
- SET FBCANDT=$PIECE(FBCKIN,U,11)
- SET FBCANR=$PIECE(FBCKIN,U,12)
- SET FBCAN=$PIECE(FBCKIN,U,13)
- SET FBDIS=$PIECE(FBCKIN,U,14)
- SET FBCKINT=$PIECE(FBCKIN,U,15)
- KILL FBCKIN
- +5 QUIT