PRCEFIS1 ;WISC/CTB/CLH-RETURN 1358 TO SERVICE ; 08/25/93 9:53 AM
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
N PRC,PRCFA,PRCF,DIR,DIE,DIC,DA,DR,X,Y,%,AMT,MSG,PRCFAT
S PRCF("X")="AB" D ^PRCFSITE Q:'% S TT="OA" D LOOKUP^PRCEOB Q:Y<0 S (DA,TRDA)=+Y,TRDA(0)=Y(0)
W ! S DIR("A")="Is this the correct transaction",DIR("B")="YES",DIR(0)="Y"
S DIR("?",1)="Enter 'YES' or'Y' or 'RETURN' if it correct."
S DIR("?")="Enter 'NO' or 'N' or '^' to exit this option."
D ^DIR K DIR Q:'Y
W ! S DIR("A",1)="This action will remove the electronic signature of the approving official"
S DIR("A",2)="and will allow editing or cancellation of the request.",DIR("A",3)=" "
S DIR(0)="Y",DIR("A")="OK to continue",DIR("B")="YES"
S DIR("?",1)="Enter 'RETURN' or 'YES' or 'Y' to return this request to the service."
S DIR("?")="Enter 'NO' or 'N' or '^' to exit this option."
D ^DIR K DIR Q:Y=0!(Y["^")
S DIE="^PRCS(410,",DR="61" D ^DIE I $D(Y) S X="No action taken*" D MSG^PRCFQ G OUT
;S AMT=$P(^PRCS(410,DA,4),"^",8),X=AMT D TRANK^PRCSES S $P(^PRCS(410,DA,7),"^",5,7)="^^",$P(^PRCS(410,DA,10),"^",4)=$O(^PRCD(442.3,"AC",9,0))
S AMT=$P(^PRCS(410,DA,4),"^",8),X=AMT D TRANK^PRCSES S $P(^PRCS(410,DA,7),"^",5)="" D REMOVE^PRCSC1(DA) S $P(^PRCS(410,DA,10),"^",4)=$O(^PRCD(442.3,"AC",9,0))
D EN,OUT G V
EN ;SENDS RETURNING TRANSACTION MESSAGE.
S PRCFAT=$P(TRDA(0),"^",4),PRCFAT=$S($P(^PRCS(410.5,PRCFAT,0),"^")'["1358":"2237",1:"1358")
I $S('$D(PRCFA("WHO")):1,PRCFA("WHO")="":1,1:0) S PRCFA("WHO")=1
S PRCFA("WHO")=$P("FISCAL^PURCHASING AND CONTRACTING^PROPERTY MANAGEMENT","^",PRCFA("WHO"))
K MSG S MSG(1,0)="The following "_PRCFAT_" transaction was not processed ",MSG(2,0)="by "_PRCFA("WHO")_" and is returned without action",MSG(3,0)="for the reason(s) indicated.",MSG(4,0)=" "
S MSG(5,0)="Transaction Number: "_$P(TRDA(0),"^")_" Amount: $ "_$J($P(^PRCS(410,DA,4),"^",8),0,2),MSG(6,0)=" ",MSG(7,0)=$S(PRCFAT="2237":"Justification: ",1:"Purpose: ")
I $D(^PRCS(410,DA,8,0)) S N=0 F MSG=7:1 S N=$O(^PRCS(410,DA,8,N)) Q:'N I $D(^(N,0)),^(0)]"" S MSG(MSG,0)=$S($D(MSG(MSG,0)):MSG(MSG,0)_^(0),1:^(0))
S (MSG,N)=3 F I=1:1 S N=$O(MSG(N)) Q:'N S MSG=N I $D(MSG(MSG,0)),$D(PRCFASK) W !,MSG(MSG,0)
S:$D(MSG(MSG,0)) MSG=MSG+1 S MSG(MSG,0)=" "
S X="Reason for Return: "_$S($D(^PRCS(410,DA,13,0)):"",1:"Not Specified")
K ^UTILITY($J,"W") S DIWL=0,DIWR=79,DIWF="" D DIWP^PRCUTL($G(DA)) F PRCFI=0:0 S PRCFI=$O(^PRCS(410,DA,13,PRCFI)) Q:'PRCFI I $D(^(PRCFI,0)) S X=^(0) D DIWP^PRCUTL($G(DA))
S N=0,X=MSG+1 F MSG=X:1 S N=$O(^UTILITY($J,"W",0,N)) Q:'N I $D(^(N,0)),^(0)]"" S MSG(MSG,0)=^(0)
K ^UTILITY($J,"W") S XMSUB=PRCFAT_" TRANSACTION RETURN NOTIFICATION" D MSG
I $D(PRCFASK) K PRCFASK S X="Transaction returned, bulletin transmitted.*" D MSG^PRCFQ Q
Q
OUT ;EXIT LINE FOR ROUTINE
D DIWKILL^PRCFQ
K %H,%I,AMT,C,D,D0,DA,DI,DIC,DIE,DIWF,DIWL,DIWR,DQ,DR,DWLW,ER,H,I,J,K,M,MSG,N,PATNUM,PRCF,PRCFA,TRDA,X,X1,X2,XMDUZ,XMSUB,XMTEXT,XMY,Y,PRCFASK,PRCFA("WHO"),PRCFAT Q
BULLET ;FIRE BULLETIN FOR OBLIGATION
K ^UTILITY($J),MSG S DIWL=0,DIWR=79,DIWF=""
S MSG(1,0)="A 1358 transaction with number "_$P(TRNODE(0),"^")_" has just been obligated by Fiscal Service. Transaction information is as follows:"
S MSG(2,0)=" ",MSG(3,0)="Transaction Number: "_$P(TRNODE(0),"^")_" Amount: $"_$J(AMT,0,2),MSG(4,0)=" ",MSG(5,0)=" Obligation Number: "_PATNUM,MSG(6,0)=" ",MSG(7,0)="Purpose: "
S N=0 F I=7:1 S N=$O(^PRCS(410,DA,8,N)) Q:'N I $D(^(N,0)),^(0)]"" S MSG(I,0)=$S($D(MSG(I,0)):MSG(I,0)_^(0),1:^(0))
S MSG(I,0)=" ",MSG(I+1,0)="Please note the assigned obligation number for future reference.",XMSUB="1358 OBLIGATION NOTIFICATION"
D MSG W !!,"...Control Point has been notified of this transaction...",!
Q
MSG ;SET VARIABLES AND CALL XMD
S XMDUZ=DUZ,X=$S($D(^PRCS(410,DA,7)):^(7),1:"") F I=1,3 I $P(X,"^",I)]"" S X1=$P(X,"^",I) I X1]"" S XMY(X1)=""
S PRC("CP")=$P(^PRCS(410,DA,0),"-",4) D NAMES^PRCBBUL S XMTEXT="MSG(" D WAIT^PRCFYN,^XMD Q
RETURN ;ENTRY POINT FOR NON 1358 TRANSACTION RETURNS
;REQUIRES PRCFA("TRDA")=INTERNAL NUMBER IN FILE 410, PRCFA("WHO")=SERVICE RETURNING TRANSACTION. 1=FISCAL, 2=P&C, 3=PPM IF MISSING WILL AUTOMATICALLY MAKE IT FISCAL.
I '$D(PRCFA("TRDA")) Q
S (TRDA,DA)=PRCFA("TRDA"),TRDA(0)=^PRCS(410,TRDA,0),PRC("SITE")=+TRDA(0)
D EN,DIWKILL^PRCFQ K DN,MSG,PRCFAT,PRCFA("WHO"),TRDA,DA,XMTEXT,XMSUB,XMDUZ,XMY,J,K,N,PRCFI,X,X1,X2
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCEFIS1 4484 printed Jan 18, 2025@03:02:37 Page 2
PRCEFIS1 ;WISC/CTB/CLH-RETURN 1358 TO SERVICE ; 08/25/93 9:53 AM
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 NEW PRC,PRCFA,PRCF,DIR,DIE,DIC,DA,DR,X,Y,%,AMT,MSG,PRCFAT
+3 SET PRCF("X")="AB"
DO ^PRCFSITE
if '%
QUIT
SET TT="OA"
DO LOOKUP^PRCEOB
if Y<0
QUIT
SET (DA,TRDA)=+Y
SET TRDA(0)=Y(0)
+4 WRITE !
SET DIR("A")="Is this the correct transaction"
SET DIR("B")="YES"
SET DIR(0)="Y"
+5 SET DIR("?",1)="Enter 'YES' or'Y' or 'RETURN' if it correct."
+6 SET DIR("?")="Enter 'NO' or 'N' or '^' to exit this option."
+7 DO ^DIR
KILL DIR
if 'Y
QUIT
+8 WRITE !
SET DIR("A",1)="This action will remove the electronic signature of the approving official"
+9 SET DIR("A",2)="and will allow editing or cancellation of the request."
SET DIR("A",3)=" "
+10 SET DIR(0)="Y"
SET DIR("A")="OK to continue"
SET DIR("B")="YES"
+11 SET DIR("?",1)="Enter 'RETURN' or 'YES' or 'Y' to return this request to the service."
+12 SET DIR("?")="Enter 'NO' or 'N' or '^' to exit this option."
+13 DO ^DIR
KILL DIR
if Y=0!(Y["^")
QUIT
+14 SET DIE="^PRCS(410,"
SET DR="61"
DO ^DIE
IF $DATA(Y)
SET X="No action taken*"
DO MSG^PRCFQ
GOTO OUT
+15 ;S AMT=$P(^PRCS(410,DA,4),"^",8),X=AMT D TRANK^PRCSES S $P(^PRCS(410,DA,7),"^",5,7)="^^",$P(^PRCS(410,DA,10),"^",4)=$O(^PRCD(442.3,"AC",9,0))
+16 SET AMT=$PIECE(^PRCS(410,DA,4),"^",8)
SET X=AMT
DO TRANK^PRCSES
SET $PIECE(^PRCS(410,DA,7),"^",5)=""
DO REMOVE^PRCSC1(DA)
SET $PIECE(^PRCS(410,DA,10),"^",4)=$ORDER(^PRCD(442.3,"AC",9,0))
+17 DO EN
DO OUT
GOTO V
EN ;SENDS RETURNING TRANSACTION MESSAGE.
+1 SET PRCFAT=$PIECE(TRDA(0),"^",4)
SET PRCFAT=$SELECT($PIECE(^PRCS(410.5,PRCFAT,0),"^")'["1358":"2237",1:"1358")
+2 IF $SELECT('$DATA(PRCFA("WHO")):1,PRCFA("WHO")="":1,1:0)
SET PRCFA("WHO")=1
+3 SET PRCFA("WHO")=$PIECE("FISCAL^PURCHASING AND CONTRACTING^PROPERTY MANAGEMENT","^",PRCFA("WHO"))
+4 KILL MSG
SET MSG(1,0)="The following "_PRCFAT_" transaction was not processed "
SET MSG(2,0)="by "_PRCFA("WHO")_" and is returned without action"
SET MSG(3,0)="for the reason(s) indicated."
SET MSG(4,0)=" "
+5 SET MSG(5,0)="Transaction Number: "_$PIECE(TRDA(0),"^")_" Amount: $ "_$JUSTIFY($PIECE(^PRCS(410,DA,4),"^",8),0,2)
SET MSG(6,0)=" "
SET MSG(7,0)=$SELECT(PRCFAT="2237":"Justification: ",1:"Purpose: ")
+6 IF $DATA(^PRCS(410,DA,8,0))
SET N=0
FOR MSG=7:1
SET N=$ORDER(^PRCS(410,DA,8,N))
if 'N
QUIT
IF $DATA(^(N,0))
IF ^(0)]""
SET MSG(MSG,0)=$SELECT($DATA(MSG(MSG,0)):MSG(MSG,0)_^(0),1:^(0))
+7 SET (MSG,N)=3
FOR I=1:1
SET N=$ORDER(MSG(N))
if 'N
QUIT
SET MSG=N
IF $DATA(MSG(MSG,0))
IF $DATA(PRCFASK)
WRITE !,MSG(MSG,0)
+8 if $DATA(MSG(MSG,0))
SET MSG=MSG+1
SET MSG(MSG,0)=" "
+9 SET X="Reason for Return: "_$SELECT($DATA(^PRCS(410,DA,13,0)):"",1:"Not Specified")
+10 KILL ^UTILITY($JOB,"W")
SET DIWL=0
SET DIWR=79
SET DIWF=""
DO DIWP^PRCUTL($GET(DA))
FOR PRCFI=0:0
SET PRCFI=$ORDER(^PRCS(410,DA,13,PRCFI))
if 'PRCFI
QUIT
IF $DATA(^(PRCFI,0))
SET X=^(0)
DO DIWP^PRCUTL($GET(DA))
+11 SET N=0
SET X=MSG+1
FOR MSG=X:1
SET N=$ORDER(^UTILITY($JOB,"W",0,N))
if 'N
QUIT
IF $DATA(^(N,0))
IF ^(0)]""
SET MSG(MSG,0)=^(0)
+12 KILL ^UTILITY($JOB,"W")
SET XMSUB=PRCFAT_" TRANSACTION RETURN NOTIFICATION"
DO MSG
+13 IF $DATA(PRCFASK)
KILL PRCFASK
SET X="Transaction returned, bulletin transmitted.*"
DO MSG^PRCFQ
QUIT
+14 QUIT
OUT ;EXIT LINE FOR ROUTINE
+1 DO DIWKILL^PRCFQ
+2 KILL %H,%I,AMT,C,D,D0,DA,DI,DIC,DIE,DIWF,DIWL,DIWR,DQ,DR,DWLW,ER,H,I,J,K,M,MSG,N,PATNUM,PRCF,PRCFA,TRDA,X,X1,X2,XMDUZ,XMSUB,XMTEXT,XMY,Y,PRCFASK,PRCFA("WHO"),PRCFAT
QUIT
BULLET ;FIRE BULLETIN FOR OBLIGATION
+1 KILL ^UTILITY($JOB),MSG
SET DIWL=0
SET DIWR=79
SET DIWF=""
+2 SET MSG(1,0)="A 1358 transaction with number "_$PIECE(TRNODE(0),"^")_" has just been obligated by Fiscal Service. Transaction information is as follows:"
+3 SET MSG(2,0)=" "
SET MSG(3,0)="Transaction Number: "_$PIECE(TRNODE(0),"^")_" Amount: $"_$JUSTIFY(AMT,0,2)
SET MSG(4,0)=" "
SET MSG(5,0)=" Obligation Number: "_PATNUM
SET MSG(6,0)=" "
SET MSG(7,0)="Purpose: "
+4 SET N=0
FOR I=7:1
SET N=$ORDER(^PRCS(410,DA,8,N))
if 'N
QUIT
IF $DATA(^(N,0))
IF ^(0)]""
SET MSG(I,0)=$SELECT($DATA(MSG(I,0)):MSG(I,0)_^(0),1:^(0))
+5 SET MSG(I,0)=" "
SET MSG(I+1,0)="Please note the assigned obligation number for future reference."
SET XMSUB="1358 OBLIGATION NOTIFICATION"
+6 DO MSG
WRITE !!,"...Control Point has been notified of this transaction...",!
+7 QUIT
MSG ;SET VARIABLES AND CALL XMD
+1 SET XMDUZ=DUZ
SET X=$SELECT($DATA(^PRCS(410,DA,7)):^(7),1:"")
FOR I=1,3
IF $PIECE(X,"^",I)]""
SET X1=$PIECE(X,"^",I)
IF X1]""
SET XMY(X1)=""
+2 SET PRC("CP")=$PIECE(^PRCS(410,DA,0),"-",4)
DO NAMES^PRCBBUL
SET XMTEXT="MSG("
DO WAIT^PRCFYN
DO ^XMD
QUIT
RETURN ;ENTRY POINT FOR NON 1358 TRANSACTION RETURNS
+1 ;REQUIRES PRCFA("TRDA")=INTERNAL NUMBER IN FILE 410, PRCFA("WHO")=SERVICE RETURNING TRANSACTION. 1=FISCAL, 2=P&C, 3=PPM IF MISSING WILL AUTOMATICALLY MAKE IT FISCAL.
+2 IF '$DATA(PRCFA("TRDA"))
QUIT
+3 SET (TRDA,DA)=PRCFA("TRDA")
SET TRDA(0)=^PRCS(410,TRDA,0)
SET PRC("SITE")=+TRDA(0)
+4 DO EN
DO DIWKILL^PRCFQ
KILL DN,MSG,PRCFAT,PRCFA("WHO"),TRDA,DA,XMTEXT,XMSUB,XMDUZ,XMY,J,K,N,PRCFI,X,X1,X2
+5 QUIT
