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

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

initial load of WorldVistAEHR

File size: 1.2 KB
RevLine 
[613]1DGPMTSI1 ;ALB/LM - TREATING SPECIALTY INPATIENT SET ; 3/10/93
2 ;;5.3;Registration;;Aug 13, 1993
3 ;
4 Q
5START S DIV=$S($P(^DIC(42,+DGW,0),"^",11)]"":$P(^DIC(42,+DGW,0),"^",11),1:0)
6 S DIV=$S($D(^DG(40.8,DIV,0)):DIV,1:0)
7 ;
8 S WARD=$S($D(^DIC(42,+DGW,0)):$P(^(0),"^"),1:+DGW)
9 ;
10 S TREAT=$S($D(^DIC(45.7,DGTS,0)):$P(^(0),"^"),1:"UNKNOWN")
11 I TREAT="UNKNOWN" S DGTS=9999999999
12 ;
13 S (PASS,AA,UA,ASIH)=0,MVT=""
14 ;
15MVT I $D(DGXFR0) S MVT=$P(DGXFR0,"^",18)
16 I MVT=1 S PASS=1,MVT="PASS"
17 I MVT=2!(MVT=26) S AA=1,MVT="AA"
18 I MVT=3!(MVT=25) S UA=1,MVT="UA"
19 I "^13^43^44^45^"[("^"_MVT_"^") S ASIH=1,MVT="ASIH"
20 I MVT'["A" S MVT="" ; if not one of the above absence reset to null
21 ;
22PT S PT=$P(^DPT(DFN,0),"^")
23 S Y=+$P(DGCA,"^") X ^DD("DD") S ADMDT=$P(Y,"@")
24 ;
25 I DGTS=9999999999 S SV=0 Q
26 ;
27SV S SV=$S($D(^DIC(42.4,$P(^DIC(45.7,DGTS,0),"^",2),0)):$P(^DIC(42.4,$P(^DIC(45.7,DGTS,0),"^",2),0),"^",3),1:0)
28 ;
29 I SV=0 Q
30 ;
31 S S=SV
32 ;
33 S SV=$S(S="M":"MEDICINE",S="S":"SURGERY",S="P":"PSYCHIATRY",S="NH":"NHCU",S="NE":"NEUROLOGY",S="I":"INTERMEDIATE MED",S="R":"REHAB MEDICINE",S="SCI":"SPINAL CORD INJURY",S="D":"DOMICILIARY",S="B":"BLIND REHAB",S="RE":"RESPITE CARE",1:"")
34 ;
35END K DG2,DGA1,DGDA,DGID,DGS,DGX,DGXFR0,TSXDT,S,Y Q
Note: See TracBrowser for help on using the repository browser.