DGPT10S1 ;ALB/MTC - Source of Admission Edit ; 13 NOV 92
;;5.3;Registration;**58**;Aug 13, 1993
;
; SET UP TYPE OF FACILITY REPORTING ADMISSION
; CHECK SOURCE OF ADMISSION FOR CORRECTNESS AND CONSISTENCY WITH STATION TYPE
; DGPTSTTY=TYPE OF STATION REPORTING EPISODE
; DGPTXTTY=TYPE OF STATION TRANSFERRING PATIENT IN
EN ;
N SUFFIX
S DGPTXTTY=""
;I DGPTTF=" " Q
S SUFFIX=$P($E(DGPTTF,4,6)," ")
;I SUFFIX="" Q
I SUFFIX]"" I $D(^DIC(45.81,"D1",SUFFIX)) S DGPTXTTY=$O(^(SUFFIX,0))
LOOP ;
D EDIT Q:DGPTERC
D CONSIS Q:DGPTERC
EXIT ;
K DGPTXTT1
Q
EDIT ;
S DGPTS1=$E(DGPTSRA,1),DGPTS2=$E(DGPTSRA,2)
I "1234567"'[DGPTS1 S DGPTERC=107 Q
I DGPTS1=1&("DEGHJKLMPRST"'[DGPTS2) S DGPTERC=107 Q
I DGPTS1=2&("ABC"'[DGPTS2) S DGPTERC=107 Q
I DGPTS1=3&("ABCDE"'[DGPTS2) S DGPTERC=107 Q
I DGPTS1=4&("ABCDEFGHJKLMNPQRSTUWY"'[DGPTS2) S DGPTERC=107 Q
I DGPTS1=5&("ABCDEFG"'[DGPTS2) S DGPTERC=107 Q
I DGPTS1=6&("ABCD"'[DGPTS2) S DGPTERC=107 Q
I DGPTS1=7&(DGPTS2'="B") S DGPTERC=107 Q
Q
CONSIS ;
D @DGPTS1 Q
1 ;
I DGPTXTTY="" Q
I DGPTSRA="1D"&(DGPTXTTY'=40) S DGPTERC=135 Q
I DGPTSRA="1E"&(DGPTXTTY'=30) S DGPTERC=135 Q
I DGPTSRA="1G"&(DGPTXTTY'=42) S DGPTERC=135 Q
I "HJKMP"[DGPTS2&(DGPTXTTY'="") S DGPTERC=135 Q
Q
2 ;
Q
3 ;
I DGPTTF="" S DGPTERC=135 Q
Q
4 ;
I DGPTXTTY="" Q
I DGPTSRA="4A"&("110"'[DGPTXTTY) S DGPTERC=135 Q
I DGPTSRA="4C"&(DGPTXTTY'=40) S DGPTERC=135 Q
I "ED"[DGPTS2&(DGPTXTTY'=30) S DGPTERC=135 Q
I DGPTSRA="4F"&((DGPTXTTY'=25)&(DGPTXTTY'=26)) S DGPTERC=135 Q
I DGPTSRA="4H"&(DGPTXTTY'=42) S DGPTERC=135 Q
I DGPTSRA="4K"&(DGPTXTTY'=32) S DGPTERC=135 Q
I DGPTSRA="4L"&(DGPTXTTY'=41) S DGPTERC=135 Q
I DGPTSRA="4M"&((DGPTXTTY'=20)&(DGPTXTTY'=21)&(DGPTXTTY'=22)) S DGPTERC=135 Q
I DGPTSRA="4N"&((DGPTXTTY'=23)&(DGPTXTTY'=24)) S DGPTERC=135 Q
I DGPTSRA="4R"&(DGPTXTTY'=25) S DGPTERC=135 Q
I "GBJPQSTUWY"[DGPTS2&(DGPTXTTY'="") S DGPTERC=135 Q
Q
5 ;
I DGPTXTTY="" Q
I DGPTSRA="5A"&("110"'[DGPTXTTY) S DGPTERC=135 Q
I DGPTSRA="5B"&((DGPTXTTY<20)!(DGPTXTTY>26)) S DGPTERC=135 Q
I DGPTSRA="5C"&(DGPTXTTY'=30) S DGPTERC=135 Q
I "ED"[DGPTS2&(DGPTXTTY'=40) S DGPTERC=135 Q
I DGPTSRA="5F"&(DGPTXTTY'=42) S DGPTERC=135 Q
;- commented out for DG*5.3*58 as XX is not a valid station type
;I DGPTSRA="5G"&(DGPTXTTY'="XX") S DGPTERC=135 Q
Q
6 ;
I DGPTXTTY="" Q
I DGPTSRA="6A"&("110"'[DGPTXTTY) S DGPTERC=135 Q
I DGPTSRA="6B"&(DGPTXTTY'=40) S DGPTERC=135 Q
I DGPTSRA="6C"&(DGPTXTTY'=42) S DGPTERC=135 Q
;- commented out for DG*5.3*58 as XX is not a valid station type
;I DGPTSRA="6D"&(DGPTXTTY'="XX") S DGPTERC=135 Q
Q
7 ;
I DGPTXTTY="" Q
I DGPTSRA="7B"&((DGPTXTTY<20)!(DGPTXTTY>22)) S DGPTERC=135 Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPT10S1 2732 printed Oct 16, 2024@18:51:50 Page 2
DGPT10S1 ;ALB/MTC - Source of Admission Edit ; 13 NOV 92
+1 ;;5.3;Registration;**58**;Aug 13, 1993
+2 ;
+3 ; SET UP TYPE OF FACILITY REPORTING ADMISSION
+4 ; CHECK SOURCE OF ADMISSION FOR CORRECTNESS AND CONSISTENCY WITH STATION TYPE
+5 ; DGPTSTTY=TYPE OF STATION REPORTING EPISODE
+6 ; DGPTXTTY=TYPE OF STATION TRANSFERRING PATIENT IN
EN ;
+1 NEW SUFFIX
+2 SET DGPTXTTY=""
+3 ;I DGPTTF=" " Q
+4 SET SUFFIX=$PIECE($EXTRACT(DGPTTF,4,6)," ")
+5 ;I SUFFIX="" Q
+6 IF SUFFIX]""
IF $DATA(^DIC(45.81,"D1",SUFFIX))
SET DGPTXTTY=$ORDER(^(SUFFIX,0))
LOOP ;
+1 DO EDIT
if DGPTERC
QUIT
+2 DO CONSIS
if DGPTERC
QUIT
EXIT ;
+1 KILL DGPTXTT1
+2 QUIT
EDIT ;
+1 SET DGPTS1=$EXTRACT(DGPTSRA,1)
SET DGPTS2=$EXTRACT(DGPTSRA,2)
+2 IF "1234567"'[DGPTS1
SET DGPTERC=107
QUIT
+3 IF DGPTS1=1&("DEGHJKLMPRST"'[DGPTS2)
SET DGPTERC=107
QUIT
+4 IF DGPTS1=2&("ABC"'[DGPTS2)
SET DGPTERC=107
QUIT
+5 IF DGPTS1=3&("ABCDE"'[DGPTS2)
SET DGPTERC=107
QUIT
+6 IF DGPTS1=4&("ABCDEFGHJKLMNPQRSTUWY"'[DGPTS2)
SET DGPTERC=107
QUIT
+7 IF DGPTS1=5&("ABCDEFG"'[DGPTS2)
SET DGPTERC=107
QUIT
+8 IF DGPTS1=6&("ABCD"'[DGPTS2)
SET DGPTERC=107
QUIT
+9 IF DGPTS1=7&(DGPTS2'="B")
SET DGPTERC=107
QUIT
+10 QUIT
CONSIS ;
+1 DO @DGPTS1
QUIT
1 ;
+1 IF DGPTXTTY=""
QUIT
+2 IF DGPTSRA="1D"&(DGPTXTTY'=40)
SET DGPTERC=135
QUIT
+3 IF DGPTSRA="1E"&(DGPTXTTY'=30)
SET DGPTERC=135
QUIT
+4 IF DGPTSRA="1G"&(DGPTXTTY'=42)
SET DGPTERC=135
QUIT
+5 IF "HJKMP"[DGPTS2&(DGPTXTTY'="")
SET DGPTERC=135
QUIT
+6 QUIT
2 ;
+1 QUIT
3 ;
+1 IF DGPTTF=""
SET DGPTERC=135
QUIT
+2 QUIT
4 ;
+1 IF DGPTXTTY=""
QUIT
+2 IF DGPTSRA="4A"&("110"'[DGPTXTTY)
SET DGPTERC=135
QUIT
+3 IF DGPTSRA="4C"&(DGPTXTTY'=40)
SET DGPTERC=135
QUIT
+4 IF "ED"[DGPTS2&(DGPTXTTY'=30)
SET DGPTERC=135
QUIT
+5 IF DGPTSRA="4F"&((DGPTXTTY'=25)&(DGPTXTTY'=26))
SET DGPTERC=135
QUIT
+6 IF DGPTSRA="4H"&(DGPTXTTY'=42)
SET DGPTERC=135
QUIT
+7 IF DGPTSRA="4K"&(DGPTXTTY'=32)
SET DGPTERC=135
QUIT
+8 IF DGPTSRA="4L"&(DGPTXTTY'=41)
SET DGPTERC=135
QUIT
+9 IF DGPTSRA="4M"&((DGPTXTTY'=20)&(DGPTXTTY'=21)&(DGPTXTTY'=22))
SET DGPTERC=135
QUIT
+10 IF DGPTSRA="4N"&((DGPTXTTY'=23)&(DGPTXTTY'=24))
SET DGPTERC=135
QUIT
+11 IF DGPTSRA="4R"&(DGPTXTTY'=25)
SET DGPTERC=135
QUIT
+12 IF "GBJPQSTUWY"[DGPTS2&(DGPTXTTY'="")
SET DGPTERC=135
QUIT
+13 QUIT
5 ;
+1 IF DGPTXTTY=""
QUIT
+2 IF DGPTSRA="5A"&("110"'[DGPTXTTY)
SET DGPTERC=135
QUIT
+3 IF DGPTSRA="5B"&((DGPTXTTY<20)!(DGPTXTTY>26))
SET DGPTERC=135
QUIT
+4 IF DGPTSRA="5C"&(DGPTXTTY'=30)
SET DGPTERC=135
QUIT
+5 IF "ED"[DGPTS2&(DGPTXTTY'=40)
SET DGPTERC=135
QUIT
+6 IF DGPTSRA="5F"&(DGPTXTTY'=42)
SET DGPTERC=135
QUIT
+7 ;- commented out for DG*5.3*58 as XX is not a valid station type
+8 ;I DGPTSRA="5G"&(DGPTXTTY'="XX") S DGPTERC=135 Q
+9 QUIT
6 ;
+1 IF DGPTXTTY=""
QUIT
+2 IF DGPTSRA="6A"&("110"'[DGPTXTTY)
SET DGPTERC=135
QUIT
+3 IF DGPTSRA="6B"&(DGPTXTTY'=40)
SET DGPTERC=135
QUIT
+4 IF DGPTSRA="6C"&(DGPTXTTY'=42)
SET DGPTERC=135
QUIT
+5 ;- commented out for DG*5.3*58 as XX is not a valid station type
+6 ;I DGPTSRA="6D"&(DGPTXTTY'="XX") S DGPTERC=135 Q
+7 QUIT
7 ;
+1 IF DGPTXTTY=""
QUIT
+2 IF DGPTSRA="7B"&((DGPTXTTY<20)!(DGPTXTTY>22))
SET DGPTERC=135
QUIT
+3 QUIT
