XUTMG145.m

XUTMG145 ;SEA/RDS - TaskMan: Globals: Code for File 14.5 ;5/17/91  12:54 ; [ 04/02/2003   8:29 AM ]

 ;;8.0;KERNEL;**1002,1003,1004,1005,1007**;APR 1, 2003

 ;;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

 ;

XUTMG145  ;SEA/RDS - TaskMan: Globals: Code for File 14.5 ;5/17/91  12:54 ; [ 04/02/2003   8:29 AM ]

 +1       ;;8.0;KERNEL;**1002,1003,1004,1005,1007**;APR 1, 2003

 +2       ;;8.0;KERNEL;;Jul 10, 1995

 +3       ;

 +4        QUIT 

 +5       ;

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       ;