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

PRCPUBAL.m

Go to the documentation of this file.
  1. PRCPUBAL ;WISC/RFJ-update beginning item balances ;23 Jul 92
  1. ;;5.1;IFCAP;;Oct 20, 2000
  1. ;Per VHA Directive 10-93-142, this routine should not be modified.
  1. Q
  1. ;
  1. ;
  1. BALANCE(INVPT,ITEMDA,PRCPMOYR) ; update beginning monthly balance
  1. N %,%H,%I,D,D0,DA,DATA,DD,DI,DIC,DIE,DINUM,DLAYGO,DQ,DR,X,Y
  1. I 'PRCPMOYR D NOW^%DTC S PRCPMOYR=$E(X,1,5)
  1. I 'INVPT!('ITEMDA) Q
  1. ; monthly beginning balance already set
  1. I $D(^PRCP(445.1,INVPT,1,ITEMDA,1,PRCPMOYR,0)) Q
  1. L +^PRCP(445.1,INVPT,1,ITEMDA,1,PRCPMOYR)
  1. I '$D(^PRCP(445.1,INVPT,0)) D I '$D(^PRCP(445.1,INVPT,0)) D Q Q
  1. . K DD,D0 S DIC="^PRCP(445.1,",DIC(0)="L",DLAYGO=445.1,(X,DINUM)=INVPT,PRCPPRIV=1 D FILE^DICN K PRCPPRIV,DIC,DLAYGO
  1. I '$D(^PRCP(445.1,INVPT,1,ITEMDA,0)) D I '$D(^PRCP(445.1,INVPT,1,ITEMDA,0)) D Q Q
  1. . S:'$D(^PRCP(445.1,INVPT,1,0)) ^(0)="^445.11P^^"
  1. . K DA,DD,D0 S DIC="^PRCP(445.1,"_INVPT_",1,",DIC(0)="L",DLAYGO=445.1,DA(1)=INVPT,(X,DINUM)=ITEMDA D FILE^DICN K DIC,DLAYGO
  1. I '$D(^PRCP(445.1,INVPT,1,ITEMDA,1,PRCPMOYR,0)) D I '$D(^PRCP(445.1,INVPT,1,ITEMDA,1,PRCPMOYR,0)) D Q Q
  1. . S:'$D(^PRCP(445.1,INVPT,1,ITEMDA,1,0)) ^(0)="^445.111D^^"
  1. . K DA,DD,D0 S DIC="^PRCP(445.1,"_INVPT_",1,"_ITEMDA_",1,",DIC(0)="L",DLAYGO=445.1,DA(1)=ITEMDA,DA(2)=INVPT,(X,DINUM)=PRCPMOYR D FILE^DICN K DIC,DLAYGO
  1. S DATA=$G(^PRCP(445,INVPT,1,ITEMDA,0))
  1. I $P(DATA,"^",27)="" S $P(DATA,"^",27)=$J(($P(DATA,"^",7)+$P(DATA,"^",19))*$P(DATA,"^",22),0,2)
  1. ;
  1. I $P(DATA,"^",22)'>0 S $P(DATA,"^",22)=0
  1. I $P(DATA,"^",15)'>0 S $P(DATA,"^",15)=0
  1. S DIE="^PRCP(445.1,"_INVPT_",1,"_ITEMDA_",1,",DA=PRCPMOYR,DA(1)=ITEMDA,DA(2)=INVPT
  1. S DR="1///"_+$P(DATA,"^",7)_";2///"_+$P(DATA,"^",19)_";3///"_$$GETIN^PRCPUDUE(INVPT,ITEMDA)_";4///"_$$GETOUT^PRCPUDUE(INVPT,ITEMDA)_";5///"_+$P(DATA,"^",22)_";6///"_+$P(DATA,"^",15)_";7///"_+$P(DATA,"^",27)
  1. D ^DIE
  1. Q L -^PRCP(445.1,INVPT,1,ITEMDA,1,PRCPMOYR)
  1. Q
  1. ;
  1. ;
  1. GETOPEN(INVPT,ITEMDA,DATE) ; return open balance for invpt item for date
  1. N %,Y
  1. S Y="" I $D(^PRCP(445.2,"ABEG",+INVPT,+ITEMDA,+DATE)) S %=^(+DATE),$P(Y,"^",2)=$P(%,"^"),$P(Y,"^",8)=$P(%,"^",2)
  1. S %=$G(^PRCP(445.1,+INVPT,1,+ITEMDA,1,+DATE,0)) I %'="" S Y=%
  1. Q Y
  1. ;
  1. ;
  1. TASKSET ; taskman job to set beginning monthly balance
  1. N %,%H,%I,D,INVPT,ITEMDA,MONTH,PRCPDATE,PRCPTEXT,PRCPXMY,TYPE,X,XCNP,XMDUZ,XMZ
  1. D NOW^%DTC S PRCPDATE=$E(X,1,5),MONTH=$P("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC","^",+$E(X,4,5))_" "_(17+$E(X))_$E(X,2,3)
  1. S INVPT=0 F S INVPT=$O(^PRCP(445,INVPT)) Q:'INVPT I $P($G(^PRCP(445,INVPT,0)),"^",6)="Y" S TYPE=$P(^(0),"^",3) D
  1. . L +^PRCP(445,INVPT,1)
  1. . D ADD^PRCPULOC(445,INVPT_"-1",0,"Opening Balances Being Set")
  1. . S ITEMDA=0 F S ITEMDA=$O(^PRCP(445,INVPT,1,ITEMDA)) Q:'ITEMDA I $D(^PRCP(445,INVPT,1,ITEMDA,0)) S D=^(0) D
  1. . . I TYPE="W",$P(D,"^",27)="" S %=+$J(($P(D,"^",7)+$P(D,"^",19))*$P(D,"^",22),0,2),$P(^PRCP(445,INVPT,1,ITEMDA,0),"^",27)=%
  1. . . D BALANCE(INVPT,ITEMDA,PRCPDATE)
  1. . D CLEAR^PRCPULOC(445,INVPT_"-1",0)
  1. . L -^PRCP(445,INVPT,1)
  1. . S $P(^PRCP(445,INVPT,0),"^",22)=PRCPDATE_"00"
  1. . D GETUSER^PRCPXTRM(INVPT) I '$D(PRCPXMY) Q
  1. . K XMY S X=0 F S X=$O(PRCPXMY(X)) Q:'X I PRCPXMY(X) S XMY(X)=""
  1. . I $O(XMY(0))="" Q
  1. . K PRCPTEXT S PRCPTEXT(1,0)="The opening balances for the inventory point: "_$$INVNAME^PRCPUX1(INVPT),PRCPTEXT(2,0)=" have been set for the month and year: "_MONTH
  1. . S XMSUB="OPENING BALANCE FOR "_MONTH_" SET",XMTEXT="PRCPTEXT(" D ^XMD
  1. Q