PRCHREC7 ;WISC/RWS-CODE SHEET GENERATOR - DEPOT TRANSACTIONS ;10-24-91/10:10
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
;
LOG ;CREATE LOG CODE SHEETS
N D0,I D:'$D(PRCHDEP) VOUCHER Q:'PRCHDEP
S PRCFA("DEL")=$P(^PRC(442,PRCHPO,0),U,10),PRCFA("LBN")=$P(^(0),U,1),PRCFA("ISSUE")=$P(^(2,+PRCHRIT,0),U,3),PRCFA("MULT")=$P(^(0),U,12),Y=$P(^(0),U,13),PRCFA("NSN")=$E(Y,6,7)_$E(Y,9,11)_$E(Y,13,17),PRCFA("FSC")=Y
S Y=$P(PRCHDEP,U,2),PRCFA("LDATE")=$E(Y,4,7)_$E(Y,2,3),PRCFA("SITE")=$S($E(PRCHDEP)=2:"79A",$E(PRCHDEP)=3:"794",1:"793"),PRCFA("TTLEN")=80
S PRCHLOG="",PRCFA("SYS")="LOG",PRCFA("TT")=$S($D(PRCHNRQ):"431",1:"434"),PRCFA("REF")=$E($P($P(^PRC(442,PRCHPO,0),U,1),"-",2),2,6),PRCF("X")="P",PRCFA("EDIT")="[PRCHL"_PRCFA("TT")_"]"
D:PRCHRTP PRINT D ^PRCFSITE G:'% OUT D NEWCS^PRCFAC G:'$D(DA) OUT S $P(^PRC(442,PRCHPO,2,+PRCHRIT,3,PRCHRDY,0),U,6)=DA,^PRC(442,PRCHPO,2,+PRCHRIT,3,"AB",DA,PRCHRDY)=""
S X1=+PRCHRIT_"^^"_PRCHRQ_U_"^^^"_PRCFA("DEL")_"^^"_PRCFA("NSN"),PRCFA("LBN")=PRCFA("LBN")_"."_$P(PRCHRIT,U,1)
S Z=$P(PRCHDEP,U,2)_U_"^^^^^^^^"_PRCFA("MULT")_"^^"_PRCHRAM_"^^^"_PRCFA("SITE")
S ^PRCF(423,DA,300)=X1,^(304)=Z,$P(^(301),U,15)=PRCFA("REF"),$P(^(301),U,38)=+PRCHDEP
;
VOU S DIE="^PRCF(423,",DR="[PRCH-REC7 LOG 431/434]" D ^DIE,^PRCFACX1
;
OUT K %,B,D,D0,DA,DG,DIC,DIE,DIG,DIH,DIU,DIV,DIW,DLAYGO,DQ,DR,J,K,M,N,PRCFA,PRCFASYS,Q,Q1,S,X,XL1,Y,Z
Q
;
VOUCHER ;SELECT VOUCHER NUMBER
;
Q1 R !!,"LOG DATE: TODAY//",X:DTIME G:X="^"!'$T OUT S %DT="EX",%DT(0)="-NOW" S:X="" X="TODAY" D ^%DT K %DT G:Y<0 Q1 S PRCFA("LDATE")=Y
;
Q2 R !!,"DEPOT: HINES//",X:DTIME G:X="^"!'$T OUT S PRCHDEP=$S("793HINES"[X:"4","794SOMMERVILLE"[X:"2","79ABELL"[X:"3",1:""),X=PRCHDEP G:'PRCHDEP Q2 W " ("_$S(X=4:"HINES)",X=3:"BELL)",1:"SOMMERVILLE)")
S X=PRC("SITE")_"-"_PRC("FY")_"-"_"DVCODE"_+PRCHDEP,DIC="^PRCS(410.1,",DIC(0)="Z" I '$D(^PRCS("410.1","B",X)) S DIC("DR")="1////1" D FILE^DICN
D ^DIC S Y(1)=$P(Y(0),U,2),PRCHDEP=PRCHDEP_$E("000",$L(Y(1)),3)_Y(1)_U_PRCFA("LDATE"),DIE=DIC,DA=+Y,DR="1////"_(Y(1)+1)_";2///T" D ^DIE K DIC,X,Y
W !!,"This session has been assigned Depot Voucher Number ",+PRCHDEP
Q
;
PRINT W !,"UNIT OF PRCH: ",$P($G(^PRCD(420.5,PRCFA("ISSUE"),0)),U,1)," QTY ORDERED: ",PRCHRQ1," PREVIOUSLY RECEIVED: ",PRCHRQ2,!?3,"QTY BEING RECEIVED: ",PRCHRQ,!
Q
;
EXP I PRCFA("FSC")?1"89".E,X>$P(PRCHDEP,U,2) K X Q
I PRCFA("FSC")?1"6505".E,Y<$P(PRCHDEP,U,2) K X
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHREC7 2478 printed Dec 13, 2024@02:10:14 Page 2
PRCHREC7 ;WISC/RWS-CODE SHEET GENERATOR - DEPOT TRANSACTIONS ;10-24-91/10:10
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 ;
LOG ;CREATE LOG CODE SHEETS
+1 NEW D0,I
if '$DATA(PRCHDEP)
DO VOUCHER
if 'PRCHDEP
QUIT
+2 SET PRCFA("DEL")=$PIECE(^PRC(442,PRCHPO,0),U,10)
SET PRCFA("LBN")=$PIECE(^(0),U,1)
SET PRCFA("ISSUE")=$PIECE(^(2,+PRCHRIT,0),U,3)
SET PRCFA("MULT")=$PIECE(^(0),U,12)
SET Y=$PIECE(^(0),U,13)
SET PRCFA("NSN")=$EXTRACT(Y,6,7)_$EXTRACT(Y,9,11)_$EXTRACT(Y,13,17)
SET PRCFA("FSC")=Y
+3 SET Y=$PIECE(PRCHDEP,U,2)
SET PRCFA("LDATE")=$EXTRACT(Y,4,7)_$EXTRACT(Y,2,3)
SET PRCFA("SITE")=$SELECT($EXTRACT(PRCHDEP)=2:"79A",$EXTRACT(PRCHDEP)=3:"794",1:"793")
SET PRCFA("TTLEN")=80
+4 SET PRCHLOG=""
SET PRCFA("SYS")="LOG"
SET PRCFA("TT")=$SELECT($DATA(PRCHNRQ):"431",1:"434")
SET PRCFA("REF")=$EXTRACT($PIECE($PIECE(^PRC(442,PRCHPO,0),U,1),"-",2),2,6)
SET PRCF("X")="P"
SET PRCFA("EDIT")="[PRCHL"_PRCFA("TT")_"]"
+5 if PRCHRTP
DO PRINT
DO ^PRCFSITE
if '%
GOTO OUT
DO NEWCS^PRCFAC
if '$DATA(DA)
GOTO OUT
SET $PIECE(^PRC(442,PRCHPO,2,+PRCHRIT,3,PRCHRDY,0),U,6)=DA
SET ^PRC(442,PRCHPO,2,+PRCHRIT,3,"AB",DA,PRCHRDY)=""
+6 SET X1=+PRCHRIT_"^^"_PRCHRQ_U_"^^^"_PRCFA("DEL")_"^^"_PRCFA("NSN")
SET PRCFA("LBN")=PRCFA("LBN")_"."_$PIECE(PRCHRIT,U,1)
+7 SET Z=$PIECE(PRCHDEP,U,2)_U_"^^^^^^^^"_PRCFA("MULT")_"^^"_PRCHRAM_"^^^"_PRCFA("SITE")
+8 SET ^PRCF(423,DA,300)=X1
SET ^(304)=Z
SET $PIECE(^(301),U,15)=PRCFA("REF")
SET $PIECE(^(301),U,38)=+PRCHDEP
+9 ;
VOU SET DIE="^PRCF(423,"
SET DR="[PRCH-REC7 LOG 431/434]"
DO ^DIE
DO ^PRCFACX1
+1 ;
OUT KILL %,B,D,D0,DA,DG,DIC,DIE,DIG,DIH,DIU,DIV,DIW,DLAYGO,DQ,DR,J,K,M,N,PRCFA,PRCFASYS,Q,Q1,S,X,XL1,Y,Z
+1 QUIT
+2 ;
VOUCHER ;SELECT VOUCHER NUMBER
+1 ;
Q1 READ !!,"LOG DATE: TODAY//",X:DTIME
if X="^"!'$TEST
GOTO OUT
SET %DT="EX"
SET %DT(0)="-NOW"
if X=""
SET X="TODAY"
DO ^%DT
KILL %DT
if Y<0
GOTO Q1
SET PRCFA("LDATE")=Y
+1 ;
Q2 READ !!,"DEPOT: HINES//",X:DTIME
if X="^"!'$TEST
GOTO OUT
SET PRCHDEP=$SELECT("793HINES"[X:"4","794SOMMERVILLE"[X:"2","79ABELL"[X:"3",1:"")
SET X=PRCHDEP
if 'PRCHDEP
GOTO Q2
WRITE " ("_$SELECT(X=4:"HINES)",X=3:"BELL)",1:"SOMMERVILLE)")
+1 SET X=PRC("SITE")_"-"_PRC("FY")_"-"_"DVCODE"_+PRCHDEP
SET DIC="^PRCS(410.1,"
SET DIC(0)="Z"
IF '$DATA(^PRCS("410.1","B",X))
SET DIC("DR")="1////1"
DO FILE^DICN
+2 DO ^DIC
SET Y(1)=$PIECE(Y(0),U,2)
SET PRCHDEP=PRCHDEP_$EXTRACT("000",$LENGTH(Y(1)),3)_Y(1)_U_PRCFA("LDATE")
SET DIE=DIC
SET DA=+Y
SET DR="1////"_(Y(1)+1)_";2///T"
DO ^DIE
KILL DIC,X,Y
+3 WRITE !!,"This session has been assigned Depot Voucher Number ",+PRCHDEP
+4 QUIT
+5 ;
PRINT WRITE !,"UNIT OF PRCH: ",$PIECE($GET(^PRCD(420.5,PRCFA("ISSUE"),0)),U,1)," QTY ORDERED: ",PRCHRQ1," PREVIOUSLY RECEIVED: ",PRCHRQ2,!?3,"QTY BEING RECEIVED: ",PRCHRQ,!
+1 QUIT
+2 ;
EXP IF PRCFA("FSC")?1"89".E
IF X>$PIECE(PRCHDEP,U,2)
KILL X
QUIT
+1 IF PRCFA("FSC")?1"6505".E
IF Y<$PIECE(PRCHDEP,U,2)
KILL X
+2 QUIT
