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

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

initial load of FOIAVistA 6/30/08 version

File size: 3.0 KB
Line 
1DGPT501 ;ALB/MTC - Set up process 501 transmission ; 8/27/03 10:05am
2 ;;5.3;Registration;**64,164,529,729**;Aug 13, 1993;Build 59
3 ;
4EN ;
5 N ERROR
6 S DGPTEDFL=0
7PARSE ; Set up record string, parse record
8 S DGPTSTR=^TMP("AEDIT",$J,NODE,SEQ)
9 D SET^DGPT501P
10DATE ;
11 S DGPTMDT=$E(DGPTSTR,31,40),(X,DGPTMDTS)=$$FMDT^DGPT101($E(DGPTMDT,1,6))_"."_$E(DGPTMDT,7,10) S %DT="XT" D ^%DT K %DT I Y<0 S DGPTERC=505 D ERR G:DGPTEDFL EXIT G ELAPS
12 D DD^%DT S DGPTMDT=$E(Y,5,6)_"-"_$E(Y,1,3)_"-"_$E(Y,9,12)_" "_$S($P(Y,"@",2)]"":$E($P(Y,"@",2),1,5),1:"00:00")
13 I DGPTMDT'?1.2N1"-"3U1"-"4N1" "2N1":"2N S DGPTERC=505 D ERR G:DGPTEDFL EXIT G TSPEC
14 I DGPTMDTS<DGPTDTS S DGPTERC=537 D ERR G:DGPTEDFL EXIT
15 I DGPTMDTS>DGPTDDS S DGPTERC=540 D ERR G:DGPTEDFL EXIT
16ELAPS ;
17 S DGPTERC=0 S X1=DGPTMDTS D 501^DGPTAE03 I DGPTERC D ERR G:DGPTEDFL EXIT
18TSPEC ;
19 N DGPTMSC1
20 I DGPTMSC'?2AN S DGPTERC=506 D ERR G:DGPTEDFL EXIT G LEAV
21 S DGPTSP1=$E(DGPTMSC,1),DGPTSP2=$E(DGPTMSC,2),DGPTERC=0
22 D CHECK^DGPTAE02 I DGPTERC S DGPTERC=506 D ERR G:DGPTEDFL EXIT G LEAV
23 ;-- Active treating specialty edit check
24 I $E(DGPTMSC,1)=0!($E(DGPTMSC,1)=" ") S DGPTMSC=$E(DGPTMSC,2)
25 ; DGPTMSC := ptf code (alpha-numeric) value (file:42.4,field:7)
26 ; DGPTMSC1 := dinum value (ien, file:42.4,field:001)
27 S DGPTMSC1=+$O(^DIC(42.4,"C",DGPTMSC,0))
28 ;-- If not active treat spec, set flag to print error msg during
29 ;-- PTF close-out error display at WRER^DGPTAEE
30 I '$$ACTIVE^DGACT(42.4,DGPTMSC1,DGPTMDTS) S DGPTERC=506,DGPTSER(DGPTMDTS_501)=1 D ERR G:DGPTEDFL EXIT
31LEAV ;
32 I DGPTMPD'?1.3N S DGPTERC=508 D ERR G:DGPTEDFL EXIT
33SPINL ;
34 D SP^DGPTAE03 I DGPTERC D ERR G:DGPTEDFL EXIT
35LOCCDR ;
36 I DGPTMLR'?6N S DGPTERC=575 D ERR G:DGPTEDFL EXIT G LOCTRS
37 ;
38LOCTRS ;
39 I DGPTMLC'?2AN&(DGPTMLC'=" ") S DGPTERC=576 D ERR G:DGPTEDFL EXIT G DIAG
40 I DGPTMLC=" "&(DGPTMLR="000000") G DIAG
41 S DGPTSP1=$E(DGPTMLC,1),DGPTSP2=$E(DGPTMLC,2),DGPTERC=0
42 D CHECK^DGPTAE02 I DGPTERC S DGPTERC=576 D ERR G:DGPTEDFL EXIT
43DIAG ;
44 D ^DGPT50DI G:DGPTEDFL EXIT
45BSTAT ;
46 I "12345 "'[DGPTMBS S DGPTERC=515 D ERR G:DGPTEDFL EXIT
47FY92 ;
48 I DGPTDDS<2911001 G GOOD
49LEG ; Legionnaires disease
50 S DGPTERC=0 D LEG^DGPT50MS I DGPTERC D ERR G:DGPTEDFL EXIT
51SUI ; Suicide indicator
52 S DGPTERC=0 D SUI^DGPT50MS I DGPTERC D ERR G:DGPTEDFL EXIT
53DRUG ; Drug indicator
54 S DGPTERC=0 D DRUG^DGPT50MS I DGPTERC D ERR G:DGPTEDFL EXIT
55AXES ;Axis 4 and 5
56 I '$P($G(^DIC(42.4,+DGPTMSC1,0)),U,4) S (DGPTMXIV,DGPTMXV1,DGPTMXV2)=" " G SERVC
57 S DGPTERC=0 D AXIV^DGPT50MS I DGPTERC D ERR G:DGPTEDFL EXIT
58 S DGPTERC=0 D AXV1^DGPT50MS I DGPTERC D ERR G:DGPTEDFL EXIT
59 S DGPTERC=0 D AXV2^DGPT50MS I DGPTERC D ERR G:DGPTEDFL EXIT
60SERVC ; Service connected indicator
61 S DGPTERC=0 D SRVC^DGPT50MS I DGPTERC D ERR G:DGPTEDFL EXIT
62GOOD ;
63 W:'$D(ERROR) "."
64EXIT ;
65 K DGPTMD1,DGPTMD2,DGPTMD3,DGPTMD4,DGPTMD5,DGPTMDT,DGPTMDTS,DGPTMLC,DGPTMLD,DGPTMLR,DGPTMPD,DGPTMSC,DGPTMSI,DGPTMSR,DGPTMXX,DGPTSTR,DGPTS,DGPTSP1,DGPTSP2
66 K DGPTMLG,DGPTMSU,DGPTMDG,DGPTMXIV,DGPTMXV1,DGPTMXV2,DGPT50SR,DGPTMBS
67 Q
68ERR ;
69 D WRTERR^DGPTAE(DGPTERC,NODE,SEQ)
70 S ERROR=1
71 Q
Note: See TracBrowser for help on using the repository browser.