A1B2T1 ;ALB/EG EXTRACT FROM ODS FILES AND PUT IN MESSAGE ; JAN 12 1991
;;Version 1.55 (local for MAS v5 sites);;
ST ;ST is callable entry point
K ^UTILITY("TRN",$J) S A1B2NTL=1,U="^",A1B2NET=^XMB("NETNAME"),A1B2DEST=$P(^DIC(4.2,$P(^A1B2(11500.5,1,0),U,6),0),U,1) D FAC^A1B2UTL F A1B2TR=2,3 S H1=$H,KNT=1,(KNT1,KNT2,KNT3,KNT4)=0 D ADM,REG,DIS^A1B2T3,PAT1,BIL^A1B2T3
I $D(^UTILITY("TRN",$J)) D:A1B2FN'="" ^A1B2T2
I '$D(^UTILITY("TRN",$J)) S A1B2FLAG=0 D:A1B2FN'="" NADA^A1B2T2
D END Q
END K ^UTILITY("TRN",$J),A1B2DA,A1B2DEST,A1B2FLAG,A1B2FN,A1B2NET,A1B2NTL,A1B2PTR,A1B2TR,AI,AJ,FL,H1,KNT,KNT1,KNT2,KNT3,KNT4
Q
ADM ;use AX x-ref from 11500.2
Q:'$D(^A1B2(11500.2,"AX",A1B2TR)) S A1B2DA="" F AI=1:1 S A1B2DA=$O(^A1B2(11500.2,"AX",A1B2TR,A1B2DA)) Q:A1B2DA="" S A1B2PTR=$P(^A1B2(11500.2,A1B2DA,0),U,2) I (A1B2PTR'=""),($D(^A1B2(11500.1,A1B2PTR))>0) D ADM1
Q
ADM1 ;use EN^DIQ1
S FL=11500.2,DIC="^A1B2(11500.2,",DA=A1B2DA,DIQ="ODS(",DIQ(0)="I",DR=".01;.02;.06;.07;.08;.09;.1;.11;.12;.14;.15;.2;.21" D EN^DIQ1 S DR=".03;.05",DIQ(0)="E" D EN^DIQ1
S ^UTILITY("TRN",$J,A1B2TR,2,KNT,0)="$ADM"_U_ODS(FL,DA,.01,"I")_U_ODS(FL,DA,.03,"E")_U_ODS(FL,DA,.05,"E")_U_ODS(FL,DA,.06,"I")_U_+ODS(FL,DA,.07,"I")_U
S ^UTILITY("TRN",$J,A1B2TR,2,KNT,0)=^(0)_ODS(FL,DA,.08,"I")_U_ODS(FL,DA,.09,"I")_U_ODS(FL,DA,.1,"I")_U_ODS(FL,DA,.11,"I")_U_ODS(FL,DA,.12,"I")_U_ODS(FL,DA,.14,"I")_U
S ^UTILITY("TRN",$J,A1B2TR,2,KNT,0)=^(0)_ODS(FL,DA,.15,"I")_U_ODS(FL,DA,.2,"I")_U_ODS(FL,DA,.21,"I"),KNT=KNT+1,KNT2=KNT2+1
S ^UTILITY("TRN2",$J,A1B2TR,FL,A1B2DA)="",A1B2PTR=ODS(FL,DA,.02,"I") K DIC,DA,DIQ,DIQ(0),DR,ODS D:'$D(^UTILITY("TRN",$J,A1B2TR,1,A1B2PTR)) PAT
Q
REG ;use AX x-ref from 11500.4
Q:'$D(^A1B2(11500.4,"AX",A1B2TR)) S A1B2DA="" F AI=1:1 S A1B2DA=$O(^A1B2(11500.4,"AX",A1B2TR,A1B2DA)) Q:A1B2DA="" S A1B2PTR=$P(^A1B2(11500.4,A1B2DA,0),U,2) I (A1B2PTR'=""),($D(^A1B2(11500.1,A1B2PTR))>0) D REG1
Q
REG1 ;use EN^DIQ1
S FL=11500.4,DIC="^A1B2(11500.4,",DA=A1B2DA,DIQ="ODS(",DIQ(0)="I",DR=".01;.07;.08;.09;.12;.14;.15" D EN^DIQ1 S DR=".05",DIQ(0)="E" D EN^DIQ1
S ^UTILITY("TRN",$J,A1B2TR,3,KNT,0)="$REG"_U_ODS(FL,DA,.01,"I")_U_ODS(FL,DA,.05,"E")_U_U_U_+ODS(FL,DA,.07,"I")_U_ODS(FL,DA,.08,"I")_U_ODS(FL,DA,.09,"I")_U_U_U_ODS(FL,DA,.12,"I")_U_ODS(FL,DA,.14,"I")_U_ODS(FL,DA,.15,"I"),KNT=KNT+1,KNT3=KNT3+1
S ^UTILITY("TRN2",$J,A1B2TR,FL,A1B2DA)="" K DIC,DA,DIQ,DIQ(0),DR,ODS D:'$D(^UTILITY("TRN",$J,A1B2TR,1,A1B2PTR)) PAT
Q
PAT1 ;search pts
Q:'$D(^A1B2(11500.1,"AX",A1B2TR)) S A1B2DA="" F AI=1:1 S A1B2DA=$O(^A1B2(11500.1,"AX",A1B2TR,A1B2DA)) Q:A1B2DA="" S A1B2PTR=A1B2DA D:'$D(^UTILITY("TRN",$J,A1B2TR,1,A1B2PTR,KNT,0)) PAT
K ODS Q
PAT ;use EN^DIQ1
S FL=11500.1,DIC="^A1B2(11500.1,",DA=A1B2PTR,DIQ="ODS(",DIQ(0)="I",DR=".01;.02;.03;.06;.08;.12;.13;.07;.111;.112;.113;.114;.116;.117" D EN^DIQ1 S DR=".04;.05;.115",DIQ(0)="E" D EN^DIQ1
S ^UTILITY("TRN",$J,A1B2TR,1,A1B2PTR,KNT,0)="$PAT"_U_ODS(FL,DA,.01,"I")_U_ODS(FL,DA,.02,"I")_U_ODS(FL,DA,.03,"I")_U_ODS(FL,DA,.04,"E")_U
S ^UTILITY("TRN",$J,A1B2TR,1,A1B2PTR,KNT,0)=^(0)_ODS(FL,DA,.05,"E")_U_ODS(FL,DA,.06,"I")_U_ODS(FL,DA,.08,"I")_U_+ODS(FL,DA,.13,"I")_U_ODS(FL,DA,.12,"I")
F AI=.111,.112,.113,.114,.115,.116,.117 S AJ=$S('$D(ODS(FL,DA,AI,"I")):"",1:ODS(FL,DA,AI,"I")),ODS(FL,DA,AI,"I")=AJ
S AJ=$S('$D(ODS(FL,DA,.115,"E")):"",1:ODS(FL,DA,.115,"E")),ODS(FL,DA,.115,"E")=AJ
S ^UTILITY("TRN",$J,A1B2TR,1,A1B2PTR,KNT+.5,0)="$PAT1"_U_ODS(FL,DA,.07,"I")_U_ODS(FL,DA,.111,"I")_U_ODS(FL,DA,.112,"I")_U_ODS(FL,DA,.113,"I")_U_ODS(FL,DA,.114,"I")_U_ODS(FL,DA,.115,"E")_U_ODS(FL,DA,.116,"I")_U_ODS(FL,DA,.117,"I")
S KNT=KNT+1,KNT1=KNT1+1,^UTILITY("TRN2",$J,A1B2TR,FL,A1B2PTR)="" K DIC,DA,DIQ,DIQ(0),DR,ODS
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HA1B2T1 3682 printed Sep 23, 2025@19:57:31 Page 2
A1B2T1 ;ALB/EG EXTRACT FROM ODS FILES AND PUT IN MESSAGE ; JAN 12 1991
+1 ;;Version 1.55 (local for MAS v5 sites);;
ST ;ST is callable entry point
+1 KILL ^UTILITY("TRN",$JOB)
SET A1B2NTL=1
SET U="^"
SET A1B2NET=^XMB("NETNAME")
SET A1B2DEST=$PIECE(^DIC(4.2,$PIECE(^A1B2(11500.5,1,0),U,6),0),U,1)
DO FAC^A1B2UTL
FOR A1B2TR=2,3
SET H1=$HOROLOG
SET KNT=1
SET (KNT1,KNT2,KNT3,KNT4)=0
DO ADM
DO REG
DO DIS^A1B2T3
DO PAT1
DO BIL^A1B2T3
+2 IF $DATA(^UTILITY("TRN",$JOB))
if A1B2FN'=""
DO ^A1B2T2
+3 IF '$DATA(^UTILITY("TRN",$JOB))
SET A1B2FLAG=0
if A1B2FN'=""
DO NADA^A1B2T2
+4 DO END
QUIT
END KILL ^UTILITY("TRN",$JOB),A1B2DA,A1B2DEST,A1B2FLAG,A1B2FN,A1B2NET,A1B2NTL,A1B2PTR,A1B2TR,AI,AJ,FL,H1,KNT,KNT1,KNT2,KNT3,KNT4
+1 QUIT
ADM ;use AX x-ref from 11500.2
+1 if '$DATA(^A1B2(11500.2,"AX",A1B2TR))
QUIT
SET A1B2DA=""
FOR AI=1:1
SET A1B2DA=$ORDER(^A1B2(11500.2,"AX",A1B2TR,A1B2DA))
if A1B2DA=""
QUIT
SET A1B2PTR=$PIECE(^A1B2(11500.2,A1B2DA,0),U,2)
IF (A1B2PTR'="")
IF ($DATA(^A1B2(11500.1,A1B2PTR))>0)
DO ADM1
+2 QUIT
ADM1 ;use EN^DIQ1
+1 SET FL=11500.2
SET DIC="^A1B2(11500.2,"
SET DA=A1B2DA
SET DIQ="ODS("
SET DIQ(0)="I"
SET DR=".01;.02;.06;.07;.08;.09;.1;.11;.12;.14;.15;.2;.21"
DO EN^DIQ1
SET DR=".03;.05"
SET DIQ(0)="E"
DO EN^DIQ1
+2 SET ^UTILITY("TRN",$JOB,A1B2TR,2,KNT,0)="$ADM"_U_ODS(FL,DA,.01,"I")_U_ODS(FL,DA,.03,"E")_U_ODS(FL,DA,.05,"E")_U_ODS(FL,DA,.06,"I")_U_+ODS(FL,DA,.07,"I")_U
+3 SET ^UTILITY("TRN",$JOB,A1B2TR,2,KNT,0)=^(0)_ODS(FL,DA,.08,"I")_U_ODS(FL,DA,.09,"I")_U_ODS(FL,DA,.1,"I")_U_ODS(FL,DA,.11,"I")_U_ODS(FL,DA,.12,"I")_U_ODS(FL,DA,.14,"I")_U
+4 SET ^UTILITY("TRN",$JOB,A1B2TR,2,KNT,0)=^(0)_ODS(FL,DA,.15,"I")_U_ODS(FL,DA,.2,"I")_U_ODS(FL,DA,.21,"I")
SET KNT=KNT+1
SET KNT2=KNT2+1
+5 SET ^UTILITY("TRN2",$JOB,A1B2TR,FL,A1B2DA)=""
SET A1B2PTR=ODS(FL,DA,.02,"I")
KILL DIC,DA,DIQ,DIQ(0),DR,ODS
if '$DATA(^UTILITY("TRN",$JOB,A1B2TR,1,A1B2PTR))
DO PAT
+6 QUIT
REG ;use AX x-ref from 11500.4
+1 if '$DATA(^A1B2(11500.4,"AX",A1B2TR))
QUIT
SET A1B2DA=""
FOR AI=1:1
SET A1B2DA=$ORDER(^A1B2(11500.4,"AX",A1B2TR,A1B2DA))
if A1B2DA=""
QUIT
SET A1B2PTR=$PIECE(^A1B2(11500.4,A1B2DA,0),U,2)
IF (A1B2PTR'="")
IF ($DATA(^A1B2(11500.1,A1B2PTR))>0)
DO REG1
+2 QUIT
REG1 ;use EN^DIQ1
+1 SET FL=11500.4
SET DIC="^A1B2(11500.4,"
SET DA=A1B2DA
SET DIQ="ODS("
SET DIQ(0)="I"
SET DR=".01;.07;.08;.09;.12;.14;.15"
DO EN^DIQ1
SET DR=".05"
SET DIQ(0)="E"
DO EN^DIQ1
+2 SET ^UTILITY("TRN",$JOB,A1B2TR,3,KNT,0)="$REG"_U_ODS(FL,DA,.01,"I")_U_ODS(FL,DA,.05,"E")_U_U_U_+ODS(FL,DA,.07,"I")_U_ODS(FL,DA,.08,"I")_U_ODS(FL,DA,.09,"I")_U_U_U_ODS(FL,DA,.12,"I")_U_ODS(FL,DA,.14,"I")_U_ODS(FL,DA,.15,"I")
SET KNT=KNT+1
SET KNT3=KNT3+1
+3 SET ^UTILITY("TRN2",$JOB,A1B2TR,FL,A1B2DA)=""
KILL DIC,DA,DIQ,DIQ(0),DR,ODS
if '$DATA(^UTILITY("TRN",$JOB,A1B2TR,1,A1B2PTR))
DO PAT
+4 QUIT
PAT1 ;search pts
+1 if '$DATA(^A1B2(11500.1,"AX",A1B2TR))
QUIT
SET A1B2DA=""
FOR AI=1:1
SET A1B2DA=$ORDER(^A1B2(11500.1,"AX",A1B2TR,A1B2DA))
if A1B2DA=""
QUIT
SET A1B2PTR=A1B2DA
if '$DATA(^UTILITY("TRN",$JOB,A1B2TR,1,A1B2PTR,KNT,0))
DO PAT
+2 KILL ODS
QUIT
PAT ;use EN^DIQ1
+1 SET FL=11500.1
SET DIC="^A1B2(11500.1,"
SET DA=A1B2PTR
SET DIQ="ODS("
SET DIQ(0)="I"
SET DR=".01;.02;.03;.06;.08;.12;.13;.07;.111;.112;.113;.114;.116;.117"
DO EN^DIQ1
SET DR=".04;.05;.115"
SET DIQ(0)="E"
DO EN^DIQ1
+2 SET ^UTILITY("TRN",$JOB,A1B2TR,1,A1B2PTR,KNT,0)="$PAT"_U_ODS(FL,DA,.01,"I")_U_ODS(FL,DA,.02,"I")_U_ODS(FL,DA,.03,"I")_U_ODS(FL,DA,.04,"E")_U
+3 SET ^UTILITY("TRN",$JOB,A1B2TR,1,A1B2PTR,KNT,0)=^(0)_ODS(FL,DA,.05,"E")_U_ODS(FL,DA,.06,"I")_U_ODS(FL,DA,.08,"I")_U_+ODS(FL,DA,.13,"I")_U_ODS(FL,DA,.12,"I")
+4 FOR AI=.111,.112,.113,.114,.115,.116,.117
SET AJ=$SELECT('$DATA(ODS(FL,DA,AI,"I")):"",1:ODS(FL,DA,AI,"I"))
SET ODS(FL,DA,AI,"I")=AJ
+5 SET AJ=$SELECT('$DATA(ODS(FL,DA,.115,"E")):"",1:ODS(FL,DA,.115,"E"))
SET ODS(FL,DA,.115,"E")=AJ
+6 SET ^UTILITY("TRN",$JOB,A1B2TR,1,A1B2PTR,KNT+.5,0)="$PAT1"_U_ODS(FL,DA,.07,"I")_U_ODS(FL,DA,.111,"I")_U_ODS(FL,DA,.112,"I")_U_ODS(FL,DA,.113,"I")_U_ODS(FL,DA,.114,"I")_U_ODS(FL,DA,.115,"E")_U_ODS(FL,DA,.116,"I")_U_ODS(FL,DA,.117,"I")
+7 SET KNT=KNT+1
SET KNT1=KNT1+1
SET ^UTILITY("TRN2",$JOB,A1B2TR,FL,A1B2PTR)=""
KILL DIC,DA,DIQ,DIQ(0),DR,ODS
+8 QUIT
