source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCODCT.m@ 846

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

initial load of WorldVistAEHR
File size: 4.8 KB
Line 
1PRCODCT ;WISC/DJM-DOCUMENT CONFIRMATION TRANSACTION SERVER ;6/19/96 11:03 AM
2V ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5IN ;THIS ROUTINE WILL BE CALLED FROM THE 'FMS' SERVER VIA THE FILE 423.5
6 ;ENTRY FOR THE DOCUMENT CONFIRMATION TRANSACTION.
7 ;PRCDA IS THE INTERNAL ENTRY NUMBER FOR THE RECORD FROM FILE 423.6.
8 ;
9 S:$D(^PRCTMP("BUGS","PRCH")) ^PRCTMP("PRCOSRV2",$J,"14",$H)="At PRCODCT, PRCDA = "_PRCDA_", ZTSK = "_ZTSK
10 N AR,DCB,DCD,DCL,DOCID,LINE1,LN,RFLAG,SEGID,TRANS,PRCMG,PRCXM,LINE,STATION,STCK,ENTRY,ENCK,MGP,NAME,DIE,DR,DA,MTI,DOCLN,LNFLAG,DCL,PRCXM
11 S LINE=$G(^PRCF(423.6,PRCDA,1,10000,0))
12 S MGP=$O(^PRCF(423.5,"B",$P(LINE,U)_"-"_$P(LINE,U,5),0))
13 S MGP=$G(^PRCF(423.5,MGP,0))
14 I $P(MGP,U,2)]"" S PRCMG=$P($G(^XMB(3.8,$P(MGP,U,2),0)),U)
15 D I $D(PRCXM(1)) D PERROR^PRCODCT1 Q
16 .I $P(LINE,U,5)'="DCT" S PRCXM(1)=$P($T(ERROR+1),";;",2) Q
17 .S STATION=$P(LINE,U,4) I STATION="" S PRCXM(1)=$P($T(ERROR+4),";;",2) Q
18 .S STCK=$O(^PRC(411,"B",STATION,0)) I STCK'>0 S PRCXM(1)=$P($T(ERROR+2),";;",2) Q
19 .Q
20 ;
21FIND ;NOW THAT THE 'DCT' TRANSACTION BELONGS HERE LETS FIND THE FIRST
22 ;'DOC' SEGMENT.
23 ;
24 K ^TMP($J,"GECSSDCT"),DCD,DCL
25 S LINE=10000
26 F S (DOCLN,LINE)=$O(^PRCF(423.6,PRCDA,1,LINE)) Q:LINE="" D Q:SEGID="DOC" Q:LINE1["{"
27 .S LINE1=$G(^PRCF(423.6,PRCDA,1,LINE,0))
28 .Q:LINE1="" Q:LINE1'["^"
29 .Q:LINE1["{"
30 .S SEGID=$P(LINE1,U) Q:SEGID=""
31 .Q
32 G:LINE1["{" EXIT
33 ;
34ENTER ;OK, LETS ENTER IN EACH 'DCT' ENTRY BETWEEN TWO 'DOC's INTO THE FILE
35 ;AS NEEDED.
36 ;
37 S LNFLAG=0 K PRCXM
38 F S LINE=$O(^PRCF(423.6,PRCDA,1,LINE)) Q:LINE="" D Q:LINE1["{" I $D(PRCXM(1)) D PERROR^PRCODCT1 S LNFLAG=0
39 .S LINE1=$G(^PRCF(423.6,PRCDA,1,LINE,0))
40 .Q:LINE1=""
41 .S SEGID=$P(LINE1,U)
42 .Q:SEGID=""
43 .Q:SEGID="ER1"
44 .Q:SEGID="ER2"
45 .I LNFLAG=0,SEGID'="DCD" S PRCXM(1)=$P($T(ERROR+6),";;",2) Q
46 .I LNFLAG=0 S LNFLAG=1 D Q
47 ..S ENTRY=$P(LINE1,U,6) I ENTRY="" S PRCXM(1)=$P($T(ERROR+3),";;",2) Q
48 ..S TRANS=$E($P(LINE1,U,7)_" ",1,11) I $P(LINE1,U,7)="" S PRCXM(1)=$P($T(ERROR+5),";;",2) Q
49 ..S DOCID=ENTRY_"-"_TRANS I $P(LINE1,U,8)]"",$P(LINE1,U,8)'="~" S DOCID=DOCID_"-"_$P(LINE1,U,8)
50 ..S DCD=LINE_"^"_$P(LINE1,U,3)
51 ..Q
52 .I LNFLAG=1,'((SEGID="LIN")!(SEGID="DOC")!(SEGID="{")) S PRCXM(1)=$P($T(ERROR+7),";;",2) Q
53 .I LNFLAG=1,SEGID="LIN" S LNFLAG=2 Q
54 .I LNFLAG=1,((SEGID="DOC")!(SEGID="{")) S RFLAG=0 D D UPDATE S DOCLN=LINE,LNFLAG=0 K DOCID,DCD,DCL,RFLAG,AR Q
55 ..I $D(DCD),$P(DCD,U,2)="R" S RFLAG=1 Q
56 ..I $D(DCL) S LN="" F S LN=$O(DCL(LN)) Q:LN="" I $P(DCL(LN),U,2)="R" S RFLAG=1 Q
57 ..Q
58 .I LNFLAG=2,SEGID'="DCL" S PRCXM(1)=$P($T(ERROR+8),";;",2) Q
59 .I LNFLAG=2,SEGID="DCL" S LNFLAG=3,LN=+$P(LINE1,U,5) S DCL(LN)=LINE_"^"_$P(LINE1,U,3) Q
60 .I LNFLAG=3,'((SEGID="DOC")!(SEGID="LIN")!(SEGID="{")) S PRCXM(1)=$P($T(ERROR+9),";;",2) Q
61 .I LNFLAG=3,SEGID="LIN" S LNFLAG=2 Q
62 .I LNFLAG=3,((SEGID="DOC")!(SEGID="{")) S RFLAG=0 D D UPDATE S DOCLN=LINE,LNFLAG=0 K DOCID,DCD,DCL,RFLAG,AR Q
63 ..I $D(DCD),$P(DCD,U,2)="R" S RFLAG=1 Q
64 ..S LN="" F S LN=$O(DCL(LN)) Q:LN="" I $P(DCL(LN),U,2)="R" S RFLAG=1 Q
65 ..Q
66 .Q
67EXIT D KILL^PRCOSRV3(PRCDA)
68 Q
69 ;
70UPDATE S AR=$S(RFLAG=1:"R",1:"A") D PROCESS^GECSSDCT(DOCID,AR)
71 I RFLAG=1 D PERROR^PRCODCT1
72 I RFLAG'=1,"AR^SO^"[$E(DOCID,1,2)_"^" D
73 . N DONE,LOOP,PRCMOP,PRCPO,PRCSIS,PRCTXN
74 . S (DONE,LOOP)=0
75 . S (PRCMOP,PRCPO,PRCSIS,PRCTXN)=""
76 . D DATA^GECSSGET(DOCID,1) ; put info from 2100.1 into GECSDATA
77 . I '$D(GECSDATA) Q ; don't process bad txns from FMS
78 . S PRCPO=$P(GECSDATA(2100.1,GECSDATA,26,"E"),"/",1) ; 442 ien
79 . S PRCMOP=$P(^PRC(442,PRCPO,0),"^",2) ; method of processing
80 . ;
81 . ; find the ien for this entry into file 2100.1
82 . F S LOOP=$O(^PRC(442,PRCPO,10,LOOP)) Q:LOOP'>0!(DONE=1) D
83 . . S NODE=^PRC(442,PRCPO,10,LOOP,0)
84 . . I $P(NODE,"^",9)=GECSDATA D
85 . . . I PRCMOP'=21 S PRCTXN=$P(NODE,"^",10),DONE=1
86 . . . I PRCMOP=21 S PRCTXN=$P(NODE,"^",11),DONE=1
87 . ;
88 . ; label all appropriate txns for this adjust/amend # as final
89 . I PRCTXN'="" D
90 . .S PRCSIS=$$GETTXNS^PRCFFERT(PRCPO,PRCTXN,PRCMOP) ; find all 'sister' txns
91 . . I $P(PRCSIS,"^",5)'=1,$P(PRCSIS,"^")="" D ;txn not part of a vendor, FCP, or PO# edit
92 . . . F LOOP=2:1:4 I $P(PRCSIS,"^",LOOP)]"" D
93 . . . . D DATA^GECSSGET($P(PRCSIS,"^",LOOP),1) ; get ien for each txn
94 . . . . I $E($$STATUS^GECSSGET($P(PRCSIS,"^",LOOP)))'="A" D SETSTAT^GECSSTAA(GECSDATA,"F") ; update status for each sister txn to 'final'
95 Q
96 ;
97ERROR ;HERE IS THE LIST OF ERROR MESSAGES
98 ;;This is not a Document Confirmation Transaction (DCT).
99 ;;The STATION number sent from FMS can not be found at this location.
100 ;;This FMS transaction has no FMS TRANSACTION CODE.
101 ;;There is no STATION number sent from FMS.
102 ;;There is no TRANSACTION NUMBER from FMS.
103 ;;The DCD segment can't be found after a DOC segment.
104 ;;The LIN segment can't be found after a DCL or a DCD segment.
105 ;;The DCL segment can't be found after a LIN segment.
106 ;;A LIN or a DOC segment can't be found after a DCL segment.
Note: See TracBrowser for help on using the repository browser.