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

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

initial load of WorldVistAEHR

File size: 2.6 KB
Line 
1DGPT10S1 ;ALB/MTC - Source of Admission Edit ; 13 NOV 92
2 ;;5.3;Registration;**58**;Aug 13, 1993
3 ;
4 ; SET UP TYPE OF FACILITY REPORTING ADMISSION
5 ; CHECK SOURCE OF ADMISSION FOR CORRECTNESS AND CONSISTENCY WITH STATION TYPE
6 ; DGPTSTTY=TYPE OF STATION REPORTING EPISODE
7 ; DGPTXTTY=TYPE OF STATION TRANSFERRING PATIENT IN
8EN ;
9 N SUFFIX
10 S DGPTXTTY=""
11 ;I DGPTTF=" " Q
12 S SUFFIX=$P($E(DGPTTF,4,6)," ")
13 ;I SUFFIX="" Q
14 I SUFFIX]"" I $D(^DIC(45.81,"D1",SUFFIX)) S DGPTXTTY=$O(^(SUFFIX,0))
15LOOP ;
16 D EDIT Q:DGPTERC
17 D CONSIS Q:DGPTERC
18EXIT ;
19 K DGPTXTT1
20 Q
21EDIT ;
22 S DGPTS1=$E(DGPTSRA,1),DGPTS2=$E(DGPTSRA,2)
23 I "1234567"'[DGPTS1 S DGPTERC=107 Q
24 I DGPTS1=1&("DEGHJKLMPRST"'[DGPTS2) S DGPTERC=107 Q
25 I DGPTS1=2&("ABC"'[DGPTS2) S DGPTERC=107 Q
26 I DGPTS1=3&("ABCDE"'[DGPTS2) S DGPTERC=107 Q
27 I DGPTS1=4&("ABCDEFGHJKLMNPQRSTUWY"'[DGPTS2) S DGPTERC=107 Q
28 I DGPTS1=5&("ABCDEFG"'[DGPTS2) S DGPTERC=107 Q
29 I DGPTS1=6&("ABCD"'[DGPTS2) S DGPTERC=107 Q
30 I DGPTS1=7&(DGPTS2'="B") S DGPTERC=107 Q
31 Q
32CONSIS ;
33 D @DGPTS1 Q
341 ;
35 I DGPTXTTY="" Q
36 I DGPTSRA="1D"&(DGPTXTTY'=40) S DGPTERC=135 Q
37 I DGPTSRA="1E"&(DGPTXTTY'=30) S DGPTERC=135 Q
38 I DGPTSRA="1G"&(DGPTXTTY'=42) S DGPTERC=135 Q
39 I "HJKMP"[DGPTS2&(DGPTXTTY'="") S DGPTERC=135 Q
40 Q
412 ;
42 Q
433 ;
44 I DGPTTF="" S DGPTERC=135 Q
45 Q
464 ;
47 I DGPTXTTY="" Q
48 I DGPTSRA="4A"&("110"'[DGPTXTTY) S DGPTERC=135 Q
49 I DGPTSRA="4C"&(DGPTXTTY'=40) S DGPTERC=135 Q
50 I "ED"[DGPTS2&(DGPTXTTY'=30) S DGPTERC=135 Q
51 I DGPTSRA="4F"&((DGPTXTTY'=25)&(DGPTXTTY'=26)) S DGPTERC=135 Q
52 I DGPTSRA="4H"&(DGPTXTTY'=42) S DGPTERC=135 Q
53 I DGPTSRA="4K"&(DGPTXTTY'=32) S DGPTERC=135 Q
54 I DGPTSRA="4L"&(DGPTXTTY'=41) S DGPTERC=135 Q
55 I DGPTSRA="4M"&((DGPTXTTY'=20)&(DGPTXTTY'=21)&(DGPTXTTY'=22)) S DGPTERC=135 Q
56 I DGPTSRA="4N"&((DGPTXTTY'=23)&(DGPTXTTY'=24)) S DGPTERC=135 Q
57 I DGPTSRA="4R"&(DGPTXTTY'=25) S DGPTERC=135 Q
58 I "GBJPQSTUWY"[DGPTS2&(DGPTXTTY'="") S DGPTERC=135 Q
59 Q
605 ;
61 I DGPTXTTY="" Q
62 I DGPTSRA="5A"&("110"'[DGPTXTTY) S DGPTERC=135 Q
63 I DGPTSRA="5B"&((DGPTXTTY<20)!(DGPTXTTY>26)) S DGPTERC=135 Q
64 I DGPTSRA="5C"&(DGPTXTTY'=30) S DGPTERC=135 Q
65 I "ED"[DGPTS2&(DGPTXTTY'=40) S DGPTERC=135 Q
66 I DGPTSRA="5F"&(DGPTXTTY'=42) S DGPTERC=135 Q
67 ;- commented out for DG*5.3*58 as XX is not a valid station type
68 ;I DGPTSRA="5G"&(DGPTXTTY'="XX") S DGPTERC=135 Q
69 Q
706 ;
71 I DGPTXTTY="" Q
72 I DGPTSRA="6A"&("110"'[DGPTXTTY) S DGPTERC=135 Q
73 I DGPTSRA="6B"&(DGPTXTTY'=40) S DGPTERC=135 Q
74 I DGPTSRA="6C"&(DGPTXTTY'=42) S DGPTERC=135 Q
75 ;- commented out for DG*5.3*58 as XX is not a valid station type
76 ;I DGPTSRA="6D"&(DGPTXTTY'="XX") S DGPTERC=135 Q
77 Q
787 ;
79 I DGPTXTTY="" Q
80 I DGPTSRA="7B"&((DGPTXTTY<20)!(DGPTXTTY>22)) S DGPTERC=135 Q
81 Q
Note: See TracBrowser for help on using the repository browser.