95 lines
4.8 KiB
Mathematica
95 lines
4.8 KiB
Mathematica
PRCH1A3 ;WISC/PLT-PRCH1A continued ;9/8/98 11:10
|
|
V ;;5.1;IFCAP;;Oct 20, 2000
|
|
;Per VHA Directive 10-93-142, this routine should not be modified.
|
|
QUIT ;invalid entry
|
|
;
|
|
RC ;entry point - prch1d
|
|
;if the order is Simplified or Detailed but receiving is not required,
|
|
;confirm receipt with the user; otherwise check file #442,
|
|
;node 11 before asking the user any questions.
|
|
;
|
|
S PRCE=^PRC(442,PRCRI(442),0),PRCCP=$P($G(^(23)),"^",16),PRCR=$P($G(^(23)),"^",15)
|
|
I PRCR="N",$P($G(^PRC(442,PRCRI(442),23)),"^",11)="S" D EDIT^PRC0B(.X,"440.6;^PRCH(440.6,;"_PRCRI(440.6),43) I $G(X)=-1 D EXIT QUIT
|
|
I PRCR="N",$P($G(^PRC(442,PRCRI(442),23)),"^",11)="P" D EDIT^PRC0B(.X,"440.6;^PRCH(440.6,;"_PRCRI(440.6),43) I $G(X)=-1 D EXIT QUIT
|
|
;
|
|
I PRCR="Y",$P($G(^PRC(442,PRCRI(442),23)),"^",11)="P" D I $G(X)=-1 D EXIT QUIT
|
|
. D CHKREC I $P($G(^PRCH(440.6,PRCRI(440.6),1)),"^",3)="Y" Q
|
|
. D EDIT^PRC0B(.X,"440.6;^PRCH(440.6,;"_PRCRI(440.6),"43////N") I $G(X)=-1 D EXIT QUIT
|
|
;
|
|
;See if the order was entered by a PA with MOP=25 and confirm receipt.
|
|
I PRCR="Y",$P($G(^PRC(442,PRCRI(442),23)),"^",11)="" D I $G(X)=-1 D EXIT QUIT
|
|
. D CHKREC I $P($G(^PRCH(440.6,PRCRI(440.6),1)),"^",3)="Y" Q
|
|
. D EDIT^PRC0B(.X,"440.6;^PRCH(440.6,;"_PRCRI(440.6),"43////N")
|
|
;
|
|
I PRCR="N",$P($G(^PRC(442,PRCRI(442),23)),"^",11)="" D I $G(X)=-1 D EXIT QUIT
|
|
. D EDIT^PRC0B(.X,"440.6;^PRCH(440.6,;"_PRCRI(440.6),43)
|
|
;
|
|
;Check old orders where receiving required was not specified by the PA.
|
|
I PRCR="",$P($G(^PRC(442,PRCRI(442),23)),"^",11)="" S PRCR="Y" D I $G(X)=-1 D EXIT QUIT
|
|
. D CHKREC I $P($G(^PRCH(440.6,PRCRI(440.6),1)),"^",3)="Y" Q
|
|
. D EDIT^PRC0B(.X,"440.6;^PRCH(440.6,;"_PRCRI(440.6),"43////N")
|
|
;
|
|
;Check PC Direct Delivery Orders. These orders are not received at the
|
|
;station.
|
|
I PRCR="",$P($G(^PRC(442,PRCRI(442),23)),"^",11)="P" D EDIT^PRC0B(.X,"440.6;^PRCH(440.6,;"_PRCRI(440.6),"43////Y") I $G(X)=-1 D EXIT QUIT
|
|
;
|
|
W !,"WARNING: If a credit or additional charge is expected against this order number"
|
|
W !,"do NOT respond YES."
|
|
D EDIT^PRC0B(.X,"440.6;^PRCH(440.6,;"_PRCRI(440.6),"44;15////R;45////"_DUZ) I $G(X)=-1 D EXIT QUIT
|
|
D EDIT^PRC0B(.X,"440.6;^PRCH(440.6,;"_PRCRI(440.6),"46///T;41////"_PRCRI(442)_";42////"_PRCR)
|
|
S PRCRI(410)=$P(^PRC(442,PRCRI(442),0),"^",12),PRCF=$P($G(^(7)),"^",2)
|
|
I PRCRI(410) S PRCCOA=$P($G(^PRCS(410,PRCRI(410),4)),"^",8)
|
|
I '$G(PRCEDRM) D EDIT^PRC0B(.X,"440.6;^PRCH(440.6,;"_PRCRI(440.6),"18////"_PRCCOA_";19////"_PRCF)
|
|
S PRCF=^PRCH(440.6,PRCRI(440.6),1),PRCST=$S($P(PRCF,U,2)]"":$P(PRCF,U,2),1:"N")_$S($P(PRCF,U,3)]"":$P(PRCF,U,3),1:"N")_$S($P(PRCF,U,4)]"":$P(PRCF,U,4),1:"N")
|
|
I $E(PRCST)="N" S PRCSTC=$E("NC",$E(PRCST,2)="Y"+1)_$E(PRCST,3)
|
|
E S PRCSTC=$S($D(^PRC(442,PRCRI(442),2,"C"))&$D(^PRC(442,PRCRI(442),11)):"P",'$D(^PRC(442,PRCRI(442),11)):"N",1:"C")_$E(PRCST,3)
|
|
S PRCST=$P($T(@PRCSTC),";",3,4),PRCST=$S($D(^PRC(442,PRCRI(442),6)):+$P(PRCST,";",2),1:+$P(PRCST,";"))
|
|
D EDIT^PRC0B(.X,"442;^PRC(442,;"_PRCRI(442),"58///T;.5///"_PRCST)
|
|
I $P(PRCF,"^",4)="N" D
|
|
. S PRCVAL="" D EDIT^PRC0B(.X,"442;^PRC(442,;"_PRCRI(442),"44Are you going to dispute this charge amount?//NO;S PRCVAL=X W:X?1""Y"".U !,""You must file a disputed claim form with Purchase Card Company.""")
|
|
. I PRCVAL?1"Y".U D EDIT^PRC0B(.X,"440.6;^PRCH(440.6,;"_PRCRI(440.6),"15////D")
|
|
. QUIT
|
|
I $P(PRCF,"^",4)="Y" D EDIT^PRC0B(.X,"440.6;^PRCH(440.6,;"_PRCRI(440.6),"15////R"),EDIT^PRC0B(.X,"442;^PRC(442,;"_PRCRI(442),"44////N")
|
|
I $P(PRCF,"^",4)="Y",PRCRI(410) D
|
|
. N A,B
|
|
. S A=0,B=0 F S A=$O(^PRCH(440.6,"PO",PRCRI(442),A)) QUIT:'A S B=B+$P(^PRCH(440.6,A,0),"^",14)
|
|
. I B-PRCCOA D EDIT^PRC0B(.X,"410;^PRCS(410,;"_PRCRI(410),"27////"_B)
|
|
. S PRCRI(410)=0
|
|
. F S PRCRI(410)=$O(^PRC(442,PRCRI(442),13,PRCRI(410))) QUIT:'PRCRI(410) D:PRCRI(410) ERS410^PRC0G(PRCRI(410)_"^O")
|
|
. QUIT
|
|
D EDIT^PRC0B(.X,"442;^PRC(442,;"_PRCRI(442),"20")
|
|
S A=$$DDA4406^PRCH0A(PRCRI(440.6)),B=$$DDA442^PRCH0A(PRCRI(442)),$P(B,"^",17)="",PRCBOC=$P(B,"^",21),$P(B,"^",33)=$P(A,"^",33)
|
|
I '$G(PRCEDRM),A'=B D
|
|
. I $E(PRCB,13,15)>490 D EN^DDIOL("Enter ET-Document by FMS-ON LINE!") QUIT
|
|
. D EN^DDIOL("Generating ET-document to FMS...")
|
|
. D ET^PRCH8A(.X,PRCRI(440.6)_"^"_PRCRI(442)_"^1^"_PRCBOC,"")
|
|
. I X D EDIT^PRC0B(.X,"440.6;^PRCH(440.6,;"_PRCRI(440.6),"17////"_$P(X,"^"))
|
|
. QUIT
|
|
EXIT D:$D(IOSTBM) SS(1,24),CS
|
|
K FINALDEL,FPARTIAL,PARTIAL
|
|
QUIT
|
|
;
|
|
SS(IOTM,IOBM) ;screen size a-top, b=bottom margin
|
|
W @IOSTBM QUIT
|
|
;
|
|
MC(DX,DY) ;move cursor dx=column #, dy=row number
|
|
S DX=DX-1,DY=DY-1 X IOXY QUIT
|
|
;
|
|
CS W @IOF QUIT
|
|
;
|
|
CHKREC ;Determine the receiving status of the order
|
|
S PARTIAL=+$P($G(^PRC(442,PRCRI(442),11,0)),"^",3) Q:$G(PARTIAL)=0
|
|
S:PARTIAL>0 FPARTIAL=$G(^PRC(442,PRCRI(442),11,PARTIAL,0))
|
|
S:FPARTIAL]"" FINALDEL=$P($G(FPARTIAL),"^",9)
|
|
I FINALDEL["F" D EDIT^PRC0B(.X,"440.6;^PRCH(440.6,;"_PRCRI(440.6),"43////Y")
|
|
Q
|
|
;
|
|
STATUS ;order status 1-pos:n,p,c for receiving, 2-pos:n,y for final payment
|
|
NN ;;39;44
|
|
NY ;;24;29
|
|
PN ;;46;47
|
|
PY ;;32;34
|
|
CN ;;48;49
|
|
CY ;;50;51
|
|
;
|