source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHAMYB.m@ 839

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

initial load of WorldVistAEHR
File size: 5.3 KB
RevLine 
[613]1PRCHAMYB ;WISC/DJM-MOVING AMENDMENT INFO FROM 443.6 TO 442 ;4/4/95 10:57 AM
2V ;;5.1;IFCAP;**79,100**;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5 N PRCIEN,PRCIEN1,PRCDSL,PAT,PRCDS,PRCDATA,PRCAS,FLAG,DIC,X,DIK,PRCHIEN,LAST,%X,%Y,LOOP,LOOPVAL,DA,MESSG1,CHECKSUM,PRCHPO1,PRCHPOX,PRCHPO2,STATUS,FCP,IMF,O0,O1,PODATE,Y,PRCOPODA
6 S PRCIEN=0 F S PRCIEN=$O(^PRC(442,PRCHPO,6,PRCHAM,3,PRCIEN)) Q:PRCIEN'>0 D
7 .S PRCIEN1=$G(^PRC(442,PRCHPO,6,PRCHAM,3,PRCIEN,0)) Q:PRCIEN1=""
8 .S PRCDSL=$P(PRCIEN1,U,7) Q:PRCDSL'>0
9 .S ^PRC(442,PRCHPO,6,PRCHAM,3,"AD",PRCDSL,PRCIEN)=""
10 .Q
11 ;
12COPY2 ;NOW TO COPY ANY DELIVERY SCHEDULES FROM 441.7 TO 442.8.
13 S FLAG=0,PAT=$P(^PRC(443.6,PRCHPO,0),U,1),PRCDS=""
14 F S PRCDS=$O(^PRC(441.7,"AG",PAT,PRCDS)) Q:PRCDS'>0 D Q:FLAG>0
15 .S PRCDSL="" F S PRCDSL=$O(^PRC(441.7,"AG",PAT,PRCDS,PRCDSL)) Q:PRCDSL'>0 D Q:FLAG>0
16 ..S PRCDATA=$G(^PRC(441.7,PRCDSL,0))
17 ..S PRCAS=$P(PRCDATA,U,7)
18 ..S PRCDATA=$P(PRCDATA,U,1,6)
19 ..S PRCDELF=$P(PRCDATA,U,6)
20 ..S:PRCAS>0&(PRCDELF="") ^PRC(442.8,PRCAS,0)=PRCDATA
21 ..I PRCAS>0&(PRCDELF="D") D
22 ...S DIK="^PRC(442.8,"
23 ...S DA=PRCAS
24 ...D ^DIK
25 ...Q
26 ..I PRCAS'>0 D Q:FLAG>0
27 ...S DIC="^PRC(442.8,",DIC(0)="L",X=PAT K DD,DO D FILE^DICN I Y'>0 W !,"An error has occurred while restoring file 442.8 for "_PAT,!,",item "_PRCDS_"." S FLAG=1 Q
28 ...S PRCAS=$S(PRCAS>0:PRCAS,1:+Y),^PRC(442.8,PRCAS,0)=PRCDATA
29 ..Q:FLAG>0
30 ..S DIK="^PRC(442.8,",DA=$S(PRCAS>0:PRCAS,1:+Y) D IX^DIK
31 ..S PRCHIEN=0 F S PRCHIEN=$O(^PRC(442,PRCHPO,6,PRCHAM,3,"AD",PRCDSL,PRCHIEN)) Q:PRCHIEN="" S $P(^PRC(442,PRCHPO,6,PRCHAM,3,PRCHIEN,0),U,7)=PRCAS
32 ..Q
33 .Q
34 Q:FLAG>0
35ROLL ;THIS WILL DO THE LINE ITEM ROLL-UP INTO ALL THE 'BOC's.
36 S LAST=0,%X="^PRC(442,PRCHPO,22,",%Y="^PRC(443.6,PRCHPO,22," D %XY^%RCR
37 S LOOP=0 F S LOOP=$O(^PRC(442,PRCHPO,22,LOOP)) Q:LOOP'>0 D
38 .S LOOPVAL=$G(^PRC(442,PRCHPO,22,LOOP,0)),$P(LOOPVAL,U,2)=0
39 .S ^PRC(442,PRCHPO,22,LOOP,0)=LOOPVAL I $P(LOOPVAL,U,3)'=991,$P(LOOPVAL,U,3)>LAST S LAST=$P(LOOPVAL,U,3)
40 .Q
41 S DA=PRCHPO D ^PRCHAMYC,^PRCHSF1
42 S (MESSG1,CHECKSUM)="" D RECODE^PRCHES5(PRCHPO,CHECKSUM,.MESSG1)
43 ;
44CLEANUP ;THE CODE FOLLOWING THIS COMMENT WILL DELETE THE TEMPORARY FILE
45 ;ENTRIES IN FILE 443.6 AND 441.7 FOR PRCHPO ENTRY FROM 442 AND 442.8
46 ;FILES.
47 S PRCHPO1=$P($G(^PRC(443.6,PRCHPO,0)),U),PRCHPOX=$P($G(^PRC(443.6,PRCHPO,23)),U,4)
48 I PRCHPOX]"" S PRCHPO2=$P($G(^PRC(443.6,PRCHPOX,0)),U)
49 K ^PRC(443.6,PRCHPO) I PRCHPOX>0 K ^PRC(443.6,PRCHPOX)
50 K ^PRC(443.6,"E",$P(PRCHPO1,"-",2),PRCHPO),^PRC(443.6,"B",PRCHPO1,PRCHPO),^PRC(443.6,"D",PRCHPO),^PRC(443.6,"C",PRCHPO,PRCHAM)
51 I PRCHPOX>0 K ^PRC(443.6,"E",$P(PRCHPO2,"-",2),PRCHPOX),^PRC(443.6,"B",PRCHPO2,PRCHPOX),^PRC(443.6,"D",PRCHPOX),^PRC(443.6,"C",PRCHPOX,PRCHAM)
52 S PRCDS="" F S PRCDS=$O(^PRC(441.7,"B",PRCHPO1,PRCDS)) Q:PRCDS'>0 D
53 .S DIK="^PRC(441.7,",DA=PRCDS D ^DIK
54 .Q
55 ;
56STATUS ;NOW TO UPDATE THE 'SUPPLY STATUS', FIELD .5. THIS WILL UPDATE
57 ;THE P.O. STATUS TO EQUAL THE LATEST AMENDMENT STATUS.
58 S STATUS=$P($G(^PRC(442,PRCHPO,6,PRCHAM,1)),U,4),DR=".5////^S X=STATUS",DIE="^PRC(442,",DA=PRCHPO D ^DIE
59 S PRCOPODA=PRCHPO_"^"_1_"^"_PRCHAM
60 ; ...now generating the PHM transaction...
61 D NEW^PRCOEDI ; set up & send PHM
62 ; Create FPDS message for the AAC, PRC*5.1*79. Check if the order was
63 ; amended but the total dollar amount did not. If there is a cancellation, then send the HL7 message.
64 ;PRC*5.1*100: check node 9 and the source code before sending PO to FPDS. Source codes 0,1,3, and 9 not required by FPDS - IEN stored in global.
65 I "1378"[$P(^PRC(442,PRCHPO,1),U,7) G OUT1
66 I $P(^PRC(442,PRCHPO,0),U,15)>0,$D(^PRC(442,PRCHPO,25)),$D(^PRC(442,PRCHPO,9,1,0)) D
67 . I $D(^PRC(442,PRCHPO,6,0)) D
68 .. S PRCMN=$P(^PRC(442,PRCHPO,6,0),U,3)
69 .. I $P(^PRC(442,PRCHPO,6,PRCMN,0),U,3)=0,$P(^PRC(442,PRCHPO,7),U,2)'=45 S PRCQ=1
70 . D:$G(PRCQ)'=1 EN^DDIOL("...now generating the FPDS message for the AAC...","","!!"),EN^DDIOL(" ")
71 . D:$G(PRCQ)'=1 AAC^PRCHAAC
72 ; End of changes for PRC*5.1*79
73OUT1 K PRCOPODA,PRCQ,PRCMN
74 I STATUS'=45 G EXIT
75 S AUTH=$P($G(^PRC(442,PRCHPO,6,PRCHAM,0)),U,4)
76 G:AUTH="" EXIT
77 G:'((AUTH=5)!(AUTH=15)) UPDATE
78 K AUTH,REF,REF1 G EXIT
79 ;
80UPDATE ;UPDATE FILE 410 TO POINT TO THE CORRECT P.O.
81 S O0=$G(^PRC(442,PRCHPO,0))
82 S O1=$G(^PRC(442,PRCHPO,1))
83 S FCP=+$P(O0,U)_+$P(O0,U,3)
84 S PODATE=+$P(O1,U,15)
85 S NEWPO=$P($G(^PRC(442,PRCHPO,23)),U,4)
86 G:NEWPO="" FINI
87 S PRCOPODA=NEWPO_"^"_2_"^"_PRCHAM_"^"_PRCHPO
88 ;...now generating PHA transaction...
89 D NEW^PRCOEDI
90 K PRCOPODA
91 S LOOP=0 F S LOOP=$O(^PRC(442,NEWPO,2,LOOP)) Q:LOOP'>0 D
92 .S L0=$G(^PRC(442,NEWPO,2,LOOP,0))
93 .S L2=$G(^PRC(442,NEWPO,2,LOOP,2))
94 .S L0=$P(L0,U,10),L2=$P(L2,U,13)
95 .Q:L0=""!(L2="")
96 .I $P(L0,U,5)>0 D
97 ..S IMF=$P(L0,U,5)
98 ..K ^PRC(441,IMF,4,FCP,1,PRCHPO,0)
99 ..S ^PRC(441,IMF,4,FCP,1,NEWPO,0)=NEWPO
100 ..K ^PRC(441,IMF,4,FCP,1,"AC",9999999-PODATE,PRCHPO)
101 ..S ^PRC(441,IMF,4,FCP,1,"AC",9999999-PODATE,NEWPO)=""
102 ..Q
103 .S DA(1)=L0,DA=L2,DIE="^PRCS(410,"_DA(1)_",""IT"",",DR="9///^S X=NEWPO"
104 .D ^DIE
105 .Q
106 S PRC2237=$P($G(^PRC(442,PRCHPO,0)),U,12) G:PRC2237'>0 FINI
107 S PRCCNS=$P($P($G(^PRC(442,NEWPO,0)),U),"-",2)
108 S OLDCNS=$P(^PRCS(410,PRC2237,4),U,5)
109 K ^PRCS(410,"D",OLDCNS,PRC2237)
110 S $P(^PRCS(410,PRC2237,4),U,5)=PRCCNS
111 S ^PRCS(410,"D",PRCCNS,PRC2237)=""
112 S $P(^PRCS(410,PRC2237,10),U,3)=NEWPO
113 S MESSAGE="" D RECODE^PRCSC2(PRC2237,.MESSAGE)
114 I MESSAGE'=1 W !,"An error has occurred while recoding an ESIG.",!
115FINI K NEWPO,LOOP,L0,L2,DIE,DR,PRC2237,OLDCNS,PRCCNS,MESSAGE
116EXIT G OTHER^PRCHAMYD
Note: See TracBrowser for help on using the repository browser.