PRCS0B ;WISC/PLT-UTILITY FOR PRCS-ROUTINE ; 12/19/94 1:53 PM
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
QUIT ;invalid entry
;
;PRCA data ^1=buyer station #, ^2=seller station #
;PRCB data ^1=buyer fcp #, ^2=seller fcp #
;PRCC= file 410 ri of buyer's issue book request
;PRCD data ^1=buyer's price, ^2=seller's price
IB(PRCA,PRCB,PRCC,PRCD) ;post buyer's issue book request
N PRC,PRCRI,PRCE,PRCF,PRCG,PRCH,PRCIS
N A,B,C
QUIT:$D(^PRCS(410,PRCC,0))#10=0 S PRCE=^(0),PRCRI("410A")=$P($G(^(445)),"^",4)
S PRCRI(410)=PRCC,A=$P(PRCE,"^"),PRCG=A
S PRC("SITE")=$P(A,"-"),PRC("FY")=$P(A,"-",2),PRC("QTR")=$P(A,"-",3),PRC("CP")=$P(A,"-",4)
D ICLOCK^PRC0B("^PRCS(410,"_PRCRI(410)_",")
S PRCE=$G(^PRCS(410,PRCRI(410),4)),PRCIS=$P($G(^(445)),"^")
I $P(PRCE,"^",5)="" D EDIT^PRC0B(.X,"410;^PRCS(410,;"_PRCRI(410),"24////"_PRCIS)
D:$P(PRCE,"^")'=$P(PRCD,"^")
. D EDIT^PRC0B(.X,"410;^PRCS(410,;"_PRCRI(410),"27////"_$P(PRCD,"^"))
. QUIT
D:$P(PRCE,"^",3)'=$P(PRCD,"^")!($P(PRCE,"^",10)="")
. D EDIT^PRC0B(.X,"410;^PRCS(410,;"_PRCRI(410),"22////"_$P(PRCD,"^"))
. D ENCODE^PRCSC2(PRCRI(410),DUZ)
. D ERS410^PRC0G(PRCRI(410)_"^O")
. QUIT
I PRCRI("410A"),$D(^PRCS(410,PRCRI("410A"),0))#10=0 S PRCRI("410A")=""
I 'PRCRI("410A") D G:'PRCRI("410A") EXIT
. S PRC("SITE")=$P(^PRC(420,+$P(PRCA,"^",2),0),"^")
. S PRC("CP")=$P(^PRC(420,+PRC("SITE"),1,+$P(PRCB,"^",2),0)," ")
. S Z=PRC("SITE")_"-"_PRC("FY")_"-"_PRC("QTR")_"-"_PRC("CP")
. S X=$P(Z,"-",1,2)_"-"_$P(Z,"-",4)
. D EN1^PRCSUT3 QUIT:X="" S PRCH=X
. S PRC("BBFY")=$$BBFY^PRCSUT(PRC("SITE"),PRC("FY"),PRC("CP"),1)
. S X=PRCH D EN2^PRCSUT3 QUIT:Y<1
. S PRCRI("410A")=+Y
. D EDIT^PRC0B(.X,"410;^PRCS(410,;"_PRCRI("410A"),"1////A;3////5;40////^S X=DUZ;26///^S X=""T"";447////"_PRCC_";28.5///^S X="_PRC("BBFY"))
. S PRCF="410;^PRCS(410,;"_PRCRI("410A")_";60"
. S PRCF=PRCF_"~410.05;^PRCS(410,"_PRCRI("410A")_",""CO"","
. S X="Seller's adjustment for issue book request "_PRCG
. D ADD^PRC0B1(.X,.Y,PRCF)
. D EDIT^PRC0B(.X,"410;^PRCS(410,;"_PRCRI(410),"447////"_PRCRI("410A"))
. QUIT
D DCLOCK^PRC0B("^PRCS(410,"_PRCRI(410)_",")
;edit seller adjustment entry inf file 410
S PRCRI(410)=PRCRI("410A")
S PRCE=^PRCS(410,PRCRI(410),0),A=$P(PRCE,"^",1),PRC("BBFY")=$P($G(^(3)),"^",11)
S PRC("SITE")=$P(A,"-"),PRC("FY")=$P(A,"-",2),PRC("QTR")=$P(A,"-",3),PRC("CP")=$P(A,"-",4)
D ICLOCK^PRC0B("^PRCS(410,"_PRCRI(410)_",")
S PRCE=$G(^PRCS(410,PRCRI(410),4))
I $P(PRCE,"^",5)="" D EDIT^PRC0B(.X,"410;^PRCS(410,;"_PRCRI(410),"23///^S X=""T"";24////"_PRCIS),ERS410^PRC0G(PRCRI(410)_"^O")
D:$P(PRCE,"^",6)'=$P(PRCD,"^",2)
. D EDIT^PRC0B(.X,"410;^PRCS(410,;"_PRCRI(410),"25////"_(-$P(PRCD,"^",2)))
. S $P(^PRCS(410,PRCRI(410),4),"^",8)=$P(PRCD,"^",2)
D:$P(PRCE,"^",3)'=$P(PRCD,"^",2)
. D EDIT^PRC0B(.X,"410;^PRCS(410,;"_PRCRI(410),"22////"_(-$P(PRCD,"^",2)))
D DCLOCK^PRC0B("^PRCS(410,"_PRCRI(410)_",")
EXIT QUIT
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCS0B 2994 printed Nov 22, 2024@17:27:07 Page 2
PRCS0B ;WISC/PLT-UTILITY FOR PRCS-ROUTINE ; 12/19/94 1:53 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 ;
+4 ;PRCA data ^1=buyer station #, ^2=seller station #
+5 ;PRCB data ^1=buyer fcp #, ^2=seller fcp #
+6 ;PRCC= file 410 ri of buyer's issue book request
+7 ;PRCD data ^1=buyer's price, ^2=seller's price
IB(PRCA,PRCB,PRCC,PRCD) ;post buyer's issue book request
+1 NEW PRC,PRCRI,PRCE,PRCF,PRCG,PRCH,PRCIS
+2 NEW A,B,C
+3 if $DATA(^PRCS(410,PRCC,0))#10=0
QUIT
SET PRCE=^(0)
SET PRCRI("410A")=$PIECE($GET(^(445)),"^",4)
+4 SET PRCRI(410)=PRCC
SET A=$PIECE(PRCE,"^")
SET PRCG=A
+5 SET PRC("SITE")=$PIECE(A,"-")
SET PRC("FY")=$PIECE(A,"-",2)
SET PRC("QTR")=$PIECE(A,"-",3)
SET PRC("CP")=$PIECE(A,"-",4)
+6 DO ICLOCK^PRC0B("^PRCS(410,"_PRCRI(410)_",")
+7 SET PRCE=$GET(^PRCS(410,PRCRI(410),4))
SET PRCIS=$PIECE($GET(^(445)),"^")
+8 IF $PIECE(PRCE,"^",5)=""
DO EDIT^PRC0B(.X,"410;^PRCS(410,;"_PRCRI(410),"24////"_PRCIS)
+9 if $PIECE(PRCE,"^")'=$PIECE(PRCD,"^")
Begin DoDot:1
+10 DO EDIT^PRC0B(.X,"410;^PRCS(410,;"_PRCRI(410),"27////"_$PIECE(PRCD,"^"))
+11 QUIT
End DoDot:1
+12 if $PIECE(PRCE,"^",3)'=$PIECE(PRCD,"^")!($PIECE(PRCE,"^",10)="")
Begin DoDot:1
+13 DO EDIT^PRC0B(.X,"410;^PRCS(410,;"_PRCRI(410),"22////"_$PIECE(PRCD,"^"))
+14 DO ENCODE^PRCSC2(PRCRI(410),DUZ)
+15 DO ERS410^PRC0G(PRCRI(410)_"^O")
+16 QUIT
End DoDot:1
+17 IF PRCRI("410A")
IF $DATA(^PRCS(410,PRCRI("410A"),0))#10=0
SET PRCRI("410A")=""
+18 IF 'PRCRI("410A")
Begin DoDot:1
+19 SET PRC("SITE")=$PIECE(^PRC(420,+$PIECE(PRCA,"^",2),0),"^")
+20 SET PRC("CP")=$PIECE(^PRC(420,+PRC("SITE"),1,+$PIECE(PRCB,"^",2),0)," ")
+21 SET Z=PRC("SITE")_"-"_PRC("FY")_"-"_PRC("QTR")_"-"_PRC("CP")
+22 SET X=$PIECE(Z,"-",1,2)_"-"_$PIECE(Z,"-",4)
+23 DO EN1^PRCSUT3
if X=""
QUIT
SET PRCH=X
+24 SET PRC("BBFY")=$$BBFY^PRCSUT(PRC("SITE"),PRC("FY"),PRC("CP"),1)
+25 SET X=PRCH
DO EN2^PRCSUT3
if Y<1
QUIT
+26 SET PRCRI("410A")=+Y
+27 DO EDIT^PRC0B(.X,"410;^PRCS(410,;"_PRCRI("410A"),"1////A;3////5;40////^S X=DUZ;26///^S X=""T"";447////"_PRCC_";28.5///^S X="_PRC("BBFY"))
+28 SET PRCF="410;^PRCS(410,;"_PRCRI("410A")_";60"
+29 SET PRCF=PRCF_"~410.05;^PRCS(410,"_PRCRI("410A")_",""CO"","
+30 SET X="Seller's adjustment for issue book request "_PRCG
+31 DO ADD^PRC0B1(.X,.Y,PRCF)
+32 DO EDIT^PRC0B(.X,"410;^PRCS(410,;"_PRCRI(410),"447////"_PRCRI("410A"))
+33 QUIT
End DoDot:1
if 'PRCRI("410A")
GOTO EXIT
+34 DO DCLOCK^PRC0B("^PRCS(410,"_PRCRI(410)_",")
+35 ;edit seller adjustment entry inf file 410
+36 SET PRCRI(410)=PRCRI("410A")
+37 SET PRCE=^PRCS(410,PRCRI(410),0)
SET A=$PIECE(PRCE,"^",1)
SET PRC("BBFY")=$PIECE($GET(^(3)),"^",11)
+38 SET PRC("SITE")=$PIECE(A,"-")
SET PRC("FY")=$PIECE(A,"-",2)
SET PRC("QTR")=$PIECE(A,"-",3)
SET PRC("CP")=$PIECE(A,"-",4)
+39 DO ICLOCK^PRC0B("^PRCS(410,"_PRCRI(410)_",")
+40 SET PRCE=$GET(^PRCS(410,PRCRI(410),4))
+41 IF $PIECE(PRCE,"^",5)=""
DO EDIT^PRC0B(.X,"410;^PRCS(410,;"_PRCRI(410),"23///^S X=""T"";24////"_PRCIS)
DO ERS410^PRC0G(PRCRI(410)_"^O")
+42 if $PIECE(PRCE,"^",6)'=$PIECE(PRCD,"^",2)
Begin DoDot:1
+43 DO EDIT^PRC0B(.X,"410;^PRCS(410,;"_PRCRI(410),"25////"_(-$PIECE(PRCD,"^",2)))
+44 SET $PIECE(^PRCS(410,PRCRI(410),4),"^",8)=$PIECE(PRCD,"^",2)
End DoDot:1
+45 if $PIECE(PRCE,"^",3)'=$PIECE(PRCD,"^",2)
Begin DoDot:1
+46 DO EDIT^PRC0B(.X,"410;^PRCS(410,;"_PRCRI(410),"22////"_(-$PIECE(PRCD,"^",2)))
End DoDot:1
+47 DO DCLOCK^PRC0B("^PRCS(410,"_PRCRI(410)_",")
EXIT QUIT
+1 ;
