source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCH1A3.m@ 724

Last change on this file since 724 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 4.8 KB
RevLine 
[613]1PRCH1A3 ;WISC/PLT-PRCH1A continued ;9/8/98 11:10
2V ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 QUIT ;invalid entry
5 ;
6RC ;entry point - prch1d
7 ;if the order is Simplified or Detailed but receiving is not required,
8 ;confirm receipt with the user; otherwise check file #442,
9 ;node 11 before asking the user any questions.
10 ;
11 S PRCE=^PRC(442,PRCRI(442),0),PRCCP=$P($G(^(23)),"^",16),PRCR=$P($G(^(23)),"^",15)
12 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
13 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
14 ;
15 I PRCR="Y",$P($G(^PRC(442,PRCRI(442),23)),"^",11)="P" D I $G(X)=-1 D EXIT QUIT
16 . D CHKREC I $P($G(^PRCH(440.6,PRCRI(440.6),1)),"^",3)="Y" Q
17 . D EDIT^PRC0B(.X,"440.6;^PRCH(440.6,;"_PRCRI(440.6),"43////N") I $G(X)=-1 D EXIT QUIT
18 ;
19 ;See if the order was entered by a PA with MOP=25 and confirm receipt.
20 I PRCR="Y",$P($G(^PRC(442,PRCRI(442),23)),"^",11)="" D I $G(X)=-1 D EXIT QUIT
21 . D CHKREC I $P($G(^PRCH(440.6,PRCRI(440.6),1)),"^",3)="Y" Q
22 . D EDIT^PRC0B(.X,"440.6;^PRCH(440.6,;"_PRCRI(440.6),"43////N")
23 ;
24 I PRCR="N",$P($G(^PRC(442,PRCRI(442),23)),"^",11)="" D I $G(X)=-1 D EXIT QUIT
25 . D EDIT^PRC0B(.X,"440.6;^PRCH(440.6,;"_PRCRI(440.6),43)
26 ;
27 ;Check old orders where receiving required was not specified by the PA.
28 I PRCR="",$P($G(^PRC(442,PRCRI(442),23)),"^",11)="" S PRCR="Y" D I $G(X)=-1 D EXIT QUIT
29 . D CHKREC I $P($G(^PRCH(440.6,PRCRI(440.6),1)),"^",3)="Y" Q
30 . D EDIT^PRC0B(.X,"440.6;^PRCH(440.6,;"_PRCRI(440.6),"43////N")
31 ;
32 ;Check PC Direct Delivery Orders. These orders are not received at the
33 ;station.
34 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
35 ;
36 W !,"WARNING: If a credit or additional charge is expected against this order number"
37 W !,"do NOT respond YES."
38 D EDIT^PRC0B(.X,"440.6;^PRCH(440.6,;"_PRCRI(440.6),"44;15////R;45////"_DUZ) I $G(X)=-1 D EXIT QUIT
39 D EDIT^PRC0B(.X,"440.6;^PRCH(440.6,;"_PRCRI(440.6),"46///T;41////"_PRCRI(442)_";42////"_PRCR)
40 S PRCRI(410)=$P(^PRC(442,PRCRI(442),0),"^",12),PRCF=$P($G(^(7)),"^",2)
41 I PRCRI(410) S PRCCOA=$P($G(^PRCS(410,PRCRI(410),4)),"^",8)
42 I '$G(PRCEDRM) D EDIT^PRC0B(.X,"440.6;^PRCH(440.6,;"_PRCRI(440.6),"18////"_PRCCOA_";19////"_PRCF)
43 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")
44 I $E(PRCST)="N" S PRCSTC=$E("NC",$E(PRCST,2)="Y"+1)_$E(PRCST,3)
45 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)
46 S PRCST=$P($T(@PRCSTC),";",3,4),PRCST=$S($D(^PRC(442,PRCRI(442),6)):+$P(PRCST,";",2),1:+$P(PRCST,";"))
47 D EDIT^PRC0B(.X,"442;^PRC(442,;"_PRCRI(442),"58///T;.5///"_PRCST)
48 I $P(PRCF,"^",4)="N" D
49 . 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.""")
50 . I PRCVAL?1"Y".U D EDIT^PRC0B(.X,"440.6;^PRCH(440.6,;"_PRCRI(440.6),"15////D")
51 . QUIT
52 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")
53 I $P(PRCF,"^",4)="Y",PRCRI(410) D
54 . N A,B
55 . 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)
56 . I B-PRCCOA D EDIT^PRC0B(.X,"410;^PRCS(410,;"_PRCRI(410),"27////"_B)
57 . S PRCRI(410)=0
58 . F S PRCRI(410)=$O(^PRC(442,PRCRI(442),13,PRCRI(410))) QUIT:'PRCRI(410) D:PRCRI(410) ERS410^PRC0G(PRCRI(410)_"^O")
59 . QUIT
60 D EDIT^PRC0B(.X,"442;^PRC(442,;"_PRCRI(442),"20")
61 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)
62 I '$G(PRCEDRM),A'=B D
63 . I $E(PRCB,13,15)>490 D EN^DDIOL("Enter ET-Document by FMS-ON LINE!") QUIT
64 . D EN^DDIOL("Generating ET-document to FMS...")
65 . D ET^PRCH8A(.X,PRCRI(440.6)_"^"_PRCRI(442)_"^1^"_PRCBOC,"")
66 . I X D EDIT^PRC0B(.X,"440.6;^PRCH(440.6,;"_PRCRI(440.6),"17////"_$P(X,"^"))
67 . QUIT
68EXIT D:$D(IOSTBM) SS(1,24),CS
69 K FINALDEL,FPARTIAL,PARTIAL
70 QUIT
71 ;
72SS(IOTM,IOBM) ;screen size a-top, b=bottom margin
73 W @IOSTBM QUIT
74 ;
75MC(DX,DY) ;move cursor dx=column #, dy=row number
76 S DX=DX-1,DY=DY-1 X IOXY QUIT
77 ;
78CS W @IOF QUIT
79 ;
80CHKREC ;Determine the receiving status of the order
81 S PARTIAL=+$P($G(^PRC(442,PRCRI(442),11,0)),"^",3) Q:$G(PARTIAL)=0
82 S:PARTIAL>0 FPARTIAL=$G(^PRC(442,PRCRI(442),11,PARTIAL,0))
83 S:FPARTIAL]"" FINALDEL=$P($G(FPARTIAL),"^",9)
84 I FINALDEL["F" D EDIT^PRC0B(.X,"440.6;^PRCH(440.6,;"_PRCRI(440.6),"43////Y")
85 Q
86 ;
87STATUS ;order status 1-pos:n,p,c for receiving, 2-pos:n,y for final payment
88NN ;;39;44
89NY ;;24;29
90PN ;;46;47
91PY ;;32;34
92CN ;;48;49
93CY ;;50;51
94 ;
Note: See TracBrowser for help on using the repository browser.