- 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 Feb 18, 2025@23:28:06 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
