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

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

initial load of WorldVistAEHR

File size: 3.5 KB
Line 
1DGPT701 ;ALB/MTC - Process 701 Transaction ;10/06/1999
2 ;;5.3;Registration;**64,164,251,415,729**;Aug 13, 1993;Build 59
3 ; 10/06/1999 ACS - Removed Place of Disposition codes M,Y,Z from the list of
4 ; invalid codes.
5 ;
6EN ;
7 Q
8SET ;
9 S DGPTSTR=$G(^TMP("AEDIT",$J,"N701",DGPTAL7))
10 D PARSE^DGPT701P
11DTE ;
12 S (X,DGPTDDS)=$$FMDT^DGPT101($E(DGPTDDTD,1,6))_"."_$E(DGPTDDTD,7,10)
13 S %DT="XT" D ^%DT I Y<0 S DGPTERC=705 D ERR G:DGPTEDFL EXIT
14 I Y>0 D DD^%DT S DGPTDTD=$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")
15 S X1=DGPTNOW,X2=+DGPTDDS D ^%DTC I X<0 S DGPTERC=740 D ERR G:DGPTEDFL EXIT
16 S X1=+DGPTDDS,X2=+DGPTDTS D ^%DTC S DGPTELP=X I X<0 S DGPTERC=737 D ERR G:DGPTEDFL EXIT
17CHECK ;
18TSPEC ; CHECK TREATING SPECIALTY CODE
19 N DGPTDSP1
20 I DGPTDSP'?2AN S DGPTERC=706 D ERR G:DGPTEDFL EXIT G DISPTY
21 S DGPTSP1=$E(DGPTDSP,1),DGPTSP2=$E(DGPTDSP,2),DGPTERC=0
22 D CHECK^DGPTAE02 I DGPTERC S DGPTERC=706 D ERR G:DGPTEDFL EXIT G DISPTY
23 ;-- Active treating specialty edit check
24 I $E(DGPTDSP,1)=0!($E(DGPTDSP,1)=" ") S DGPTDSP=$E(DGPTDSP,2)
25 ; DGPTDSP := ptf code (alpha-numeric) value (file:42.4,field:7)
26 ; DGPTDSP1 := dinum value (ien, file:42.4,field:.001)
27 S DGPTDSP1=+$O(^DIC(42.4,"C",DGPTDSP,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,DGPTDSP1,DGPTDDS) S DGPTERC=706,DGPTSER(DGPTDDS_701)=1 D ERR G:DGPTEDFL EXIT
31 ;
32DISPTY ;
33 I (DGPTDTY<1)!(DGPTDTY>7) S DGPTERC=707 D ERR G:DGPTEDFL EXIT G OPCAR
34 S DGPTERC=0 D DISPTY^DGPTAE02 I DGPTERC D ERR G:DGPTEDFL EXIT
35OPCAR ;
36 I "13 "'[DGPTDOP S DGPTERC=708 D ERR G:DGPTEDFL EXIT G VA
37 I DGPTDOP'=" " S DGPTERC=0 D OP^DGPTAE02 I DGPTERC D ERR G:DGPTEDFL EXIT
38VA ;
39 I "12 "'[DGPTDVA S DGPTERC=709 D ERR G:DGPTEDFL EXIT
40 ;
41VAOP ;-- check for inconsistencies between opcare and va aspices
42 I DGPTDVA=2,DGPTDOP=1 D G:DGPTEDFL EXIT
43 . S DGPTERC=708 D ERR
44 . S DGPTERC=709 D ERR
45CDR ;
46 I DGPTDLR'?6" "&(DGPTDLR'?." "6N) S DGPTERC=775 D ERR G:DGPTEDFL EXIT
47POD ;
48 ;I "68EIMNOQSVWYZ"[DGPTDPD S DGPTERC=710 D ERR G:DGPTEDFL EXIT G RECF
49 I "68EINOQSVW"[DGPTDPD S DGPTERC=710 D ERR G:DGPTEDFL EXIT G RECF
50 S DGPTERC=0 D POD^DGPTAE02 I DGPTERC D ERR G:DGPTEDFL EXIT
51RECF ;
52 I DGPTDVA'=1!(DGPTDRF=" ") G ASIH
53 I DGPTDRF[" " S DGPTDRF=$P(DGPTDRF," ",1)
54 I DGPTDRF="" S DGPTERC=711 D ERR G:DGPTEDFL EXIT
55ASIH ;
56 I DGPTDAS'=" ",DGPTDAS'?2E1N S DGPTERC=712 D ERR G:DGPTEDFL EXIT
57 ;
58LEAVE ;
59 S DGPTERC=0 D LEAVE^DGPTAE02 D:DGPTERC ERR G:DGPTEDFL EXIT
60SC ;
61 I DGPTDSC'=" "&(DGPTDSC'?3N) S DGPTERC=730 D ERR G:DGPTEDFL EXIT G CP
62 S DGPTDSC=+DGPTDSC
63CP ;
64 S DGPTERC=0 D CANDP^DGPTAE02 I DGPTERC D ERR G:DGPTEDFL EXIT
65DIAG ;
66 S DGPTERC=0 D ^DGPT70DX I DGPTERC D ERR G:DGPTEDFL EXIT
67OVER ; Pass FY92 edits for earlier data
68 I DGPTDDS'>2911001 G ONED
69LEG ; LEGIONNAIRE'S DISEASE
70 S DGPTERC=0 D LEG^DGPTAE02 I DGPTERC D ERR G:DGPTEDFL EXIT
71SUI ; Suicide indicator
72 S DGPTERC=0 D SUI^DGPTAE02 I DGPTERC D ERR G:DGPTEDFL EXIT
73DRUG ;
74 S DGPTERC=0 D DRUG^DGPTAE02 I DGPTERC D ERR G:DGPTEDFL EXIT
75AXES ; Psych axises
76 I '$P($G(^DIC(42.4,+DGPTDSP1,0)),U,4) S (DGPT70X4,DGPT7X51,DGPT7X52)=" " G ONED
77 S DGPTERC=0 D AXIV^DGPTAE02 I DGPTERC D ERR G:DGPTEDFL EXIT
78 S DGPTERC=0 D AXV1^DGPTAE02 I DGPTERC D ERR G:DGPTEDFL EXIT
79 S DGPTERC=0 D AXV2^DGPTAE02 I DGPTERC D ERR G:DGPTEDFL EXIT
80ONED ;
81 I (DGPTDDXO=" ")&('$D(^TMP("AEDIT",$J,"N702"))&'$D(^TMP("AEDIT",$J,"N703"))) S DGPTERC=718 D ERR G:DGPTEDFL EXIT
82 I (DGPTDDXO="X")&($D(^TMP("AEDIT",$J,"N072"))) S DGPTERC=719 D ERR G:DGPTEDFL EXIT
83EXIT ;
84 Q
85ERR ;
86 D WRTERR^DGPTAE(DGPTERC,"N701",DGPTAL7)
87 S ERROR=1
88 Q
Note: See TracBrowser for help on using the repository browser.