- 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 Mar 13, 2025@21:21:50 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 ;
