- 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 Jan 18, 2025@03:51:57 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