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))
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HTIUPNCVX 3443 printed Apr 09, 2024@21:48:13 Page 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
