source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHDP7.m@ 1766

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

initial load of WorldVistAEHR
File size: 4.2 KB
Line 
1PRCHDP7 ;WISC/DJM-PRINT AMENDMENT, ROUTINE #3 ;10/19/95 10:46 AM
2V ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5E25 ;Edit MAIL INVOICE TO PRINT
6 N CHANGE,OLD,MIT,LCNT,DATA,SITE
7 S CHANGE=0 D LCNT^PRCHDP9(.LCNT)
8 F S CHANGE=$O(^PRC(442,PRCHPO,6,PRCHAM,3,"AC",AMEND,.04,CHANGE)) Q:CHANGE'>0 D
9 .S SITE=$P($G(^PRC(442,PRCHPO,23)),U,7),SITE=$S($G(SITE)]"":SITE,1:$P($P(^PRC(442,PRCHPO,0),U),"-"))
10 .S OLD=^PRC(442,PRCHPO,6,PRCHAM,3,CHANGE,1,1,0),OLD=$P($S($D(^PRC(411,SITE,4,OLD,0)):^(0),1:""),U)
11 .S MIT=$P(^PRC(442,PRCHPO,12),U,6),MIT=$P($S($D(^PRC(411,SITE,4,MIT,0)):^(0),1:""),U)
12 .D LINE^PRCHDP9(.LCNT,2) S DATA="MAIL INVOICE to "_OLD_" has been **AMENDED** to become MAIL INVOICE to "_MIT
13 .D DATA^PRCHDP9(.LCNT,DATA),LCNT1^PRCHDP9(LCNT)
14 Q
15E26 ;Edit METHOD OF PAYMENT PRINT
16 N CHANGE,MOP,OLD,LCNT,DATA
17 S CHANGE=0 D LCNT^PRCHDP9(.LCNT)
18 F S CHANGE=$O(^PRC(442,PRCHPO,6,PRCHAM,3,"AC",AMEND,.02,CHANGE)) Q:CHANGE'>0 D
19 .S OLD=^PRC(442,PRCHPO,6,PRCHAM,3,CHANGE,1,1,0),OLD=$P(^PRCD(442.5,OLD,0),U)
20 .S MOP=$P(^PRC(442,PRCHPO,0),U,2),MOP=$P(^PRCD(442.5,MOP,0),U)
21 .D LINE^PRCHDP9(.LCNT,2) S DATA="METHOD of PAYMENT of "_OLD D DATA^PRCHDP9(.LCNT,DATA)
22 .S DATA="has been changed to "_MOP D DATA^PRCHDP9(.LCNT,DATA),LCNT1^PRCHDP9(LCNT)
23 Q
24E27 ;ADMINISTRATIVE CERTIFICATION Add PRINT
25 N CHANGE,CHANGES,AC,VAL,LCNT,DATA
26 S CHANGE=0 D LCNT^PRCHDP9(.LCNT)
27 F S CHANGE=$O(^PRC(442,PRCHPO,6,PRCHAM,3,"AC",AMEND,.01,CHANGE)) Q:CHANGE'>0 D
28 .S CHANGES=^PRC(442,PRCHPO,6,PRCHAM,3,CHANGE,0)
29 .S AC=$P(CHANGES,U,4),VAL=$G(^PRC(442,PRCHPO,15,AC,0)) Q:VAL=""
30 .S AC=$P(VAL,U),VAL=$P($G(^PRC(442.7,+VAL,0)),U,2)
31 .D LINE^PRCHDP9(.LCNT,2) S DATA="ADMINISTRATIVE CERTIFICATION "_AC_", "_VAL_", has been ADDED"
32 .D DATA^PRCHDP9(.LCNT,DATA),LCNT1^PRCHDP9(LCNT)
33 Q
34E28 ;ADMINISTRATIVE CERTIFICATION Delete PRINT
35 N CHANGE,CHANGES,AC,OLD,LCNT,DATA
36 S CHANGE=0 D LCNT^PRCHDP9(.LCNT)
37 F S CHANGE=$O(^PRC(442,PRCHPO,6,PRCHAM,3,"AC",AMEND,.01,CHANGE)) Q:CHANGE'>0 D
38 .S CHANGES=^PRC(442,PRCHPO,6,PRCHAM,3,CHANGE,0),OLD=^PRC(442,PRCHPO,6,PRCHAM,3,CHANGE,1,1,0)
39 .S AC=$P(CHANGES,U,4),OLD=$S(OLD>0:$P($G(^PRC(442.7,+OLD,0)),U,2),1:""),OLD=$S(OLD]"":", "_OLD_",",1:"")
40 .D LINE^PRCHDP9(.LCNT,2) S DATA="ADMINISTRATIVE CERTIFICATION "_AC_OLD D DATA^PRCHDP9(.LCNT,DATA)
41 .S DATA="has been DELETED"
42 .D DATA^PRCHDP9(.LCNT,DATA),LCNT1^PRCHDP9(LCNT)
43 Q
44E29 ;EST. SHIPPING Edit PRINT
45 N CHANGE,OLD,EST,LCNT,DATA,OBOC,OBOC1,FLAG
46 S CHANGE=0 D LCNT^PRCHDP9(.LCNT)
47 F S CHANGE=$O(^PRC(442,PRCHPO,6,PRCHAM,3,"AC",AMEND,13,CHANGE)) Q:CHANGE'>0 D
48 .S OLD=^PRC(442,PRCHPO,6,PRCHAM,3,CHANGE,1,1,0),OLD=$FN(OLD,"-",2)
49 .S EST=$P(^PRC(442,PRCHPO,0),U,13),EST=$FN(EST,"-",2)
50 .S (OBOC1,FLAG)=0 K OBOC
51 .F S OBOC1=$O(^PRC(442,PRCHPO,6,PRCHAM,3,"AC",AMEND,13.05,OBOC1)) Q:OBOC1'>0 D Q:FLAG=1
52 ..S OBOC=+(^PRC(442,PRCHPO,6,PRCHAM,3,OBOC1,1,1,0)),FLAG=1
53 .I '$D(OBOC) S OBOC=+$P($G(^PRC(442,PRCHPO,23)),U)
54 .D LINE^PRCHDP9(.LCNT,2)
55 .I OLD'>0 D
56 ..S DATA="**ADDED THROUGH AMENDMENT**" D DATA^PRCHDP9(.LCNT,DATA)
57 ..S DATA="Estimated Shipping and/or Handling of $"_EST_" has been added" D DATA^PRCHDP9(.LCNT,DATA)
58 ..S DATA="BOC: "_+$P($G(^PRC(442,PRCHPO,23)),U) D DATA^PRCHDP9(.LCNT,DATA)
59 ..Q
60 .I OLD>0 D
61 ..S DATA="Estimated Shipping and/or Handling of $"_OLD_" has been changed" D DATA^PRCHDP9(.LCNT,DATA)
62 ..S DATA="to $"_EST D DATA^PRCHDP9(.LCNT,DATA)
63 ..S DATA="BOC: "_OBOC_" has been changed to: "_+$P($G(^PRC(442,PRCHPO,23)),U) D DATA^PRCHDP9(.LCNT,DATA)
64 ..Q
65 .D LCNT1^PRCHDP9(LCNT)
66 .Q
67 Q
68OLD ;GET ALL THE OLD DESCRIPTION FROM 'CHANGES' MULTIPLE AND SET INTO
69 ;THE DISPLAY '^TMP($J,"W"' ARRAY.
70 N LINE,DATA
71 S LINE=1
72 F D:DES]"" Q:DES=""
73 .S DATA=$E(DES,1,60) D DATA^PRCHDP9(.LCNT,DATA)
74 .S DES=$E(DES,61,255) Q:$L(DES)'<75 Q:LINE'>0
75 .S LINE=$O(^PRC(442,PRCHPO,6,PRCHAM,3,PRCHLN,1,LINE)) Q:LINE'>0
76 .S DES=DES_$G(^PRC(442,PRCHPO,6,PRCHAM,3,PRCHLN,1,LINE,0))
77 .Q
78 Q
79 ;
80NEW ;GET ALL THE NEW DESCRIPTION FROM THE LINE ITEM MULTIPLE AND SET
81 ;INTO THE DISPLAY '^TMP($J,"W"' ARRAY.
82 N LINE,DATA
83 S LINE=1
84 F D:ITEM1]"" Q:ITEM1=""
85 .S DATA=$E(ITEM1,1,60) D DATA^PRCHDP9(.LCNT,DATA)
86 .S ITEM1=$E(ITEM1,61,255) Q:$L(ITEM1)'<75 Q:LINE'>0
87 .S LINE=$O(^PRC(442,PRCHPO,2,ITEM,1,LINE)) Q:LINE'>0
88 .S ITEM1=ITEM1_$G(^PRC(442,PRCHPO,2,ITEM,1,LINE,0))
89 .Q
90 Q
Note: See TracBrowser for help on using the repository browser.