source: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTAE.m@ 1416

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

initial load of FOIAVistA 6/30/08 version

File size: 3.2 KB
Line 
1DGPTAE ;ALB/MTC - Austin Edit Checks Driver ; 12 NOV 92
2 ;;5.3;Registration;**58,415**;Aug 13, 1993
3 ;
4 ; Check for 101, 501, 701; Route processing by type; call DRG and output routine
5EN ;
6 N DGPTERP,DGPTERC,DGPRS,DGPTEDFL,DGPTNOW,DGPTFAC
7 S (DGPTEDFL,DGPTERP)=0,DGPRS="N101^N501^N601^N701^N702^N703^N401^N402^N403^N535^"
8 D NOW^%DTC S DGPTNOW=+X
9 ;-- check if record available to process
10 I '$D(^TMP("AEDIT")) G EXIT
11 ;-- check if all nodes are present
12 S DGPTERC=$$PRES() I DGPTERC D WRTERR(DGPTERC,"N101",1) G EXIT
13 ;-- process record
14 D ALLPR
15 ;-- if errors
16 D ERROR
17 ;-- exit
18 D EXIT
19 Q
20 ;
21ALLPR ;-- process all records types
22 N ERROR,NODE,SEQ
23 S ERROR=0
24 ;
25 D FAC
26 ;
27 S NODE="" F S NODE=$O(^TMP("AEDIT",$J,NODE)) Q:NODE=""!(ERROR) D
28 . S SEQ=0 F S SEQ=$O(^TMP("AEDIT",$J,NODE,SEQ)) Q:SEQ="" D RTE
29 ;
30 Q
31 ;
32EXIT ;-- clean-up
33 K ^TMP("AEDIT",$J),^TMP("AERROR",$J),^TMP("AD",$J)
34 K DGPTDTS,DGPTPS,DGPTSSN,DGPTDTA,DGPTFAC,DGPTLN,DGPTFI,DGPTMI
35 K DGPTSRA,DGPTTF,DGPTSRP,DGPTPOW,DGPTMRS,DGPTGEN,DGPTDOB,DGPTPOS1,DGPTPOS2,DGPTEXA,DGPTEXI,DGPTSTE,DGPTCTY,DGPTZIP,DGPTMTC,DGPTBY,DGPTINC
36 K DGPTDDTD,DGPTDDS,DGPTDSP,DGPTDTY,DGPTDOP,DGPTDVA,DGPTDPD,DGPTDRF,DGPTDAS,DGPTDCP,DGPTDDXE,DGPTDDXO,DGPTDLR,DGPTDLC,DGPTDSC
37 K DGPT70LG,DGPT70SU,DGPT70DR,DGPT70X4,DGPTDXV1,DGPTDXV2
38 K DGPTMSR,DGPTMSC,DGPTMLD,DGPTMPD,DGPTMSI,DGPTMD1,DGPTMD11,DGPTMD2,DGPTMD3,DGPTMD4,DGPTMD5,DGPTMXX,DGPTMLR,DGPTMLC,DGPTMBS
39 K DGPTMLG,DGPTMSU,DGPTMDG,DGPTMXIV,DGPTMXV1,DGPTMXV2,DGPT50SR
40 K DGACNT,DGPT7X51,DGPT7X52,DGPTADT,DGPTAGE,DGPTAL7,DGPTBYR,DGPTDIA,DGPTDIA1,DGPTDIA2,DGPTDIAR,DGPTELP,DGPTFEF,DGPTFMDB,DGPTGEN1,DGPTL3,DGPTL4,DGPTMSX,DGPTS1,DGPTS2,DGPTSTTY,DGPTTY,DGPTXTTY,DGSCDT,DGPTPRAR,DGPTOPAR,DGSCDT,DGPTOC
41 K DGFNUM,DGLAST,DGMVT,DGOUT,DGPTF,DGPTOPP,DGSCDT,DGSPEC,DGLAST,DGFNUM
42 Q
43 ;
44RTE ;route processing
45 N DGFL2,I,J
46 S DGFL2=0 F I=1:1:9 S:NODE=$P(DGPRS,U,I) DGFL2=1 Q:(DGFL2)!($P(DGPRS,U,I)']"")
47 I 'DGFL2 S ERROR=101 Q
48 Q:NODE="N701"
49 ;
50 D @("^DGPT"_$S($E(NODE,2)=4:"401",1:$E(NODE,2,4)))
51RTN ;
52 Q
53 ;
54PRES() ;-- check if required pieces are present
55 N I,ERROR
56 S ERROR=0
57 F I="N101","N501","N701" I '$D(^TMP("AEDIT",$J,I)) S ERROR=188 Q
58 Q ERROR
59 ;
60WRTERR(ERROR,NODE,SEQ) ;-- This function will write out errors to the ^TMP("AERROR"
61 ; global.
62 ; INPUT : ERROR - code of Austin's error
63 ; NODE - node error occured on
64 ; SEQ - sequence in ^TMP("AEDIT",
65 ;
66 I '$D(ERROR) G WRTQ
67 S DGPTERP=DGPTERP+1,^TMP("AERROR",$J,SEQ,NODE,DGPTERP)=ERROR
68 I DGPTERP>12 S DGPTEDFL=1
69WRTQ Q
70 ;
71FAC ;-- check facility id; get station type
72 N SUFFIX,SOA,STATION,STTY
73 S DGPTSTTY="",X=$G(^TMP("AEDIT",$J,"N101",1)),DGPTFAC=$E(X,25,30),SUFFIX=$E(X,29,30),SOA=$E(X,45,46)
74 I SOA=" " D WRTERR(107) G FACQ
75 I DGPTFAC'=" ",'DGPTFAC D WRTERR(108,"101") G FACQ
76 I SUFFIX]"" I $D(^DIC(45.81,"D1",SUFFIX)) S DGPTSTTY=$O(^(SUFFIX,0)) S:DGPTSTTY DGPTSTTY=U_DGPTSTTY_U
77 S X=$O(^DIC(45.1,"B",$E(X,45,46),0))
78 S STATION="",STTY=0 F S STTY=$O(^DIC(45.1,X,"ST",STTY)) Q:'STTY S STATION=STATION_"^"_STTY
79 S STATION=STATION_"^"
80 I $P(DGPTSTTY,U,2),STATION'[DGPTSTTY D WRTERR(135,"101") G FACQ
81 S DGPTSTTY=STATION
82FACQ Q
83 ;
84ERROR ;-- this routine will process the error detected during close-out
85 G:'$D(^TMP("AERROR",$J)) ERRQ
86 S DGERR=1
87 D EN^VALM("DGPT CLOSE-OUT ERROR")
88ERRQ Q
89 ;
Note: See TracBrowser for help on using the repository browser.