source: WorldVistAEHR/trunk/r/OPERATIONS_WITH_DESERT_STORM-A1B2/A1B2T1.m@ 1432

Last change on this file since 1432 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 3.6 KB
RevLine 
[613]1A1B2T1 ;ALB/EG EXTRACT FROM ODS FILES AND PUT IN MESSAGE ; JAN 12 1991
2 ;;Version 1.55 (local for MAS v5 sites);;
3ST ;ST is callable entry point
4 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
5 I $D(^UTILITY("TRN",$J)) D:A1B2FN'="" ^A1B2T2
6 I '$D(^UTILITY("TRN",$J)) S A1B2FLAG=0 D:A1B2FN'="" NADA^A1B2T2
7 D END Q
8END K ^UTILITY("TRN",$J),A1B2DA,A1B2DEST,A1B2FLAG,A1B2FN,A1B2NET,A1B2NTL,A1B2PTR,A1B2TR,AI,AJ,FL,H1,KNT,KNT1,KNT2,KNT3,KNT4
9 Q
10ADM ;use AX x-ref from 11500.2
11 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
12 Q
13ADM1 ;use EN^DIQ1
14 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
15 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
16 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
17 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
18 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
19 Q
20REG ;use AX x-ref from 11500.4
21 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
22 Q
23REG1 ;use EN^DIQ1
24 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
25 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
26 S ^UTILITY("TRN2",$J,A1B2TR,FL,A1B2DA)="" K DIC,DA,DIQ,DIQ(0),DR,ODS D:'$D(^UTILITY("TRN",$J,A1B2TR,1,A1B2PTR)) PAT
27 Q
28PAT1 ;search pts
29 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
30 K ODS Q
31PAT ;use EN^DIQ1
32 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
33 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
34 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")
35 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
36 S AJ=$S('$D(ODS(FL,DA,.115,"E")):"",1:ODS(FL,DA,.115,"E")),ODS(FL,DA,.115,"E")=AJ
37 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")
38 S KNT=KNT+1,KNT1=KNT1+1,^UTILITY("TRN2",$J,A1B2TR,FL,A1B2PTR)="" K DIC,DA,DIQ,DIQ(0),DR,ODS
39 Q
Note: See TracBrowser for help on using the repository browser.