Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: FBNHPC1

FBNHPC1.m

Go to the documentation of this file. 
  1. FBNHPC1 ;AISC/CMR-POST COMMITMENTS TO 1358 cont. ;9/20/94
  1.  ;;3.5;FEE BASIS;**153**;JAN 30, 1995;Build 14
  1.  ;;Per VA Directive 6402, this routine should not be modified.
  1.  ;
  1.  ;FB*3.5*153 Added calls to tag 'CHKSITOB' to insure obligation found in file
  1.  ;           FB7078 for time period selected is from the same station selected
  1.  ;           during option process.  This is true for both monthly activity
  1.  ;           as well as carry over activity and Insufficient Authorization 
  1.  ;           Rate data on file
  1.  ;
  1. CHECK S ^XTMP("FBPOST",FBIFN)=""
  1.  Q:$E(FBPAYDT,1,5)<$E(FBABD,1,5)
  1.  S FBTRDYS=0 K FBELSE
  1.  S FBERR=""  D CHKSITOB Q:$G(FBELSE)=1  D GETRAT^FBNHEP2 Q:FBERR  D CHECK^FBNHEP2 Q:FBERR  ;FB*3.5*153
  1.  S FBIFN=FBHIFN
  1.  D
  1.  .I $E(FBABD,1,5)<$E(FBPAYDT,1,5)&($E(FBDD,1,5)>$E(FBPAYDT,1,5)) S FBTRDYS=FBDAYS D CALC Q
  1.  .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
  1.  .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
  1.  .I FBABD=FBDD S FBTRDYS=1 D CALC Q
  1.  .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
  1.  Q:$D(FBELSE)
  1.  ;ifcap calls for posting
  1.  I 'FBNHCC,$D(^PRC(424,"E",+$P(FBZ,"^",3)_";"_+FBIFN_";"_$P(FBOBN,"-",2)_";"_FBMM)) Q
  1.  S FBSEQ="" I 'FBNHCC S X=FBOBN,PRCS("TYPE")="FB" D EN1^PRCSUT31 Q:Y=""  S FBSEQ=Y
  1.  S DFN=$P(FBZ,"^",3),FBNAME=$$NAME^FBCHREQ2(DFN),FBSSN=$$SSN^FBAAUTL(DFN),FBVEN=$P(FBZ,"^",2)
  1.  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
  1.  I 'FBNHCC G:+Y=0 ERR^FBNHPC
  1.  S FBTOTAL=FBTOTAL+FBTRDYS,FBTOT=FBTOT+FBDEFP,FBCNT=FBCNT+1
  1.  S ^TMP($J,"FBNHPC",FBNAME,FBCNT)=FBSSN_"^"_FBTRDYS_"^"_FBDEFP_"^"_$G(FBSEQ)_"^"_+FBVEN
  1.  Q
  1.  ;
  1. 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
  1.  .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)
  1.  .I $Y+3>IOSL,$E(IOST,1,2)["C-" S DIR(0)="E" D ^DIR K DIR S:'Y FBOUT=1 Q:FBOUT
  1.  .I ($Y+3)>IOSL W @IOF D HED
  1.  .W !,FBSEQ,?7,$E(FBNAME,1,20),?30,FBSSN,?44,$E($$VNAME^FBNHEXP(FBVEN),1,20),?66,FBTRDYS,?70,$J($FN(FBDEFP,",",2),10)
  1.  Q
  1.  ;
  1. 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",!
  1.  S I="",$P(I,"-",59)="-" W ?10,I K I W !
  1.  I FBNHCC W ?5,"Estimated Funds for: ",$P("Jan^Feb^Mar^Apr^May^Jun^Jul^Aug^Sep^Oct^Nov^Dec","^",+FBMM)," ",FBYY,!!
  1.  I 'FBNHCC W ?5,"Postings for Obligation Number: ",$P(FBOBN,"-",2),!!,"Ref #"
  1.  W ?7,"Veteran",?30,"SSN",?44,"Vendor",?65,"Days",?74,"Total",!,Q,!
  1.  Q
  1.  ;
  1. CALC S FBENDFLG=$S(FBDD'>FBENDDT:1,1:""),FBENDDT=$S(FBDD>FBENDDT:FBENDDT,1:FBDD),FBAABDT=FBABD D CALC^FBNHEP2
  1.  S FBENDDT=FBPAYEDT K FB
  1.  Q
  1.  ;FB*3.5*153
  1. CHKSITOB ;INSURE ENTRY IS FOR CORRECT SITE/OBLIGATION
  1.  S FBOBNO=$E($P(FBZ,U),1,6)
  1.  S FBOBIEN=$O(^PRC(442,"B",PRC("SITE")_"-"_FBOBNO,0)) I FBOBIEN="" S FBELSE=1 Q
  1.  S PRC23=$G(^PRC(442,FBOBIEN,23)) I PRC23="" S FBELSE=1 Q
  1.  I $P(PRC23,U,7)'=FBSTA S FBELSE=1 Q
  1.  Q