- 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 Mar 13, 2025@21:18:07 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 ;
