Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: DGPT10S1

DGPT10S1.m

Go to the documentation of this file.
  1. DGPT10S1 ;ALB/MTC - Source of Admission Edit ; 13 NOV 92
  1. ;;5.3;Registration;**58**;Aug 13, 1993
  1. ;
  1. ; SET UP TYPE OF FACILITY REPORTING ADMISSION
  1. ; CHECK SOURCE OF ADMISSION FOR CORRECTNESS AND CONSISTENCY WITH STATION TYPE
  1. ; DGPTSTTY=TYPE OF STATION REPORTING EPISODE
  1. ; DGPTXTTY=TYPE OF STATION TRANSFERRING PATIENT IN
  1. EN ;
  1. N SUFFIX
  1. S DGPTXTTY=""
  1. ;I DGPTTF=" " Q
  1. S SUFFIX=$P($E(DGPTTF,4,6)," ")
  1. ;I SUFFIX="" Q
  1. I SUFFIX]"" I $D(^DIC(45.81,"D1",SUFFIX)) S DGPTXTTY=$O(^(SUFFIX,0))
  1. LOOP ;
  1. D EDIT Q:DGPTERC
  1. D CONSIS Q:DGPTERC
  1. EXIT ;
  1. K DGPTXTT1
  1. Q
  1. EDIT ;
  1. S DGPTS1=$E(DGPTSRA,1),DGPTS2=$E(DGPTSRA,2)
  1. I "1234567"'[DGPTS1 S DGPTERC=107 Q
  1. I DGPTS1=1&("DEGHJKLMPRST"'[DGPTS2) S DGPTERC=107 Q
  1. I DGPTS1=2&("ABC"'[DGPTS2) S DGPTERC=107 Q
  1. I DGPTS1=3&("ABCDE"'[DGPTS2) S DGPTERC=107 Q
  1. I DGPTS1=4&("ABCDEFGHJKLMNPQRSTUWY"'[DGPTS2) S DGPTERC=107 Q
  1. I DGPTS1=5&("ABCDEFG"'[DGPTS2) S DGPTERC=107 Q
  1. I DGPTS1=6&("ABCD"'[DGPTS2) S DGPTERC=107 Q
  1. I DGPTS1=7&(DGPTS2'="B") S DGPTERC=107 Q
  1. Q
  1. CONSIS ;
  1. D @DGPTS1 Q
  1. 1 ;
  1. I DGPTXTTY="" Q
  1. I DGPTSRA="1D"&(DGPTXTTY'=40) S DGPTERC=135 Q
  1. I DGPTSRA="1E"&(DGPTXTTY'=30) S DGPTERC=135 Q
  1. I DGPTSRA="1G"&(DGPTXTTY'=42) S DGPTERC=135 Q
  1. I "HJKMP"[DGPTS2&(DGPTXTTY'="") S DGPTERC=135 Q
  1. Q
  1. 2 ;
  1. Q
  1. 3 ;
  1. I DGPTTF="" S DGPTERC=135 Q
  1. Q
  1. 4 ;
  1. I DGPTXTTY="" Q
  1. I DGPTSRA="4A"&("110"'[DGPTXTTY) S DGPTERC=135 Q
  1. I DGPTSRA="4C"&(DGPTXTTY'=40) S DGPTERC=135 Q
  1. I "ED"[DGPTS2&(DGPTXTTY'=30) S DGPTERC=135 Q
  1. I DGPTSRA="4F"&((DGPTXTTY'=25)&(DGPTXTTY'=26)) S DGPTERC=135 Q
  1. I DGPTSRA="4H"&(DGPTXTTY'=42) S DGPTERC=135 Q
  1. I DGPTSRA="4K"&(DGPTXTTY'=32) S DGPTERC=135 Q
  1. I DGPTSRA="4L"&(DGPTXTTY'=41) S DGPTERC=135 Q
  1. I DGPTSRA="4M"&((DGPTXTTY'=20)&(DGPTXTTY'=21)&(DGPTXTTY'=22)) S DGPTERC=135 Q
  1. I DGPTSRA="4N"&((DGPTXTTY'=23)&(DGPTXTTY'=24)) S DGPTERC=135 Q
  1. I DGPTSRA="4R"&(DGPTXTTY'=25) S DGPTERC=135 Q
  1. I "GBJPQSTUWY"[DGPTS2&(DGPTXTTY'="") S DGPTERC=135 Q
  1. Q
  1. 5 ;
  1. I DGPTXTTY="" Q
  1. I DGPTSRA="5A"&("110"'[DGPTXTTY) S DGPTERC=135 Q
  1. I DGPTSRA="5B"&((DGPTXTTY<20)!(DGPTXTTY>26)) S DGPTERC=135 Q
  1. I DGPTSRA="5C"&(DGPTXTTY'=30) S DGPTERC=135 Q
  1. I "ED"[DGPTS2&(DGPTXTTY'=40) S DGPTERC=135 Q
  1. I DGPTSRA="5F"&(DGPTXTTY'=42) S DGPTERC=135 Q
  1. ;- commented out for DG*5.3*58 as XX is not a valid station type
  1. ;I DGPTSRA="5G"&(DGPTXTTY'="XX") S DGPTERC=135 Q
  1. Q
  1. 6 ;
  1. I DGPTXTTY="" Q
  1. I DGPTSRA="6A"&("110"'[DGPTXTTY) S DGPTERC=135 Q
  1. I DGPTSRA="6B"&(DGPTXTTY'=40) S DGPTERC=135 Q
  1. I DGPTSRA="6C"&(DGPTXTTY'=42) S DGPTERC=135 Q
  1. ;- commented out for DG*5.3*58 as XX is not a valid station type
  1. ;I DGPTSRA="6D"&(DGPTXTTY'="XX") S DGPTERC=135 Q
  1. Q
  1. 7 ;
  1. I DGPTXTTY="" Q
  1. I DGPTSRA="7B"&((DGPTXTTY<20)!(DGPTXTTY>22)) S DGPTERC=135 Q
  1. Q