PRCFA8 ;WISC/CTB-PROCESS RECEIVING REPORTS ;2/2/96 13:30
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
EN8 ;PROCESSING OF RECEIVING REPORT
S (PRCFA("SYS"),PRCFASYS)="FMS",PRCF("X")="AS"
D ^PRCFSITE G:'% OUT K DIC("A")
S D="C",DIC("S")="I +$P(^(0),U,1)=PRC(""SITE""),$D(^(7)),+^(7)>0 S FSO=$P(^PRCD(442.3,+^(7),0),U,3) I FSO>29&(FSO<40)!(FSO=26!(FSO=41)&$$ONE2PROC^PRCFA8) I '$P($G(^PRC(442,+Y,24)),U)"
S DIC("A")="Select Purchase Order Number: ",DIC=442,DIC(0)="AEQZ"
D IX^DIC K DIC("S"),DIC("A"),FSO G:+Y<0 OUT
S PO(0)=Y(0),(D0,PRCFA("PODA"))=+Y,PO=Y
S %A="Do want to review the Purchase Order and Receiving Report"
I $P($G(^PRC(442,D0,11,0)),U,4)>1 S %A=%A_"s"
S %B="",%=2 D ^PRCFYN G OUT:%<0 I %=1 D ^PRCHDP1
PPT N FED,PPT,I S PPT="",(FED,I)=0
N P7 S P7=$P($G(^PRC(442,PRCFA("PODA"),1)),U,7)
I P7]"","13578"[P7 S FED=2
;I 'FED N PPR F S I=$O(^PRC(442,PRCFA("PODA"),5,I)) Q:+I'=I S PPR=$G(^(I,0)) D
;. Q:PPR="" I $P(PPR,U,1)="NET",$P(PPR,U,5)]"" S PPT=$P(PPR,U,5)
;. I PPT="" S PPT=$P(PPR,U,5)
;. Q
S PPT=$P($G(^PRC(442,PRCFA("PODA"),12)),U,15)
I 'FED,PPT="" D I $D(DTOUT)!$D(DUOUT)!$D(Y) G OUT
. W !!,"This P.O. does not have PROMPT PAYMENT TYPE information.",!,"PLease enter the information now."
. S DIE="^PRC(442,",DA=PRCFA("PODA"),DR=97_"//^S X=""A""" D ^DIE K DIE,DR,DA
. S PPT=$P($G(^PRC(442,PRCFA("PODA"),12)),U,15)
. QUIT
ACC I '$D(^PRC(442,PRCFA("PODA"),22)) D G OUT
. S X="This P.O. has no FMS accounting lines - Cannot process.*"
. D MSG^PRCFQ
. Q
PAR S DIC("A")="Partial Number to PROCESS: ",DIC="^PRC(442,"_+PO_",11,"
S DIC("S")="I $P(^(0),U,19)="""""
S DIC(0)="AEQMNZ" D ^DIC K DIC("A")
G:Y<0 OUT S PO(11)=Y(0),PRCFA("PARTIAL")=+Y
; Convert IFCAP Partial # ==> FMS Partial #
N PNO S PNO="" D ALPHA^PRCFPAR(PRCFA("PARTIAL"),.PNO)
I PNO<0 D G PAR
. S X="Partial # is out of limits - FMS will not process.*"
. D MSG^PRCFQ
. Q
N ACTION S ACTION="E"
S X=$P($G(^PRC(442,PRCFA("PODA"),11,PRCFA("PARTIAL"),1)),U,16)
I X?1.N D
. S X="This partial #"_PRCFA("PARTIAL")_" is an Adjustment to partial #"_X
. D MSG^PRCFQ
. S ACTION="M"
I $P(PO(11),U,6)="Y" W $C(7) D I %'=1 G OUT
. S %A="Fiscal Service has already processed this partial."
. S %A(1)="Do you want to enter a MODIFICATION to the original Receiving Report"
. S %B="",%=2 D ^PRCFYN I %'=1 K P,DIC,Y
. Q
S PO(2)=$P(PO(11),"^")\1 ;I $P(PO(0),"^",19)=2!($P(PO(0),"^",19)=3) G X
S DA(1)=PRCFA("PODA"),DA=PRCFA("PARTIAL")
S DIE="^PRC(442,"_PRCFA("PODA")_",11,",DR="23R//^S X=$P(""JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC"",U,+$E(DT,4,5))_"" ""_($E(DT,1,3)+1700)"
D ^DIE K DA,DIE,DR G OUT8:$D(DTOUT)!$D(DUOUT)!$D(Y)
C N SC,DOCTYPE S (SC,DOCTYPE)="N"
S PRCFPO=PRCFA("PODA"),PRCFPR=PRCFA("PARTIAL"),PRCFA8=1
D EN^PRCFARR I $G(LCKFLG) G OUT8
D:$D(^TMP("PRCFARR",$J)) ^PRCFARRD
W:'$D(^TMP("PRCFARR",$J)) @IOF,!,"Error: Receiver Records could not be built!",!!
S PO=+PO
EN82 ;
X W !,"LIQUIDATION CODE: " R X:DTIME G OUT8:'$T,OUT8:X["^"
I "PCF"'[$E(X)!(X="") W ! S X="Enter a (P)artial, (F)inal, or (C)omplete only.*" D MSG^PRCFQ G X
S PRCFA("LIQ")=$E(X)
S MESSAGE="" D ESIG^PRCUESIG(DUZ,.MESSAGE)
I MESSAGE'=1 S X="<No Further Action Taken.>" D MSG^PRCFQ G OUT
I $G(PRCFA("PODA"))>0 D
. D EN72^PRCFAC1
. N XA,XB,XC,XD,GECSFMS,POESIG S GECSFMS("DA")=""
. S GECSFMS("DOC")="^^RR^"_$TR($P(PO(0),U),"-")_PNO
. K PRCFA("TT") S POESIG=1,XA="RR",XB=$S($G(ACTION)="M":1,1:0)
. S XC=$P(^PRC(442,PRCFA("PODA"),11,PRCFA("PARTIAL"),0),U)
. S XD=$P($P(PO(0),"^"),"-",2)
. D EN7^PRCFFU41(XA,XB,XC,XD)
. D LOAD^PRCFARRQ
OUT8 K PRCFA("PODA"),PRCFA("REC"),PRCFA("PARTIAL"),%A,%B,DTOUT,DUOUT,PO,PRCF,PRCFASYS,PRCFPO,PRCFPR
G EN8
OUT K %,%A,%B,%Y,B,D0,DA,DG,DIC,DIE,DIG,DIH,DIK,DIR,DIU,DIV,DIW,DLAYGO,DR,DTOUT,DUOUT,FSO,J,K,MESSAGE,P,PO,PRCF,PRCFA,PRCFASYS,PRCFPO,PRCFPR,Q,Q1,S,X,Y
K ^TMP("PRCFARR",$J)
Q
ONE2PROC() ;Check if unsent receivers
N X,Z S X=0,Z=0
F S Z=$O(^PRC(442,Y,11,Z)) Q:Z'?1.N D Q:X
. Q:$D(^PRC(442,Y,11,Z,0))#10'=1
. S:$P(^PRC(442,Y,11,Z,0),U,19)="" X=1
Q X
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCFA8 4142 printed Apr 09, 2024@21:02:41 Page 2
PRCFA8 ;WISC/CTB-PROCESS RECEIVING REPORTS ;2/2/96 13:30
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
EN8 ;PROCESSING OF RECEIVING REPORT
+1 SET (PRCFA("SYS"),PRCFASYS)="FMS"
SET PRCF("X")="AS"
+2 DO ^PRCFSITE
if '%
GOTO OUT
KILL DIC("A")
+3 SET D="C"
SET DIC("S")="I +$P(^(0),U,1)=PRC(""SITE""),$D(^(7)),+^(7)>0 S FSO=$P(^PRCD(442.3,+^(7),0),U,3) I FSO>29&(FSO<40)!(FSO=26!(FSO=41)&$$ONE2PROC^PRCFA8) I '$P($G(^PRC(442,+Y,24)),U)"
+4 SET DIC("A")="Select Purchase Order Number: "
SET DIC=442
SET DIC(0)="AEQZ"
+5 DO IX^DIC
KILL DIC("S"),DIC("A"),FSO
if +Y<0
GOTO OUT
+6 SET PO(0)=Y(0)
SET (D0,PRCFA("PODA"))=+Y
SET PO=Y
+7 SET %A="Do want to review the Purchase Order and Receiving Report"
+8 IF $PIECE($GET(^PRC(442,D0,11,0)),U,4)>1
SET %A=%A_"s"
+9 SET %B=""
SET %=2
DO ^PRCFYN
if %<0
GOTO OUT
IF %=1
DO ^PRCHDP1
PPT NEW FED,PPT,I
SET PPT=""
SET (FED,I)=0
+1 NEW P7
SET P7=$PIECE($GET(^PRC(442,PRCFA("PODA"),1)),U,7)
+2 IF P7]""
IF "13578"[P7
SET FED=2
+3 ;I 'FED N PPR F S I=$O(^PRC(442,PRCFA("PODA"),5,I)) Q:+I'=I S PPR=$G(^(I,0)) D
+4 ;. Q:PPR="" I $P(PPR,U,1)="NET",$P(PPR,U,5)]"" S PPT=$P(PPR,U,5)
+5 ;. I PPT="" S PPT=$P(PPR,U,5)
+6 ;. Q
+7 SET PPT=$PIECE($GET(^PRC(442,PRCFA("PODA"),12)),U,15)
+8 IF 'FED
IF PPT=""
Begin DoDot:1
+9 WRITE !!,"This P.O. does not have PROMPT PAYMENT TYPE information.",!,"PLease enter the information now."
+10 SET DIE="^PRC(442,"
SET DA=PRCFA("PODA")
SET DR=97_"//^S X=""A"""
DO ^DIE
KILL DIE,DR,DA
+11 SET PPT=$PIECE($GET(^PRC(442,PRCFA("PODA"),12)),U,15)
+12 QUIT
End DoDot:1
IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(Y)
GOTO OUT
ACC IF '$DATA(^PRC(442,PRCFA("PODA"),22))
Begin DoDot:1
+1 SET X="This P.O. has no FMS accounting lines - Cannot process.*"
+2 DO MSG^PRCFQ
+3 QUIT
End DoDot:1
GOTO OUT
PAR SET DIC("A")="Partial Number to PROCESS: "
SET DIC="^PRC(442,"_+PO_",11,"
+1 SET DIC("S")="I $P(^(0),U,19)="""""
+2 SET DIC(0)="AEQMNZ"
DO ^DIC
KILL DIC("A")
+3 if Y<0
GOTO OUT
SET PO(11)=Y(0)
SET PRCFA("PARTIAL")=+Y
+4 ; Convert IFCAP Partial # ==> FMS Partial #
+5 NEW PNO
SET PNO=""
DO ALPHA^PRCFPAR(PRCFA("PARTIAL"),.PNO)
+6 IF PNO<0
Begin DoDot:1
+7 SET X="Partial # is out of limits - FMS will not process.*"
+8 DO MSG^PRCFQ
+9 QUIT
End DoDot:1
GOTO PAR
+10 NEW ACTION
SET ACTION="E"
+11 SET X=$PIECE($GET(^PRC(442,PRCFA("PODA"),11,PRCFA("PARTIAL"),1)),U,16)
+12 IF X?1.N
Begin DoDot:1
+13 SET X="This partial #"_PRCFA("PARTIAL")_" is an Adjustment to partial #"_X
+14 DO MSG^PRCFQ
+15 SET ACTION="M"
End DoDot:1
+16 IF $PIECE(PO(11),U,6)="Y"
WRITE $CHAR(7)
Begin DoDot:1
+17 SET %A="Fiscal Service has already processed this partial."
+18 SET %A(1)="Do you want to enter a MODIFICATION to the original Receiving Report"
+19 SET %B=""
SET %=2
DO ^PRCFYN
IF %'=1
KILL P,DIC,Y
+20 QUIT
End DoDot:1
IF %'=1
GOTO OUT
+21 ;I $P(PO(0),"^",19)=2!($P(PO(0),"^",19)=3) G X
SET PO(2)=$PIECE(PO(11),"^")\1
+22 SET DA(1)=PRCFA("PODA")
SET DA=PRCFA("PARTIAL")
+23 SET DIE="^PRC(442,"_PRCFA("PODA")_",11,"
SET DR="23R//^S X=$P(""JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC"",U,+$E(DT,4,5))_"" ""_($E(DT,1,3)+1700)"
+24 DO ^DIE
KILL DA,DIE,DR
if $DATA(DTOUT)!$DATA(DUOUT)!$DATA(Y)
GOTO OUT8
C NEW SC,DOCTYPE
SET (SC,DOCTYPE)="N"
+1 SET PRCFPO=PRCFA("PODA")
SET PRCFPR=PRCFA("PARTIAL")
SET PRCFA8=1
+2 DO EN^PRCFARR
IF $GET(LCKFLG)
GOTO OUT8
+3 if $DATA(^TMP("PRCFARR",$JOB))
DO ^PRCFARRD
+4 if '$DATA(^TMP("PRCFARR",$JOB))
WRITE @IOF,!,"Error: Receiver Records could not be built!",!!
+5 SET PO=+PO
EN82 ;
X WRITE !,"LIQUIDATION CODE: "
READ X:DTIME
if '$TEST
GOTO OUT8
if X["^"
GOTO OUT8
+1 IF "PCF"'[$EXTRACT(X)!(X="")
WRITE !
SET X="Enter a (P)artial, (F)inal, or (C)omplete only.*"
DO MSG^PRCFQ
GOTO X
+2 SET PRCFA("LIQ")=$EXTRACT(X)
+3 SET MESSAGE=""
DO ESIG^PRCUESIG(DUZ,.MESSAGE)
+4 IF MESSAGE'=1
SET X="<No Further Action Taken.>"
DO MSG^PRCFQ
GOTO OUT
+5 IF $GET(PRCFA("PODA"))>0
Begin DoDot:1
+6 DO EN72^PRCFAC1
+7 NEW XA,XB,XC,XD,GECSFMS,POESIG
SET GECSFMS("DA")=""
+8 SET GECSFMS("DOC")="^^RR^"_$TRANSLATE($PIECE(PO(0),U),"-")_PNO
+9 KILL PRCFA("TT")
SET POESIG=1
SET XA="RR"
SET XB=$SELECT($GET(ACTION)="M":1,1:0)
+10 SET XC=$PIECE(^PRC(442,PRCFA("PODA"),11,PRCFA("PARTIAL"),0),U)
+11 SET XD=$PIECE($PIECE(PO(0),"^"),"-",2)
+12 DO EN7^PRCFFU41(XA,XB,XC,XD)
+13 DO LOAD^PRCFARRQ
End DoDot:1
OUT8 KILL PRCFA("PODA"),PRCFA("REC"),PRCFA("PARTIAL"),%A,%B,DTOUT,DUOUT,PO,PRCF,PRCFASYS,PRCFPO,PRCFPR
+1 GOTO EN8
OUT KILL %,%A,%B,%Y,B,D0,DA,DG,DIC,DIE,DIG,DIH,DIK,DIR,DIU,DIV,DIW,DLAYGO,DR,DTOUT,DUOUT,FSO,J,K,MESSAGE,P,PO,PRCF,PRCFA,PRCFASYS,PRCFPO,PRCFPR,Q,Q1,S,X,Y
+1 KILL ^TMP("PRCFARR",$JOB)
+2 QUIT
ONE2PROC() ;Check if unsent receivers
+1 NEW X,Z
SET X=0
SET Z=0
+2 FOR
SET Z=$ORDER(^PRC(442,Y,11,Z))
if Z'?1.N
QUIT
Begin DoDot:1
+3 if $DATA(^PRC(442,Y,11,Z,0))#10'=1
QUIT
+4 if $PIECE(^PRC(442,Y,11,Z,0),U,19)=""
SET X=1
End DoDot:1
if X
QUIT
+5 QUIT X
