Routine: TIUPNCVX

TIUPNCVX ;SF/JLI ;PNs ==> TIU cnv rtns ;5-7-97

 ;;1.0;TEXT INTEGRATION UTILITIES;;Jun 20, 1997

 ;set x-refs for conversion

ENTRY ;

 S DA=TIUIFN,TIU0=$G(^TIU(8925,TIUIFN,0)),TIU13=$G(^(13))

 S TIU12=$G(^(12)),TIU15=$G(^(15))

 S TIURDATE=9999999-TIU13

 S ^TIU(8925,"B",$P(TIU0,U),DA)=""

 I +TIU13 D

 . I +$P(TIU0,U,5) D

 . . S ^TIU(8925,"ALL","ANY",+TIU0,+$P(TIU0,U,5),TIURDATE,DA)=""

 . . I +$P(TIU0,U,2) S ^TIU(8925,"APT",+$P(TIU0,U,2),+TIU0,+$P(TIU0,U,5),TIURDATE,DA)=""

 . . I +$P(TIU0,U,3) S ^TIU(8925,"AVSIT",+$P(TIU0,U,3),+TIU0,+$P(TIU0,U,5),TIURDATE,DA)=""

 . . I +$P(TIU12,U,2) S ^TIU(8925,"AAU",+$P(TIU12,U,2),+TIU0,+$P(TIU0,U,5),TIURDATE,DA)=""

 . . I +$P(TIU12,U,5) S ^TIU(8925,"ALOC",+$P(TIU12,U,5),+TIU0,+$P(TIU0,U,5),TIURDATE,DA)=""

 . . I +$P(TIU12,U,8) S ^TIU(8925,"ASUP",+$P(TIU12,U,8),+TIU0,+$P(TIU0,U,5),TIURDATE,DA)=""

 . . I +$P(TIU13,U,2) S ^TIU(8925,"ATC",+$P(TIU13,U,2),+TIU0,+$P(TIU0,U,5),TIURDATE,DA)=""

 . . I +$O(^TIU(8925.9,"B",DA,0)) D APRBS^TIUDD(+TIU0,+$P(TIU0,U,5),TIURDATE,DA)

 . I +$P(TIU0,U,2) S ^TIU(8925,"APTCL",+$P(TIU0,U,2),+$$CLINDOC^TIULC1(+TIU0,DA),TIURDATE,DA)=""

 . I +$P(TIU0,U,2) S ^TIU(8925,"APTCL",+$P(TIU0,U,2),38,TIURDATE,DA)=""

 I $P($$DOCTYPE^TIULF(DA),U)="DOC",+$P(TIU0,U,2),+$P(TIU0,U,3) D

 . S ^TIU(8925,"AV",+$P(TIU0,U,2),+TIU0,+$P(TIU0,U,3),DA)=""

 . S ^TIU(8925,"AA",+$P(TIU0,U,2),+TIU0,(9999999-$P(+^AUPNVSIT(+$P(TIU0,U,3),0),".")),DA)=""

 . S ^TIU(8925,"AE",+$P(TIU0,U,2),(9999999-$P(+^AUPNVSIT(+$P(TIU0,U,3),0),".")),+TIU0,DA)=""

 I $P(TIU0,U,2)'="" D

 . S ^TIU(8925,"C",$P(TIU0,U,2),DA)=""

 . I +$$APTP^TIULX(DA),+TIU15 S ^TIU(8925,"APTP",+$P(TIU0,U,2),+TIU15,DA)=""

 . I +$P(TIU0,U,4),+TIU13,+$P(TIU0,U,5) S ^TIU(8925,"ADCPT",+$P(TIU0,U,2),+$P(TIU0,U,4),+$P(TIU0,U,5),TIURDATE,DA)=""

 I $P(TIU0,U,3)'="" D

 . S X=$P(TIU0,U,3)

 . D:$D(^AUPNVSIT(+$P(TIU0,U,3))) ADD^AUPNVSIT

 . S ^TIU(8925,"V",$P(TIU0,U,3),DA)=""

 . X ^DD(8925,.03,1,7,1) ; TRIGGER

 . S DA=TIUIFN

 I $P(TIU0,U,6)'="" S ^TIU(8925,"DAD",$P(TIU0,U,6),DA)=""

 I $P(TIU0,U,12)'="" S ^TIU(8925,"FIX",$P(TIU0,U,12),DA)=""

 I $P(TIU12,U)'="" S ^TIU(8925,"F",$P(TIU12,U),DA)=""

 I $P(TIU12,U,2)'="" D

 . S ^TIU(8925,"CA",$P(TIU12,U,2),DA)=""

 . I +$$AAUP^TIULX(DA),+TIU15 S ^TIU(8925,"AAUP",+$P(TIU12,U,2),+TIU15,DA)=""

 I $P(TIU12,U,5)'="",+$$ALOCP^TIULX(DA),+TIU15 S ^TIU(8925,"ALOCP",+$P(TIU12,U,5),+TIU15,DA)=""

 I $P(TIU12,U,8)'="" S ^TIU(8925,"CS",$P(TIU12,U,8),DA)=""

 I $P(TIU13,U)'="" S ^TIU(8925,"D",$P(TIU13,U),DA)=""

 I $P(TIU13,U,2)'="" S ^TIU(8925,"TC",$P(TIU13,U,2),DA)=""

 I $P(TIU13,U,4)'="" S ^TIU(8925,"E",$P(TIU13,U,4),DA)=""

 S X=$P($G(^TIU(8925,DA,150)),U)

 I X'="" S ^TIU(8925,"VID",$E(X,1,30),DA)=""

 I +TIU0'=81 D SACLPT^TIUDD0(.02,$P(TIU0,U,2))

 I $P(TIU15,U)'>0 D SACLAU^TIUDD0(1202,$P(TIU12,U,2)),SACLAU1^TIUDD0(1302,$P(TIU13,U,2))

 I '$P(TIU15,U,7),($P(TIU0,U,5)<7) D

 . I $P(TIU0,U,5)=6 D SACLEC^TIUDD0(1208,$P(TIU12,U,8)) I 1

 . E  I $P(TIU0,U,5)>4 D SACLEC^TIUDD0(1208,$P(TIU12,U,8))

 I +TIU0'=81,$P(TIU15,U,2)>0 D SACLSB^TIUDD0(1502,$P(TIU15,U,2))

 I $P(TIU0,U,7)'>0 S $P(^(0),U,7)=+$G(^TIU(8925,DA,13))

 I $P(TIU12,U,5)'>0 S VTYPE="E"

 E  S VLOC=+$P(TIU12,U,5),STOP=+$P(^SC(VLOC,0),U,7) D

 . I STOP>0 S STOP=$P(^DIC(40.7,STOP,0),U) S VTYPE=$S(STOP["TELE":"T",1:"A") I 1

 . E  D

 . . I $P(^SC(VLOC,0),U,3)="W" S VTYPE="H"

 . . E  S VTYPE="E"

 . S $P(^TIU(8925,DA,0),U,13)=VTYPE

 D SAPTLD^TIUDD0(.02,$P(TIU0,U,2))

TIUPNCVX  ;SF/JLI ;PNs ==> TIU cnv rtns ;5-7-97

 +1       ;;1.0;TEXT INTEGRATION UTILITIES;;Jun 20, 1997

 +2       ;

 +3       ;set x-refs for conversion

ENTRY     ;

 +1        SET DA=TIUIFN

           SET TIU0=$GET(^TIU(8925,TIUIFN,0))

           SET TIU13=$GET(^(13))

 +2        SET TIU12=$GET(^(12))

           SET TIU15=$GET(^(15))

 +3        SET TIURDATE=9999999-TIU13

 +4        SET ^TIU(8925,"B",$PIECE(TIU0,U),DA)=""

 +5        IF +TIU13

               Begin DoDot:1

 +6                IF +$PIECE(TIU0,U,5)

                       Begin DoDot:2

 +7                        SET ^TIU(8925,"ALL","ANY",+TIU0,+$PIECE(TIU0,U,5),TIURDATE,DA)=""

 +8                        IF +$PIECE(TIU0,U,2)

                               SET ^TIU(8925,"APT",+$PIECE(TIU0,U,2),+TIU0,+$PIECE(TIU0,U,5),TIURDATE,DA)=""

 +9                        IF +$PIECE(TIU0,U,3)

                               SET ^TIU(8925,"AVSIT",+$PIECE(TIU0,U,3),+TIU0,+$PIECE(TIU0,U,5),TIURDATE,DA)=""

 +10                       IF +$PIECE(TIU12,U,2)

                               SET ^TIU(8925,"AAU",+$PIECE(TIU12,U,2),+TIU0,+$PIECE(TIU0,U,5),TIURDATE,DA)=""

 +11                       IF +$PIECE(TIU12,U,5)

                               SET ^TIU(8925,"ALOC",+$PIECE(TIU12,U,5),+TIU0,+$PIECE(TIU0,U,5),TIURDATE,DA)=""

 +12                       IF +$PIECE(TIU12,U,8)

                               SET ^TIU(8925,"ASUP",+$PIECE(TIU12,U,8),+TIU0,+$PIECE(TIU0,U,5),TIURDATE,DA)=""

 +13                       IF +$PIECE(TIU13,U,2)

                               SET ^TIU(8925,"ATC",+$PIECE(TIU13,U,2),+TIU0,+$PIECE(TIU0,U,5),TIURDATE,DA)=""

 +14                       IF +$ORDER(^TIU(8925.9,"B",DA,0))

                               DO APRBS^TIUDD(+TIU0,+$PIECE(TIU0,U,5),TIURDATE,DA)

                       End DoDot:2

 +15               IF +$PIECE(TIU0,U,2)

                       SET ^TIU(8925,"APTCL",+$PIECE(TIU0,U,2),+$$CLINDOC^TIULC1(+TIU0,DA),TIURDATE,DA)=""

 +16               IF +$PIECE(TIU0,U,2)

                       SET ^TIU(8925,"APTCL",+$PIECE(TIU0,U,2),38,TIURDATE,DA)=""

               End DoDot:1

 +17       IF $PIECE($$DOCTYPE^TIULF(DA),U)="DOC"

               IF +$PIECE(TIU0,U,2)

                   IF +$PIECE(TIU0,U,3)

                       Begin DoDot:1

 +18                       SET ^TIU(8925,"AV",+$PIECE(TIU0,U,2),+TIU0,+$PIECE(TIU0,U,3),DA)=""

 +19                       SET ^TIU(8925,"AA",+$PIECE(TIU0,U,2),+TIU0,(9999999-$PIECE(+^AUPNVSIT(+$PIECE(TIU0,U,3),0),".")),DA)=""

 +20                       SET ^TIU(8925,"AE",+$PIECE(TIU0,U,2),(9999999-$PIECE(+^AUPNVSIT(+$PIECE(TIU0,U,3),0),".")),+TIU0,DA)=""

                       End DoDot:1

 +21      ;

 +22       IF $PIECE(TIU0,U,2)'=""

               Begin DoDot:1

 +23               SET ^TIU(8925,"C",$PIECE(TIU0,U,2),DA)=""

 +24               IF +$$APTP^TIULX(DA)

                       IF +TIU15

                           SET ^TIU(8925,"APTP",+$PIECE(TIU0,U,2),+TIU15,DA)=""

 +25               IF +$PIECE(TIU0,U,4)

                       IF +TIU13

                           IF +$PIECE(TIU0,U,5)

                               SET ^TIU(8925,"ADCPT",+$PIECE(TIU0,U,2),+$PIECE(TIU0,U,4),+$PIECE(TIU0,U,5),TIURDATE,DA)=""

               End DoDot:1

 +26      ;

 +27       IF $PIECE(TIU0,U,3)'=""

               Begin DoDot:1

 +28               SET X=$PIECE(TIU0,U,3)

 +29               IF $DATA(^AUPNVSIT(+$PIECE(TIU0,U,3)))

                       DO ADD^AUPNVSIT

 +30               SET ^TIU(8925,"V",$PIECE(TIU0,U,3),DA)=""

 +31      ; TRIGGER

                   XECUTE ^DD(8925,.03,1,7,1)

 +32               SET DA=TIUIFN

               End DoDot:1

 +33       IF $PIECE(TIU0,U,6)'=""

               SET ^TIU(8925,"DAD",$PIECE(TIU0,U,6),DA)=""

 +34       IF $PIECE(TIU0,U,12)'=""

               SET ^TIU(8925,"FIX",$PIECE(TIU0,U,12),DA)=""

 +35       IF $PIECE(TIU12,U)'=""

               SET ^TIU(8925,"F",$PIECE(TIU12,U),DA)=""

 +36       IF $PIECE(TIU12,U,2)'=""

               Begin DoDot:1

 +37               SET ^TIU(8925,"CA",$PIECE(TIU12,U,2),DA)=""

 +38               IF +$$AAUP^TIULX(DA)

                       IF +TIU15

                           SET ^TIU(8925,"AAUP",+$PIECE(TIU12,U,2),+TIU15,DA)=""

               End DoDot:1

 +39       IF $PIECE(TIU12,U,5)'=""

               IF +$$ALOCP^TIULX(DA)

                   IF +TIU15

                       SET ^TIU(8925,"ALOCP",+$PIECE(TIU12,U,5),+TIU15,DA)=""

 +40       IF $PIECE(TIU12,U,8)'=""

               SET ^TIU(8925,"CS",$PIECE(TIU12,U,8),DA)=""

 +41       IF $PIECE(TIU13,U)'=""

               SET ^TIU(8925,"D",$PIECE(TIU13,U),DA)=""

 +42       IF $PIECE(TIU13,U,2)'=""

               SET ^TIU(8925,"TC",$PIECE(TIU13,U,2),DA)=""

 +43       IF $PIECE(TIU13,U,4)'=""

               SET ^TIU(8925,"E",$PIECE(TIU13,U,4),DA)=""

 +44       SET X=$PIECE($GET(^TIU(8925,DA,150)),U)

 +45       IF X'=""

               SET ^TIU(8925,"VID",$EXTRACT(X,1,30),DA)=""

 +46       IF +TIU0'=81

               DO SACLPT^TIUDD0(.02,$PIECE(TIU0,U,2))

 +47       IF $PIECE(TIU15,U)'>0

               DO SACLAU^TIUDD0(1202,$PIECE(TIU12,U,2))

               DO SACLAU1^TIUDD0(1302,$PIECE(TIU13,U,2))

 +48       IF '$PIECE(TIU15,U,7)

               IF ($PIECE(TIU0,U,5)<7)

                   Begin DoDot:1

 +49                   IF $PIECE(TIU0,U,5)=6

                           DO SACLEC^TIUDD0(1208,$PIECE(TIU12,U,8))

                           IF 1

 +50                  IF '$TEST

                           IF $PIECE(TIU0,U,5)>4

                               DO SACLEC^TIUDD0(1208,$PIECE(TIU12,U,8))

                   End DoDot:1

 +51       IF +TIU0'=81

               IF $PIECE(TIU15,U,2)>0

                   DO SACLSB^TIUDD0(1502,$PIECE(TIU15,U,2))

 +52       IF $PIECE(TIU0,U,7)'>0

               SET $PIECE(^(0),U,7)=+$GET(^TIU(8925,DA,13))

 +53       IF $PIECE(TIU12,U,5)'>0

               SET VTYPE="E"

 +54      IF '$TEST

               SET VLOC=+$PIECE(TIU12,U,5)

               SET STOP=+$PIECE(^SC(VLOC,0),U,7)

               Begin DoDot:1

 +55               IF STOP>0

                       SET STOP=$PIECE(^DIC(40.7,STOP,0),U)

                       SET VTYPE=$SELECT(STOP["TELE":"T",1:"A")

                       IF 1

 +56              IF '$TEST

                       Begin DoDot:2

 +57                       IF $PIECE(^SC(VLOC,0),U,3)="W"

                               SET VTYPE="H"

 +58                      IF '$TEST

                               SET VTYPE="E"

                       End DoDot:2

 +59               SET $PIECE(^TIU(8925,DA,0),U,13)=VTYPE

               End DoDot:1

 +60       DO SAPTLD^TIUDD0(.02,$PIECE(TIU0,U,2))

 +61       QUIT

TIUPNCVX.m