XUTMG145 ;SEA/RDS - TaskMan: Globals: Code for File 14.5 ;5/17/91 12:54 ;
;;8.0;KERNEL;;Jul 10, 1995
;
Q
;
IT01 ;input transform for field .01
I $L(X)>30!($L(X)<2)!'(X'?1P.E) K X Q
I $D(DA)#2,DA]"",$D(^%ZIS(14.5,DA,0))#2,$P(^(0),U)=X Q
I $O(^%ZIS(14.5,"B",X,""))]"" K X S ZTUNIQUE=0 Q
Q
;
S01 ;set statement for field .01
N DIG,DIH,DIU,DIV,ZT,ZT1,ZTDA,ZTD0,ZTS,ZTX
S ZTX=X,ZTDA=DA,DIH=14.6
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
S X=ZTX,DA=ZTDA Q
;
S01A ;S01--re-crossreference appropriate fields
S DA=ZT1,D0=ZT1,DIV(0)=DA,DIU=ZTDA,DIV=ZTDA
I $P(ZTS,U,5)=ZTDA S DIG=1 D ^DICR Q
I $P(ZTS,U,6)=ZTDA S DIG=2 D ^DICR Q
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXUTMG145 721 printed Dec 13, 2024@02:13:13 Page 2
XUTMG145 ;SEA/RDS - TaskMan: Globals: Code for File 14.5 ;5/17/91 12:54 ;
+1 ;;8.0;KERNEL;;Jul 10, 1995
+2 ;
+3 QUIT
+4 ;
IT01 ;input transform for field .01
+1 IF $LENGTH(X)>30!($LENGTH(X)<2)!'(X'?1P.E)
KILL X
QUIT
+2 IF $DATA(DA)#2
IF DA]""
IF $DATA(^%ZIS(14.5,DA,0))#2
IF $PIECE(^(0),U)=X
QUIT
+3 IF $ORDER(^%ZIS(14.5,"B",X,""))]""
KILL X
SET ZTUNIQUE=0
QUIT
+4 QUIT
+5 ;
S01 ;set statement for field .01
+1 NEW DIG,DIH,DIU,DIV,ZT,ZT1,ZTDA,ZTD0,ZTS,ZTX
+2 SET ZTX=X
SET ZTDA=DA
SET DIH=14.6
+3 SET ZT1=""
FOR ZT=0:0
SET ZT1=$ORDER(^%ZIS(14.6,ZT1))
if ZT1=""
QUIT
IF $DATA(^%ZIS(14.6,ZT1,0))#2
SET ZTS=^(0)
DO S01A
+4 SET X=ZTX
SET DA=ZTDA
QUIT
+5 ;
S01A ;S01--re-crossreference appropriate fields
+1 SET DA=ZT1
SET D0=ZT1
SET DIV(0)=DA
SET DIU=ZTDA
SET DIV=ZTDA
+2 IF $PIECE(ZTS,U,5)=ZTDA
SET DIG=1
DO ^DICR
QUIT
+3 IF $PIECE(ZTS,U,6)=ZTDA
SET DIG=2
DO ^DICR
QUIT
+4 QUIT
+5 ;
