PRCH1C ;WISC/PLT-FMS documents Inquiry/Regenerate Rejected ET ; 08/16/95 1:45 PM
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
QUIT ;invalid entry
;
EN ;FMS doc inquiry
D EN^PRC0E("ET:Expenditure Transfer^FMS ET Document ID: ","D INQ^PRCH1C")
QUIT
INQ ;dispaly dcocument data
N A,B,PRCFC,PRCTX,PRCRI,PRCIDL
S PRCTX=$P(X,"^",2),PRCRI(2100.1)=$P(X,"^",4)
S PRCFC=$TR($G(GECSDATA(2100.1,PRCRI(2100.1),26,"E")),"/","^")
S PRCRI(440.6)=+PRCFC,PRCRI(442)=$P(PRCFC,"^",2),PRCDI=$P(PRCFC,"^",3),PRCBOC=$P(PRCFC,"^",4)
S PRCIDL=$P(^PRCH(440.6,PRCRI(440.6),0),"^")
S PRCB(1)=$$DDA4406^PRCH0A(PRCRI(440.6)),PRCB(2)=$$DDA442^PRCH0A(PRCRI(442))
S $P(PRCB(2),"^",21)=PRCBOC
S $P(PRCB(2),"^",33)=$P(PRCB(1),"^",33)
S $P(PRCB(1),"^",40)=$E(PRCIDL,13,15),$P(PRCB(2),"^",40)=$E(PRCIDL,13,15)+500
F A=1,2 S $P(PRCB(A),"^",34)=$E("DI",A)
I PRCDI=2 F A=1,2 S $P(PRCB(A),"^",34)=$E("ID",A)
I $P(PRCB(1),"^",33)<0 S A=$P(PRCB(1),"^",34),$P(PRCB(1),"^",34)=$P(PRCB(2),"^",34),$P(PRCB(2),"^",34)=A F A=1,2 S $P(PRCB(A),"^",33)=$E($P(PRCB(A),"^",33),2,999)
I $P(PRCB(1),"^",34)="I" S A=PRCB(1),PRCB(1)=PRCB(2),PRCB(2)=A
D:PRCFC]""
. D @("INQ"_PRCTX)
QUIT
;
INQET ;display ET
W !,"Description",?25,"Line #",$P(PRCB(1),"^",40),?45,"Line #",$P(PRCB(2),"^",40)
F B=13:1:21,23 W !,$J($P("BBFY^BBEY^FUND^STATION^SUB STATION^COST CENTER^SUB COST CENTER^FCP/PRJ^BOC^^JOB NO","^",B-12),15),": ",?25,$P(PRCB(1),"^",B),?45,$P(PRCB(2),"^",B)
F B=33,34 W !,$J($P("LINE AMOUNT^LINE ACTION","^",B-32),15),": ",?25,$P(PRCB(1),"^",B),?45,$P(PRCB(2),"^",B)
W !,"PURCHASE CARD ORDER: ",$P(^PRC(442,PRCRI(442),0),"^")
QUIT
;
;
;PRCA data ^1=txn type;txn type...,^2=select document text, ^3=status
EN1 ;rejected FMS document process
N PRC,PRCA,PRCRI,PRCID,PRCTX,PRCF,PRCFC,PRCLACT,PRCDI,PRCBOC
D EN^PRC0E("ET:Expenditure Transfer^FMS Rejected Budget Document ID: ^~E~R~T~~","D INQ^PRCH1C,EN2^PRCH1C")
QUIT
;
EN2 ;File process rejected fms doc
N PRCRI,PRCTX,PRCID,PRCFC,PRCFDT,PRCFAC,PRCAP,PRCFP
S PRCTX=$P(X,"^",2),PRCID=$P(X,"^",3),PRCRI(2100.1)=$P(X,"^",4)
D EN^DDIOL(" ")
D DATA^GECSSGET(PRCID,0)
S PRCFC=GECSDATA(2100.1,PRCRI(2100.1),26,"E") K GECSDATA
S PRCRI(440.6)=+PRCFC,PRCRI(442)=$P(PRCFC,"/",2),PRCDI=$P(PRCFC,"/",3),PRCBOC=$P(PRCFC,"/",4)
S PRCRI(420.1)=+$P(^PRC(442,PRCRI(442),0),"^",5)
;lookup boc
Q12 S A="420.1;^PRCD(420.1,;"_PRCRI(420.1)_";1~420.11;^PRCD(420.1,"_PRCRI(420.1)_",1,"
;S X("S")="I $P(^(0),U)>0"
D LOOKUP^PRC0B(.X,.Y,A,"AEOQS","Select BOC: ")
I Y<0!(X="") QUIT
S PRCRI(420.2)=+Y
S PRCBOC=$P(^PRCD(420.2,PRCRI(420.2),0)," ")
Q13 K X,Y D YN^PRC0A(.X,.Y,"Ready To Regenerate ET-FMS Document","","NO")
I X["^"!'Y QUIT
I Y=1 D
. D:PRCFC]"" @PRCTX,EN^DDIOL("<Regenerated>")
QUIT
;
EXIT K X,Y
QUIT
;
ET S PRCFC=PRCRI(440.6)_"^"_PRCRI(442)_"^"_PRCDI_"^"_PRCBOC
D ET^PRCH8A(.X,PRCFC,PRCRI(2100.1)_"^"_$P(PRCID,"-",2,999))
QUIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCH1C 2976 printed Nov 22, 2024@17:15:13 Page 2
PRCH1C ;WISC/PLT-FMS documents Inquiry/Regenerate Rejected ET ; 08/16/95 1:45 PM
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 ;invalid entry
QUIT
+3 ;
EN ;FMS doc inquiry
+1 DO EN^PRC0E("ET:Expenditure Transfer^FMS ET Document ID: ","D INQ^PRCH1C")
+2 QUIT
INQ ;dispaly dcocument data
+1 NEW A,B,PRCFC,PRCTX,PRCRI,PRCIDL
+2 SET PRCTX=$PIECE(X,"^",2)
SET PRCRI(2100.1)=$PIECE(X,"^",4)
+3 SET PRCFC=$TRANSLATE($GET(GECSDATA(2100.1,PRCRI(2100.1),26,"E")),"/","^")
+4 SET PRCRI(440.6)=+PRCFC
SET PRCRI(442)=$PIECE(PRCFC,"^",2)
SET PRCDI=$PIECE(PRCFC,"^",3)
SET PRCBOC=$PIECE(PRCFC,"^",4)
+5 SET PRCIDL=$PIECE(^PRCH(440.6,PRCRI(440.6),0),"^")
+6 SET PRCB(1)=$$DDA4406^PRCH0A(PRCRI(440.6))
SET PRCB(2)=$$DDA442^PRCH0A(PRCRI(442))
+7 SET $PIECE(PRCB(2),"^",21)=PRCBOC
+8 SET $PIECE(PRCB(2),"^",33)=$PIECE(PRCB(1),"^",33)
+9 SET $PIECE(PRCB(1),"^",40)=$EXTRACT(PRCIDL,13,15)
SET $PIECE(PRCB(2),"^",40)=$EXTRACT(PRCIDL,13,15)+500
+10 FOR A=1,2
SET $PIECE(PRCB(A),"^",34)=$EXTRACT("DI",A)
+11 IF PRCDI=2
FOR A=1,2
SET $PIECE(PRCB(A),"^",34)=$EXTRACT("ID",A)
+12 IF $PIECE(PRCB(1),"^",33)<0
SET A=$PIECE(PRCB(1),"^",34)
SET $PIECE(PRCB(1),"^",34)=$PIECE(PRCB(2),"^",34)
SET $PIECE(PRCB(2),"^",34)=A
FOR A=1,2
SET $PIECE(PRCB(A),"^",33)=$EXTRACT($PIECE(PRCB(A),"^",33),2,999)
+13 IF $PIECE(PRCB(1),"^",34)="I"
SET A=PRCB(1)
SET PRCB(1)=PRCB(2)
SET PRCB(2)=A
+14 if PRCFC]""
Begin DoDot:1
+15 DO @("INQ"_PRCTX)
End DoDot:1
+16 QUIT
+17 ;
INQET ;display ET
+1 WRITE !,"Description",?25,"Line #",$PIECE(PRCB(1),"^",40),?45,"Line #",$PIECE(PRCB(2),"^",40)
+2 FOR B=13:1:21,23
WRITE !,$JUSTIFY($PIECE("BBFY^BBEY^FUND^STATION^SUB STATION^COST CENTER^SUB COST CENTER^FCP/PRJ^BOC^^JOB NO","^",B-12),15),": ",?25,$PIECE(PRCB(1),"^",B),?45,$PIECE(PRCB(2),"^",B)
+3 FOR B=33,34
WRITE !,$JUSTIFY($PIECE("LINE AMOUNT^LINE ACTION","^",B-32),15),": ",?25,$PIECE(PRCB(1),"^",B),?45,$PIECE(PRCB(2),"^",B)
+4 WRITE !,"PURCHASE CARD ORDER: ",$PIECE(^PRC(442,PRCRI(442),0),"^")
+5 QUIT
+6 ;
+7 ;
+8 ;PRCA data ^1=txn type;txn type...,^2=select document text, ^3=status
EN1 ;rejected FMS document process
+1 NEW PRC,PRCA,PRCRI,PRCID,PRCTX,PRCF,PRCFC,PRCLACT,PRCDI,PRCBOC
+2 DO EN^PRC0E("ET:Expenditure Transfer^FMS Rejected Budget Document ID: ^~E~R~T~~","D INQ^PRCH1C,EN2^PRCH1C")
+3 QUIT
+4 ;
EN2 ;File process rejected fms doc
+1 NEW PRCRI,PRCTX,PRCID,PRCFC,PRCFDT,PRCFAC,PRCAP,PRCFP
+2 SET PRCTX=$PIECE(X,"^",2)
SET PRCID=$PIECE(X,"^",3)
SET PRCRI(2100.1)=$PIECE(X,"^",4)
+3 DO EN^DDIOL(" ")
+4 DO DATA^GECSSGET(PRCID,0)
+5 SET PRCFC=GECSDATA(2100.1,PRCRI(2100.1),26,"E")
KILL GECSDATA
+6 SET PRCRI(440.6)=+PRCFC
SET PRCRI(442)=$PIECE(PRCFC,"/",2)
SET PRCDI=$PIECE(PRCFC,"/",3)
SET PRCBOC=$PIECE(PRCFC,"/",4)
+7 SET PRCRI(420.1)=+$PIECE(^PRC(442,PRCRI(442),0),"^",5)
+8 ;lookup boc
Q12 SET A="420.1;^PRCD(420.1,;"_PRCRI(420.1)_";1~420.11;^PRCD(420.1,"_PRCRI(420.1)_",1,"
+1 ;S X("S")="I $P(^(0),U)>0"
+2 DO LOOKUP^PRC0B(.X,.Y,A,"AEOQS","Select BOC: ")
+3 IF Y<0!(X="")
QUIT
+4 SET PRCRI(420.2)=+Y
+5 SET PRCBOC=$PIECE(^PRCD(420.2,PRCRI(420.2),0)," ")
Q13 KILL X,Y
DO YN^PRC0A(.X,.Y,"Ready To Regenerate ET-FMS Document","","NO")
+1 IF X["^"!'Y
QUIT
+2 IF Y=1
Begin DoDot:1
+3 if PRCFC]""
DO @PRCTX
DO EN^DDIOL("<Regenerated>")
End DoDot:1
+4 QUIT
+5 ;
EXIT KILL X,Y
+1 QUIT
+2 ;
ET SET PRCFC=PRCRI(440.6)_"^"_PRCRI(442)_"^"_PRCDI_"^"_PRCBOC
+1 DO ET^PRCH8A(.X,PRCFC,PRCRI(2100.1)_"^"_$PIECE(PRCID,"-",2,999))
+2 QUIT
