PRCFGPF ;SF-ISC/TKW,WISC/DGL-PROCESS GENERAL POST FUNDS 2237 REQUEST IN FISCAL ; [6/26/98 11:05am]
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
EN S PRCF("X")="SP" D ^PRCFSITE Q:'% S PRCFGPF=1
; ALLOW SELECTION ONLY OF GPF TRANSACTIONS WITH SUPPLY STATUS='FISCAL ACTION REQUIRED'
EN0 D:'$D(MESSAGE) ES Q:'$D(MESSAGE) S PRCFDICS=" I $O(^PRCD(442.3,""C"",+$P(^PRC(443,Y,0),U,7),0))=10" D TR^PRCHG G:'$D(DA) Q
S DIE="^PRC(443,",DR=1.5 D ^DIE K DIE,DR
S PRCFG=$S($D(^PRCD(442.3,+$P(^PRC(443,DA,0),U,7),0)):$P(^(0),U,2),1:"") D REMOVE^PRCHES11(DA) S P=+PRC("PER")
G:PRCFG=10 EN0
;IF RETURNED TO SERVICE
I PRCFG=85 D RTS G EN0
;IF APPROVED, AFFIX FISCAL SIGNATURE AND PRINT 2237 IN SUPPLY.
S MESSAGE=""
D ENCODE^PRCSC3(DA,DUZ,.MESSAGE)
I MESSAGE<0 W !,"Electronic Signature failure: ",MESSAGE G Q
S PRCHQ=$P(^PRCS(410,DA,0),U,4),D0=DA,PRCHQ=$S(PRCHQ=5:"DQ^PRCPRIB0",1:"QUE^PRCSP12"),PRCHQ("DEST")="S" D ^PRCHQUE G EN0
ES G Q:'$D(PRC("PER"))!('$D(PRC("SITE")))
S MESSAGE=""
D ESIG^PRCUESIG(DUZ,.MESSAGE)
G Q:MESSAGE'=1
Q
Q K %,DA,DIC,DIE,DR,MESSAGE,P,PRC,PRCF,PRCFDICS,PRCFGPF,PRCFG,PRCHNM,PRCHQ Q
RTS ;UPDATE COMMITTED CP BALANCE, REMOVE CP OFFICIAL SIGNATURE, ALLOW FISCAL TO ENTER COMMENTS, UPDATE QTY.DUE-IN IF SERVICE RUNNING INVENTORY, SEND BULLETIN
S X=+$P($G(^PRCS(410,DA,4)),"^",8)
D TRANK^PRCSES,REMOVE^PRCSC1(DA),REMOVE^PRCSC3(DA)
S $P(^PRCS(410,DA,10),U,4)=$P(^PRC(443,DA,0),U,7),DIE="^PRCS(410,",DR=61
D ^DIE K DIE D EN3^PRCPWI
S XMB="PRCH GPF"
S XMB(1)=$P(^PRCS(410,DA,0),U,4),XMB(1)=$S($P(^PRCS(410.5,XMB(1),0),U)'["1358":"2237",1:"2237")
S XMB(2)="FISCAL",XMB(3)=$P(^PRCS(410,DA,0),U,1)
S XMB(4)=$P(^PRCS(410,DA,4),U,1),XMB(5)=$P(XMB(3),"-",4)
K ^TMP("PRCFGPF",$J)
S XMTEXT="^TMP(""PRCFGPF"",$J,",XX=0,X=1,^TMP("PRCFGPF",$J,X)=" Purpose: "
F S XX=$O(^PRCS(410,DA,8,XX)) Q:XX="" S X=X+1,^TMP("PRCFGPF",$J,X)=$G(^PRCS(410,DA,8,XX,0))
S XX=0,X=X+1,^TMP("PRCFGPF",$J,X)=""
S X=X+1,^TMP("PRCFGPF",$J,X)=" Reason for return: "
F S XX=$O(^PRCS(410,DA,13,XX)) Q:XX="" S X=X+1,^TMP("PRCFGPF",$J,X)=$G(^PRCS(410,DA,13,XX,0))
S X="" K XMY
F I=0:0 S X=$O(^PRC(420,PRC("SITE"),1,XMB(5),1,X)) Q:X="" D
. S A=$G(^(X,0))
. I $P(A,U,3)="Y" S XMY(X)=""
. Q
D ^XMB K ^TMP("PRCFGPF",$J)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCFGPF 2318 printed Dec 13, 2024@02:04:06 Page 2
PRCFGPF ;SF-ISC/TKW,WISC/DGL-PROCESS GENERAL POST FUNDS 2237 REQUEST IN FISCAL ; [6/26/98 11:05am]
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
EN SET PRCF("X")="SP"
DO ^PRCFSITE
if '%
QUIT
SET PRCFGPF=1
+1 ; ALLOW SELECTION ONLY OF GPF TRANSACTIONS WITH SUPPLY STATUS='FISCAL ACTION REQUIRED'
EN0 if '$DATA(MESSAGE)
DO ES
if '$DATA(MESSAGE)
QUIT
SET PRCFDICS=" I $O(^PRCD(442.3,""C"",+$P(^PRC(443,Y,0),U,7),0))=10"
DO TR^PRCHG
if '$DATA(DA)
GOTO Q
+1 SET DIE="^PRC(443,"
SET DR=1.5
DO ^DIE
KILL DIE,DR
+2 SET PRCFG=$SELECT($DATA(^PRCD(442.3,+$PIECE(^PRC(443,DA,0),U,7),0)):$PIECE(^(0),U,2),1:"")
DO REMOVE^PRCHES11(DA)
SET P=+PRC("PER")
+3 if PRCFG=10
GOTO EN0
+4 ;IF RETURNED TO SERVICE
+5 IF PRCFG=85
DO RTS
GOTO EN0
+6 ;IF APPROVED, AFFIX FISCAL SIGNATURE AND PRINT 2237 IN SUPPLY.
+7 SET MESSAGE=""
+8 DO ENCODE^PRCSC3(DA,DUZ,.MESSAGE)
+9 IF MESSAGE<0
WRITE !,"Electronic Signature failure: ",MESSAGE
GOTO Q
+10 SET PRCHQ=$PIECE(^PRCS(410,DA,0),U,4)
SET D0=DA
SET PRCHQ=$SELECT(PRCHQ=5:"DQ^PRCPRIB0",1:"QUE^PRCSP12")
SET PRCHQ("DEST")="S"
DO ^PRCHQUE
GOTO EN0
ES if '$DATA(PRC("PER"))!('$DATA(PRC("SITE")))
GOTO Q
+1 SET MESSAGE=""
+2 DO ESIG^PRCUESIG(DUZ,.MESSAGE)
+3 if MESSAGE'=1
GOTO Q
+4 QUIT
Q KILL %,DA,DIC,DIE,DR,MESSAGE,P,PRC,PRCF,PRCFDICS,PRCFGPF,PRCFG,PRCHNM,PRCHQ
QUIT
RTS ;UPDATE COMMITTED CP BALANCE, REMOVE CP OFFICIAL SIGNATURE, ALLOW FISCAL TO ENTER COMMENTS, UPDATE QTY.DUE-IN IF SERVICE RUNNING INVENTORY, SEND BULLETIN
+1 SET X=+$PIECE($GET(^PRCS(410,DA,4)),"^",8)
+2 DO TRANK^PRCSES
DO REMOVE^PRCSC1(DA)
DO REMOVE^PRCSC3(DA)
+3 SET $PIECE(^PRCS(410,DA,10),U,4)=$PIECE(^PRC(443,DA,0),U,7)
SET DIE="^PRCS(410,"
SET DR=61
+4 DO ^DIE
KILL DIE
DO EN3^PRCPWI
+5 SET XMB="PRCH GPF"
+6 SET XMB(1)=$PIECE(^PRCS(410,DA,0),U,4)
SET XMB(1)=$SELECT($PIECE(^PRCS(410.5,XMB(1),0),U)'["1358":"2237",1:"2237")
+7 SET XMB(2)="FISCAL"
SET XMB(3)=$PIECE(^PRCS(410,DA,0),U,1)
+8 SET XMB(4)=$PIECE(^PRCS(410,DA,4),U,1)
SET XMB(5)=$PIECE(XMB(3),"-",4)
+9 KILL ^TMP("PRCFGPF",$JOB)
+10 SET XMTEXT="^TMP(""PRCFGPF"",$J,"
SET XX=0
SET X=1
SET ^TMP("PRCFGPF",$JOB,X)=" Purpose: "
+11 FOR
SET XX=$ORDER(^PRCS(410,DA,8,XX))
if XX=""
QUIT
SET X=X+1
SET ^TMP("PRCFGPF",$JOB,X)=$GET(^PRCS(410,DA,8,XX,0))
+12 SET XX=0
SET X=X+1
SET ^TMP("PRCFGPF",$JOB,X)=""
+13 SET X=X+1
SET ^TMP("PRCFGPF",$JOB,X)=" Reason for return: "
+14 FOR
SET XX=$ORDER(^PRCS(410,DA,13,XX))
if XX=""
QUIT
SET X=X+1
SET ^TMP("PRCFGPF",$JOB,X)=$GET(^PRCS(410,DA,13,XX,0))
+15 SET X=""
KILL XMY
+16 FOR I=0:0
SET X=$ORDER(^PRC(420,PRC("SITE"),1,XMB(5),1,X))
if X=""
QUIT
Begin DoDot:1
+17 SET A=$GET(^(X,0))
+18 IF $PIECE(A,U,3)="Y"
SET XMY(X)=""
+19 QUIT
End DoDot:1
+20 DO ^XMB
KILL ^TMP("PRCFGPF",$JOB)
+21 QUIT
