source: WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUTMG145.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: 698 bytes
Line 
1XUTMG145 ;SEA/RDS - TaskMan: Globals: Code for File 14.5 ;5/17/91 12:54 ;
2 ;;8.0;KERNEL;;Jul 10, 1995
3 ;
4 Q
5 ;
6IT01 ;input transform for field .01
7 I $L(X)>30!($L(X)<2)!'(X'?1P.E) K X Q
8 I $D(DA)#2,DA]"",$D(^%ZIS(14.5,DA,0))#2,$P(^(0),U)=X Q
9 I $O(^%ZIS(14.5,"B",X,""))]"" K X S ZTUNIQUE=0 Q
10 Q
11 ;
12S01 ;set statement for field .01
13 N DIG,DIH,DIU,DIV,ZT,ZT1,ZTDA,ZTD0,ZTS,ZTX
14 S ZTX=X,ZTDA=DA,DIH=14.6
15 S ZT1="" F ZT=0:0 S ZT1=$O(^%ZIS(14.6,ZT1)) Q:ZT1="" I $D(^%ZIS(14.6,ZT1,0))#2 S ZTS=^(0) D S01A
16 S X=ZTX,DA=ZTDA Q
17 ;
18S01A ;S01--re-crossreference appropriate fields
19 S DA=ZT1,D0=ZT1,DIV(0)=DA,DIU=ZTDA,DIV=ZTDA
20 I $P(ZTS,U,5)=ZTDA S DIG=1 D ^DICR Q
21 I $P(ZTS,U,6)=ZTDA S DIG=2 D ^DICR Q
22 Q
23 ;
Note: See TracBrowser for help on using the repository browser.