- PRCPUBAL ;WISC/RFJ-update beginning item balances ;23 Jul 92
- ;;5.1;IFCAP;;Oct 20, 2000
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- Q
- ;
- ;
- BALANCE(INVPT,ITEMDA,PRCPMOYR) ; update beginning monthly balance
- N %,%H,%I,D,D0,DA,DATA,DD,DI,DIC,DIE,DINUM,DLAYGO,DQ,DR,X,Y
- I 'PRCPMOYR D NOW^%DTC S PRCPMOYR=$E(X,1,5)
- I 'INVPT!('ITEMDA) Q
- ; monthly beginning balance already set
- I $D(^PRCP(445.1,INVPT,1,ITEMDA,1,PRCPMOYR,0)) Q
- L +^PRCP(445.1,INVPT,1,ITEMDA,1,PRCPMOYR)
- I '$D(^PRCP(445.1,INVPT,0)) D I '$D(^PRCP(445.1,INVPT,0)) D Q Q
- . 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
- I '$D(^PRCP(445.1,INVPT,1,ITEMDA,0)) D I '$D(^PRCP(445.1,INVPT,1,ITEMDA,0)) D Q Q
- . S:'$D(^PRCP(445.1,INVPT,1,0)) ^(0)="^445.11P^^"
- . 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
- 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
- . S:'$D(^PRCP(445.1,INVPT,1,ITEMDA,1,0)) ^(0)="^445.111D^^"
- . 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
- S DATA=$G(^PRCP(445,INVPT,1,ITEMDA,0))
- I $P(DATA,"^",27)="" S $P(DATA,"^",27)=$J(($P(DATA,"^",7)+$P(DATA,"^",19))*$P(DATA,"^",22),0,2)
- ;
- I $P(DATA,"^",22)'>0 S $P(DATA,"^",22)=0
- I $P(DATA,"^",15)'>0 S $P(DATA,"^",15)=0
- S DIE="^PRCP(445.1,"_INVPT_",1,"_ITEMDA_",1,",DA=PRCPMOYR,DA(1)=ITEMDA,DA(2)=INVPT
- 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)
- D ^DIE
- Q L -^PRCP(445.1,INVPT,1,ITEMDA,1,PRCPMOYR)
- Q
- ;
- ;
- GETOPEN(INVPT,ITEMDA,DATE) ; return open balance for invpt item for date
- N %,Y
- S Y="" I $D(^PRCP(445.2,"ABEG",+INVPT,+ITEMDA,+DATE)) S %=^(+DATE),$P(Y,"^",2)=$P(%,"^"),$P(Y,"^",8)=$P(%,"^",2)
- S %=$G(^PRCP(445.1,+INVPT,1,+ITEMDA,1,+DATE,0)) I %'="" S Y=%
- Q Y
- ;
- ;
- TASKSET ; taskman job to set beginning monthly balance
- N %,%H,%I,D,INVPT,ITEMDA,MONTH,PRCPDATE,PRCPTEXT,PRCPXMY,TYPE,X,XCNP,XMDUZ,XMZ
- 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)
- 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
- . L +^PRCP(445,INVPT,1)
- . D ADD^PRCPULOC(445,INVPT_"-1",0,"Opening Balances Being Set")
- . 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
- . . 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)=%
- . . D BALANCE(INVPT,ITEMDA,PRCPDATE)
- . D CLEAR^PRCPULOC(445,INVPT_"-1",0)
- . L -^PRCP(445,INVPT,1)
- . S $P(^PRCP(445,INVPT,0),"^",22)=PRCPDATE_"00"
- . D GETUSER^PRCPXTRM(INVPT) I '$D(PRCPXMY) Q
- . K XMY S X=0 F S X=$O(PRCPXMY(X)) Q:'X I PRCPXMY(X) S XMY(X)=""
- . I $O(XMY(0))="" Q
- . 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
- . S XMSUB="OPENING BALANCE FOR "_MONTH_" SET",XMTEXT="PRCPTEXT(" D ^XMD
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPUBAL 3467 printed Feb 18, 2025@23:42:28 Page 2
- PRCPUBAL ;WISC/RFJ-update beginning item balances ;23 Jul 92
- +1 ;;5.1;IFCAP;;Oct 20, 2000
- +2 ;Per VHA Directive 10-93-142, this routine should not be modified.
- +3 QUIT
- +4 ;
- +5 ;
- BALANCE(INVPT,ITEMDA,PRCPMOYR) ; update beginning monthly balance
- +1 NEW %,%H,%I,D,D0,DA,DATA,DD,DI,DIC,DIE,DINUM,DLAYGO,DQ,DR,X,Y
- +2 IF 'PRCPMOYR
- DO NOW^%DTC
- SET PRCPMOYR=$EXTRACT(X,1,5)
- +3 IF 'INVPT!('ITEMDA)
- QUIT
- +4 ; monthly beginning balance already set
- +5 IF $DATA(^PRCP(445.1,INVPT,1,ITEMDA,1,PRCPMOYR,0))
- QUIT
- +6 LOCK +^PRCP(445.1,INVPT,1,ITEMDA,1,PRCPMOYR)
- +7 IF '$DATA(^PRCP(445.1,INVPT,0))
- Begin DoDot:1
- +8 KILL DD,D0
- SET DIC="^PRCP(445.1,"
- SET DIC(0)="L"
- SET DLAYGO=445.1
- SET (X,DINUM)=INVPT
- SET PRCPPRIV=1
- DO FILE^DICN
- KILL PRCPPRIV,DIC,DLAYGO
- End DoDot:1
- IF '$DATA(^PRCP(445.1,INVPT,0))
- DO Q
- QUIT
- +9 IF '$DATA(^PRCP(445.1,INVPT,1,ITEMDA,0))
- Begin DoDot:1
- +10 if '$DATA(^PRCP(445.1,INVPT,1,0))
- SET ^(0)="^445.11P^^"
- +11 KILL DA,DD,D0
- SET DIC="^PRCP(445.1,"_INVPT_",1,"
- SET DIC(0)="L"
- SET DLAYGO=445.1
- SET DA(1)=INVPT
- SET (X,DINUM)=ITEMDA
- DO FILE^DICN
- KILL DIC,DLAYGO
- End DoDot:1
- IF '$DATA(^PRCP(445.1,INVPT,1,ITEMDA,0))
- DO Q
- QUIT
- +12 IF '$DATA(^PRCP(445.1,INVPT,1,ITEMDA,1,PRCPMOYR,0))
- Begin DoDot:1
- +13 if '$DATA(^PRCP(445.1,INVPT,1,ITEMDA,1,0))
- SET ^(0)="^445.111D^^"
- +14 KILL DA,DD,D0
- SET DIC="^PRCP(445.1,"_INVPT_",1,"_ITEMDA_",1,"
- SET DIC(0)="L"
- SET DLAYGO=445.1
- SET DA(1)=ITEMDA
- SET DA(2)=INVPT
- SET (X,DINUM)=PRCPMOYR
- DO FILE^DICN
- KILL DIC,DLAYGO
- End DoDot:1
- IF '$DATA(^PRCP(445.1,INVPT,1,ITEMDA,1,PRCPMOYR,0))
- DO Q
- QUIT
- +15 SET DATA=$GET(^PRCP(445,INVPT,1,ITEMDA,0))
- +16 IF $PIECE(DATA,"^",27)=""
- SET $PIECE(DATA,"^",27)=$JUSTIFY(($PIECE(DATA,"^",7)+$PIECE(DATA,"^",19))*$PIECE(DATA,"^",22),0,2)
- +17 ;
- +18 IF $PIECE(DATA,"^",22)'>0
- SET $PIECE(DATA,"^",22)=0
- +19 IF $PIECE(DATA,"^",15)'>0
- SET $PIECE(DATA,"^",15)=0
- +20 SET DIE="^PRCP(445.1,"_INVPT_",1,"_ITEMDA_",1,"
- SET DA=PRCPMOYR
- SET DA(1)=ITEMDA
- SET DA(2)=INVPT
- +21 SET DR="1///"_+$PIECE(DATA,"^",7)_";2///"_+$PIECE(DATA,"^",19)_";3///"_$$GETIN^PRCPUDUE(INVPT,ITEMDA)_";4///"_$$GETOUT^PRCPUDUE(INVPT,ITEMDA)_";5///"_+$PIECE(DATA,"^",22)_";6///"_+$PIECE(DATA,"^",15)_";7///"_+$PIECE(DATA,"^",27)
- +22 DO ^DIE
- Q LOCK -^PRCP(445.1,INVPT,1,ITEMDA,1,PRCPMOYR)
- +1 QUIT
- +2 ;
- +3 ;
- GETOPEN(INVPT,ITEMDA,DATE) ; return open balance for invpt item for date
- +1 NEW %,Y
- +2 SET Y=""
- IF $DATA(^PRCP(445.2,"ABEG",+INVPT,+ITEMDA,+DATE))
- SET %=^(+DATE)
- SET $PIECE(Y,"^",2)=$PIECE(%,"^")
- SET $PIECE(Y,"^",8)=$PIECE(%,"^",2)
- +3 SET %=$GET(^PRCP(445.1,+INVPT,1,+ITEMDA,1,+DATE,0))
- IF %'=""
- SET Y=%
- +4 QUIT Y
- +5 ;
- +6 ;
- TASKSET ; taskman job to set beginning monthly balance
- +1 NEW %,%H,%I,D,INVPT,ITEMDA,MONTH,PRCPDATE,PRCPTEXT,PRCPXMY,TYPE,X,XCNP,XMDUZ,XMZ
- +2 DO NOW^%DTC
- SET PRCPDATE=$EXTRACT(X,1,5)
- SET MONTH=$PIECE("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC","^",+$EXTRACT(X,4,5))_" "_(17+$EXTRACT(X))_$EXTRACT(X,2,3)
- +3 SET INVPT=0
- FOR
- SET INVPT=$ORDER(^PRCP(445,INVPT))
- if 'INVPT
- QUIT
- IF $PIECE($GET(^PRCP(445,INVPT,0)),"^",6)="Y"
- SET TYPE=$PIECE(^(0),"^",3)
- Begin DoDot:1
- +4 LOCK +^PRCP(445,INVPT,1)
- +5 DO ADD^PRCPULOC(445,INVPT_"-1",0,"Opening Balances Being Set")
- +6 SET ITEMDA=0
- FOR
- SET ITEMDA=$ORDER(^PRCP(445,INVPT,1,ITEMDA))
- if 'ITEMDA
- QUIT
- IF $DATA(^PRCP(445,INVPT,1,ITEMDA,0))
- SET D=^(0)
- Begin DoDot:2
- +7 IF TYPE="W"
- IF $PIECE(D,"^",27)=""
- SET %=+$JUSTIFY(($PIECE(D,"^",7)+$PIECE(D,"^",19))*$PIECE(D,"^",22),0,2)
- SET $PIECE(^PRCP(445,INVPT,1,ITEMDA,0),"^",27)=%
- +8 DO BALANCE(INVPT,ITEMDA,PRCPDATE)
- End DoDot:2
- +9 DO CLEAR^PRCPULOC(445,INVPT_"-1",0)
- +10 LOCK -^PRCP(445,INVPT,1)
- +11 SET $PIECE(^PRCP(445,INVPT,0),"^",22)=PRCPDATE_"00"
- +12 DO GETUSER^PRCPXTRM(INVPT)
- IF '$DATA(PRCPXMY)
- QUIT
- +13 KILL XMY
- SET X=0
- FOR
- SET X=$ORDER(PRCPXMY(X))
- if 'X
- QUIT
- IF PRCPXMY(X)
- SET XMY(X)=""
- +14 IF $ORDER(XMY(0))=""
- QUIT
- +15 KILL PRCPTEXT
- SET PRCPTEXT(1,0)="The opening balances for the inventory point: "_$$INVNAME^PRCPUX1(INVPT)
- SET PRCPTEXT(2,0)=" have been set for the month and year: "_MONTH
- +16 SET XMSUB="OPENING BALANCE FOR "_MONTH_" SET"
- SET XMTEXT="PRCPTEXT("
- DO ^XMD
- End DoDot:1
- +17 QUIT