FBNHPC1 ;AISC/CMR-POST COMMITMENTS TO 1358 cont. ;9/20/94
;;3.5;FEE BASIS;**153**;JAN 30, 1995;Build 14
;;Per VA Directive 6402, this routine should not be modified.
;
;FB*3.5*153 Added calls to tag 'CHKSITOB' to insure obligation found in file
; FB7078 for time period selected is from the same station selected
; during option process. This is true for both monthly activity
; as well as carry over activity and Insufficient Authorization
; Rate data on file
;
CHECK S ^XTMP("FBPOST",FBIFN)=""
Q:$E(FBPAYDT,1,5)<$E(FBABD,1,5)
S FBTRDYS=0 K FBELSE
S FBERR="" D CHKSITOB Q:$G(FBELSE)=1 D GETRAT^FBNHEP2 Q:FBERR D CHECK^FBNHEP2 Q:FBERR ;FB*3.5*153
S FBIFN=FBHIFN
D
.I $E(FBABD,1,5)<$E(FBPAYDT,1,5)&($E(FBDD,1,5)>$E(FBPAYDT,1,5)) S FBTRDYS=FBDAYS D CALC Q
.I $E(FBABD,1,5)<$E(FBPAYDT,1,5)&($E(FBDD,1,5)'>$E(FBPAYDT,1,5)) S FBTRDYS=$E(FBDD,6,7)-1,FBTRDYS=$S(FBTRDYS>0:FBTRDYS,1:0) S:FBTRDYS'>0 FBELSE=1 D CALC Q
.I $E(FBABD,1,5)=$E(FBPAYDT,1,5)&($E(FBDD,1,5)>$E(FBPAYDT,1,5)) S FBTRDYS=(FBDAYS-$E(FBABD,6,7))+1 D CALC Q
.I FBABD=FBDD S FBTRDYS=1 D CALC Q
.I $E(FBABD,1,5)=$E(FBPAYDT,1,5)&($E(FBDD,1,5)'>$E(FBPAYDT,1,5)) S FBTRDYS=FBDD-FBABD,FBTRDYS=$S(FBTRDYS>0:FBTRDYS,1:0) S:FBTRDYS'>0 FBELSE=1 D CALC Q
Q:$D(FBELSE)
;ifcap calls for posting
I 'FBNHCC,$D(^PRC(424,"E",+$P(FBZ,"^",3)_";"_+FBIFN_";"_$P(FBOBN,"-",2)_";"_FBMM)) Q
S FBSEQ="" I 'FBNHCC S X=FBOBN,PRCS("TYPE")="FB" D EN1^PRCSUT31 Q:Y="" S FBSEQ=Y
S DFN=$P(FBZ,"^",3),FBNAME=$$NAME^FBCHREQ2(DFN),FBSSN=$$SSN^FBAAUTL(DFN),FBVEN=$P(FBZ,"^",2)
S PRCS("TYPE")="FB" I 'FBNHCC D NOW^%DTC S FBPOSDT=%,X=FBOBN_"^"_FBPOSDT_"^"_FBDEFP_"^^"_FBSEQ_"^"_FBNAME_" ("_FBSSN_")"_"^"_+DFN_";"_+FBIFN_";"_$P(FBOBN,"-",2)_";"_FBMM D EN2^PRCS58
I 'FBNHCC G:+Y=0 ERR^FBNHPC
S FBTOTAL=FBTOTAL+FBTRDYS,FBTOT=FBTOT+FBDEFP,FBCNT=FBCNT+1
S ^TMP($J,"FBNHPC",FBNAME,FBCNT)=FBSSN_"^"_FBTRDYS_"^"_FBDEFP_"^"_$G(FBSEQ)_"^"_+FBVEN
Q
;
PRT S FBNAME="" F S FBNAME=$O(^TMP($J,"FBNHPC",FBNAME)) Q:FBNAME']""!($G(FBOUT)) F FBCNT=0:0 S FBCNT=$O(^TMP($J,"FBNHPC",FBNAME,FBCNT)) Q:'FBCNT!($G(FBOUT)) D
.S Y(0)=$G(^TMP($J,"FBNHPC",FBNAME,FBCNT)),FBSSN=$P(Y(0),"^"),FBTRDYS=$P(Y(0),"^",2),FBDEFP=$P(Y(0),"^",3),FBSEQ=$P(Y(0),"^",4),FBVEN=$P(Y(0),"^",5)
.I $Y+3>IOSL,$E(IOST,1,2)["C-" S DIR(0)="E" D ^DIR K DIR S:'Y FBOUT=1 Q:FBOUT
.I ($Y+3)>IOSL W @IOF D HED
.W !,FBSEQ,?7,$E(FBNAME,1,20),?30,FBSSN,?44,$E($$VNAME^FBNHEXP(FBVEN),1,20),?66,FBTRDYS,?70,$J($FN(FBDEFP,",",2),10)
Q
;
HED W !?11,"C O M M U N I T Y N U R S I N G H O M E R E P O R T",!
S I="",$P(I,"-",59)="-" W ?10,I K I W !
I FBNHCC W ?5,"Estimated Funds for: ",$P("Jan^Feb^Mar^Apr^May^Jun^Jul^Aug^Sep^Oct^Nov^Dec","^",+FBMM)," ",FBYY,!!
I 'FBNHCC W ?5,"Postings for Obligation Number: ",$P(FBOBN,"-",2),!!,"Ref #"
W ?7,"Veteran",?30,"SSN",?44,"Vendor",?65,"Days",?74,"Total",!,Q,!
Q
;
CALC S FBENDFLG=$S(FBDD'>FBENDDT:1,1:""),FBENDDT=$S(FBDD>FBENDDT:FBENDDT,1:FBDD),FBAABDT=FBABD D CALC^FBNHEP2
S FBENDDT=FBPAYEDT K FB
Q
;FB*3.5*153
CHKSITOB ;INSURE ENTRY IS FOR CORRECT SITE/OBLIGATION
S FBOBNO=$E($P(FBZ,U),1,6)
S FBOBIEN=$O(^PRC(442,"B",PRC("SITE")_"-"_FBOBNO,0)) I FBOBIEN="" S FBELSE=1 Q
S PRC23=$G(^PRC(442,FBOBIEN,23)) I PRC23="" S FBELSE=1 Q
I $P(PRC23,U,7)'=FBSTA S FBELSE=1 Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBNHPC1 3331 printed Apr 09, 2024@21:00:40 Page 2
FBNHPC1 ;AISC/CMR-POST COMMITMENTS TO 1358 cont. ;9/20/94
+1 ;;3.5;FEE BASIS;**153**;JAN 30, 1995;Build 14
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ;FB*3.5*153 Added calls to tag 'CHKSITOB' to insure obligation found in file
+5 ; FB7078 for time period selected is from the same station selected
+6 ; during option process. This is true for both monthly activity
+7 ; as well as carry over activity and Insufficient Authorization
+8 ; Rate data on file
+9 ;
CHECK SET ^XTMP("FBPOST",FBIFN)=""
+1 if $EXTRACT(FBPAYDT,1,5)<$EXTRACT(FBABD,1,5)
QUIT
+2 SET FBTRDYS=0
KILL FBELSE
+3 ;FB*3.5*153
SET FBERR=""
DO CHKSITOB
if $GET(FBELSE)=1
QUIT
DO GETRAT^FBNHEP2
if FBERR
QUIT
DO CHECK^FBNHEP2
if FBERR
QUIT
+4 SET FBIFN=FBHIFN
+5 Begin DoDot:1
+6 IF $EXTRACT(FBABD,1,5)<$EXTRACT(FBPAYDT,1,5)&($EXTRACT(FBDD,1,5)>$EXTRACT(FBPAYDT,1,5))
SET FBTRDYS=FBDAYS
DO CALC
QUIT
+7 IF $EXTRACT(FBABD,1,5)<$EXTRACT(FBPAYDT,1,5)&($EXTRACT(FBDD,1,5)'>$EXTRACT(FBPAYDT,1,5))
SET FBTRDYS=$EXTRACT(FBDD,6,7)-1
SET FBTRDYS=$SELECT(FBTRDYS>0:FBTRDYS,1:0)
if FBTRDYS'>0
SET FBELSE=1
DO CALC
QUIT
+8 IF $EXTRACT(FBABD,1,5)=$EXTRACT(FBPAYDT,1,5)&($EXTRACT(FBDD,1,5)>$EXTRACT(FBPAYDT,1,5))
SET FBTRDYS=(FBDAYS-$EXTRACT(FBABD,6,7))+1
DO CALC
QUIT
+9 IF FBABD=FBDD
SET FBTRDYS=1
DO CALC
QUIT
+10 IF $EXTRACT(FBABD,1,5)=$EXTRACT(FBPAYDT,1,5)&($EXTRACT(FBDD,1,5)'>$EXTRACT(FBPAYDT,1,5))
SET FBTRDYS=FBDD-FBABD
SET FBTRDYS=$SELECT(FBTRDYS>0:FBTRDYS,1:0)
if FBTRDYS'>0
SET FBELSE=1
DO CALC
QUIT
End DoDot:1
+11 if $DATA(FBELSE)
QUIT
+12 ;ifcap calls for posting
+13 IF 'FBNHCC
IF $DATA(^PRC(424,"E",+$PIECE(FBZ,"^",3)_";"_+FBIFN_";"_$PIECE(FBOBN,"-",2)_";"_FBMM))
QUIT
+14 SET FBSEQ=""
IF 'FBNHCC
SET X=FBOBN
SET PRCS("TYPE")="FB"
DO EN1^PRCSUT31
if Y=""
QUIT
SET FBSEQ=Y
+15 SET DFN=$PIECE(FBZ,"^",3)
SET FBNAME=$$NAME^FBCHREQ2(DFN)
SET FBSSN=$$SSN^FBAAUTL(DFN)
SET FBVEN=$PIECE(FBZ,"^",2)
+16 SET PRCS("TYPE")="FB"
IF 'FBNHCC
DO NOW^%DTC
SET FBPOSDT=%
SET X=FBOBN_"^"_FBPOSDT_"^"_FBDEFP_"^^"_FBSEQ_"^"_FBNAME_" ("_FBSSN_")"_"^"_+DFN_";"_+FBIFN_";"_$PIECE(FBOBN,"-",2)_";"_FBMM
DO EN2^PRCS58
+17 IF 'FBNHCC
if +Y=0
GOTO ERR^FBNHPC
+18 SET FBTOTAL=FBTOTAL+FBTRDYS
SET FBTOT=FBTOT+FBDEFP
SET FBCNT=FBCNT+1
+19 SET ^TMP($JOB,"FBNHPC",FBNAME,FBCNT)=FBSSN_"^"_FBTRDYS_"^"_FBDEFP_"^"_$GET(FBSEQ)_"^"_+FBVEN
+20 QUIT
+21 ;
PRT SET FBNAME=""
FOR
SET FBNAME=$ORDER(^TMP($JOB,"FBNHPC",FBNAME))
if FBNAME']""!($GET(FBOUT))
QUIT
FOR FBCNT=0:0
SET FBCNT=$ORDER(^TMP($JOB,"FBNHPC",FBNAME,FBCNT))
if 'FBCNT!($GET(FBOUT))
QUIT
Begin DoDot:1
+1 SET Y(0)=$GET(^TMP($JOB,"FBNHPC",FBNAME,FBCNT))
SET FBSSN=$PIECE(Y(0),"^")
SET FBTRDYS=$PIECE(Y(0),"^",2)
SET FBDEFP=$PIECE(Y(0),"^",3)
SET FBSEQ=$PIECE(Y(0),"^",4)
SET FBVEN=$PIECE(Y(0),"^",5)
+2 IF $Y+3>IOSL
IF $EXTRACT(IOST,1,2)["C-"
SET DIR(0)="E"
DO ^DIR
KILL DIR
if 'Y
SET FBOUT=1
if FBOUT
QUIT
+3 IF ($Y+3)>IOSL
WRITE @IOF
DO HED
+4 WRITE !,FBSEQ,?7,$EXTRACT(FBNAME,1,20),?30,FBSSN,?44,$EXTRACT($$VNAME^FBNHEXP(FBVEN),1,20),?66,FBTRDYS,?70,$JUSTIFY($FNUMBER(FBDEFP,",",2),10)
End DoDot:1
+5 QUIT
+6 ;
HED WRITE !?11,"C O M M U N I T Y N U R S I N G H O M E R E P O R T",!
+1 SET I=""
SET $PIECE(I,"-",59)="-"
WRITE ?10,I
KILL I
WRITE !
+2 IF FBNHCC
WRITE ?5,"Estimated Funds for: ",$PIECE("Jan^Feb^Mar^Apr^May^Jun^Jul^Aug^Sep^Oct^Nov^Dec","^",+FBMM)," ",FBYY,!!
+3 IF 'FBNHCC
WRITE ?5,"Postings for Obligation Number: ",$PIECE(FBOBN,"-",2),!!,"Ref #"
+4 WRITE ?7,"Veteran",?30,"SSN",?44,"Vendor",?65,"Days",?74,"Total",!,Q,!
+5 QUIT
+6 ;
CALC SET FBENDFLG=$SELECT(FBDD'>FBENDDT:1,1:"")
SET FBENDDT=$SELECT(FBDD>FBENDDT:FBENDDT,1:FBDD)
SET FBAABDT=FBABD
DO CALC^FBNHEP2
+1 SET FBENDDT=FBPAYEDT
KILL FB
+2 QUIT
+3 ;FB*3.5*153
CHKSITOB ;INSURE ENTRY IS FOR CORRECT SITE/OBLIGATION
+1 SET FBOBNO=$EXTRACT($PIECE(FBZ,U),1,6)
+2 SET FBOBIEN=$ORDER(^PRC(442,"B",PRC("SITE")_"-"_FBOBNO,0))
IF FBOBIEN=""
SET FBELSE=1
QUIT
+3 SET PRC23=$GET(^PRC(442,FBOBIEN,23))
IF PRC23=""
SET FBELSE=1
QUIT
+4 IF $PIECE(PRC23,U,7)'=FBSTA
SET FBELSE=1
QUIT
+5 QUIT
