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

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

initial load of WorldVistAEHR

File size: 3.0 KB
Line 
1DGPMTSI ;ALB/LM - TREATING SPECIALTY INPATIENT INFO ; 6/15/93
2 ;;5.3;Registration;**76**;Aug 13, 1993
3 ;
4START I $D(IO("Q")) S DGTSDT=ZTSAVE("DGTSDT"),PTLWD=ZTSAVE("PTLWD"),PTLTS=ZTSAVE("PTLTS"),PTCTS=ZTSAVE("PTCTS")
5 S (DGT,Y)=DGTSDT
6 X ^DD("DD") S DGTSDT=Y
7 F DFN=0:0 S DFN=$O(^DPT(DFN)) Q:'DFN S DGTS=0,DGXFR0="" D EN ; I DG1 D TREAT,START^DGPMTSI1,START^DGPMTSI2
8 D START^DGPMTSO
9 Q
10EN ; -- call to return coresp adm and mvt data of pt as of a date
11 ; input: DFN => patient file ifn
12 ; DGT => date to check if pt was inpatient
13 ; output: DGA1 => coresp adm mvt ifn of ^DGPM
14 ; DG1 => ward ^ room-bed ^ mvt type(for xfrs only)
15 ; DGXFR0 => Oth of last xfr mvt for admission
16 ; -- init
17 K MT,IAD,IMD,DGCA,DGDC ; Inverse Adm Date & Inverse Mvt Date
18 S DG1=""
19 ;
20 ; -- scan adms for pt
21 ; -- if still inpt or d/c > DGT date then continue to CA
22F F IAD=9999999.9999998-DGT:0 S IAD=$O(^DGPM("ATID1",DFN,IAD)) Q:'IAD S DGA1=$O(^DGPM("ATID1",DFN,IAD,0)) I DGA1]"" S DGCA=$G(^DGPM(DGA1,0)),DGDC=$G(^DGPM(+$P(DGCA,U,17),0)),DGTS=+$P(DGCA,U,9) D ; Q:DG1!($P(DGCA,U,18)'=40)
23 .I 'DGDC!(DGDC>DGT) D CA ; I $P(%,"^",18)=43!($P(%,"^",18)=45) S DG1="" Q ; -- set DG1="" if XFR is 43=to asih (other fac) or XFR is 45=change asih location (other fac)
24 K DGNO Q
25 ;
26CA ; -- scan mvts for cor. adm that happened on or before DGT date
27 ; -- if mvt is adm or xfr then set DG1
28 ; -- if mvt is xfr then continue to XFR
29 ;F IMD=9999999.9999998-DGT:0 S IMD=$O(^DGPM("APMV",DFN,DGA1,IMD)) Q:'IMD I $D(^DGPM(+$O(^(IMD,0)),0)) S %=^(0),MT=$P(%,"^",2) Q:$P(%,"^",18)=43 I MT=1!(MT=2) S DG1=$P(%,"^",6,7) D XFR:MT=2 Q:DG1
30 F IMD=9999999.9999998-DGT:0 S IMD=$O(^DGPM("APMV",DFN,DGA1,IMD)) Q:'IMD I $D(^DGPM(+$O(^(IMD,0)),0)) S %=^(0),MT=$P(%,"^",2) S:$P(%,"^",9)]"" DGS=$P(%,"^",9),DGTS=DGS S DGW=$P(%,"^",6) I MT=1!(MT=2) S DG1=$P(%,"^",6,7) D XFR:MT=2 Q:DG1
31 I DG1 D TREAT,START^DGPMTSI1,START^DGPMTSI2
32 I $P(DG1,"^",3)=13!($P(DG1,"^",3)=44) S DG1=""
33CAQ Q
34 ;
35XFR ; -- set DG1="" if XFR to asih(oth fac) --ELSE-- add MVT type to DG1
36 ;S DGXFR0=%,DG1=$S($P(%,"^",18)=13:"",1:DG1_"^"_$P(%,"^",18))
37 S DGXFR0=%,DG1=DG1_"^"_$P(%,"^",18)
38 ;I $P(%,"^",18)=13 S %=$O(^DGPM("APMV",DFN,DGA1,IMD)) I $D(^DGPM(+$O(^(%,0)),0)) S DGW=$P(^(0),"^",6)
39 I $P(%,"^",18)=13!($P(%,"^",18)=44) D
40 . N DGPMNI,DGPMTN,DGPMAB
41 . S DGPMNI=DGA1,DGPMTN=%
42 . D FINDLAST^DGPMV32 ; gets date/time which initiated ASIH (either to asih or to asih (other))
43 . S %=$O(^DGPM("APMV",DFN,DGA1,9999999.9999999-DGPMAB)) I $D(^DGPM(+$O(^(%,0)),0)) S DGW=$P(^(0),"^",6)
44 Q
45 ;
46TREAT Q:'DG1
47 S DG2=9999999 D TREAT1
48 I +DG2=9999999 S DG2=0 Q
49 S DG2=$S($D(^DIC(45.7,+DG2,0)):+$P(^(0),U,2),1:0)
50 Q
51TREAT1 S TSXDT="" F DGID=0:0 S DGID=$O(^DGPM("ATS",DFN,DGA1,DGID)) Q:'DGID F DGS=0:0 S DGS=$O(^DGPM("ATS",DFN,DGA1,DGID,DGS)) Q:'DGS F DGDA=0:0 S DGDA=$O(^DGPM("ATS",DFN,DGA1,DGID,DGS,DGDA)) Q:'DGDA I $D(^DGPM(+DGDA,0)) S DGX=^(0) D TR2
52 Q
53TR2 I +DGX<(DGT+.1)&(+DGX<+DG2) S DG2=DGS,DGTS=DGS I +$P(DGX,"^")>+$P(DGCA,"^") S Y=$P(DGX,"^") X ^DD("DD") S TSXDT=Y
54 I $P(DGX,"^",6)]"" S DGW=$P(DGX,"^",6)
55 Q
Note: See TracBrowser for help on using the repository browser.