source: WorldVistAEHR/trunk/r/HEALTH_SUMMARY-GMTS/GMTSRS.m@ 1093

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

initial load of WorldVistAEHR
File size: 7.4 KB
RevLine 
[613]1GMTSRS ; SLC/KER - Health Summary Type Resequence ; 02/11/2003
2 ;;2.7;Health Summary;**62**;Oct 20, 1995
3 ;
4 ; External References
5 ; DBIA 10011 ^UTILITY($J
6 ; DBIA 10013 IX1^DIK
7 ; DBIA 10026 ^DIR
8 ; DBIA 10011 ^DIWP
9 ;
10 ; This routine will resequence the Health Summary Components
11 ; in the structure (sub-file 142.01) of a Health Summary
12 ; Type (file 142)
13 ;
14EN ; Main Entry Point
15 N DA,DIK,GMTST,GMTSS,GMTSERR,GMTSCC,X,Y
16 W !,"Resequence the Components and/or Selection Items of a Health Summary Type.",!
17 D LKT^GMTSRS1 I +Y'>0 W !,"Health Summary Type not selected ",! Q
18 S GMTST=+Y,DA(1)=GMTST D RC(GMTST),RSI(GMTST)
19 K DA S DA=GMTST,DIK="^GMT(142," D IX1^DIK
20 Q
21RC(TYPE) ; Resequence Components
22 N DIC,DIR,DIROUT,DIRUT,DTOUT,DUOUT,GMTSNN,GMTSNC,GMTSTX,GMTSC,GMTSCI,GMTSCP,GMTSCN,GMTSI,GMTS,GMTSRO,GMTST,GMTSTR,GMTSCC
23 N %,I,X,Y,Z,DIWL,DIWR,DIWF,DIW,DIWI,DIWT,DIWTC,DIWX,DN,DA
24 S GMTST=+($G(TYPE)) Q:+GMTST=0 Q:'$D(^GMT(142,+GMTST,0)) Q:'$L($P($G(^GMT(142,+GMTST,0)),"^",1)) S U="^",GMTSCC=$$CS(GMTST) Q:+GMTSCC'>1
25 S (GMTSTX,X)="Health Summary Type '"_$P($G(^GMT(142,+GMTST,0)),"^",1)_"' has "_GMTSCC_" Health Summary Components, do you want to resequence them now?"
26 K ^UTILITY($J,"W") S DIWL=0,DIWF="C60" D ^DIWP S GMTSNN="^UTILITY("_$J_",""W"")",GMTSNC="^UTILITY("_$J_",""W"","
27 S GMTSC=0 F S GMTSNN=$Q(@GMTSNN) Q:GMTSNN=""!(GMTSNN'[GMTSNC) I GMTSNN'["""W"",0)" S GMTSC=GMTSC+1,DIR("A",GMTSC)=@GMTSNN
28 Q:+GMTSC'>0 K ^UTILITY($J,"W") S DIR("A")=$G(DIR("A",GMTSC))_" (Y/N) " K DIR("A",GMTSC)
29 W ! S (GMTSCN,GMTSCI)=0,GMTSCP="" F S GMTSCI=$O(^GMT(142,+GMTST,1,GMTSCI)) Q:+GMTSCI=0 D
30 . S GMTSCP=+($P($G(^GMT(142,+GMTST,1,GMTSCI,0)),"^",2)) Q:+GMTSCP'>0
31 . S GMTSCP=$P($G(^GMT(142.1,+GMTSCP,0)),"^",1) Q:'$L(GMTSCP)
32 . S GMTSCN=+($G(GMTSCN))+1 W !,?1,$J(GMTSCN,3)," ",GMTSCP
33 S DIR(0)="YAO",DIR("?")="^D YN^GMTSRS3",DIR("??")="^D SC^GMTSRS3",DIR("B")="N"
34 W ! D ^DIR S GMTSRO=0 S:+($G(Y))>0 GMTSRO=1 W ! S DA(1)=+($G(GMTST)) D RCS^GMTSRS1
35 Q
36RSI(TYPE) ; Resequence Selection Items
37 N DIC,DIR,DIROUT,DIRUT,DTOUT,DUOUT,GMTSNN,GMTSNC,GMTSS,GMTSSI,GMTSTX
38 N GMTSC,GMTSCI,GMTSCP,GMTSCN,GMTSI,GMTS,GMTSRO,GMTST,GMTSTR,GMTSCC,%,I,X,Y,Z
39 N DIWL,DIWR,DIWF,DIW,DIWI,DIWT,DIWTC,DIWX,DN,DA
40 S GMTST=+($G(TYPE)) Q:+GMTST=0 Q:'$D(^GMT(142,+GMTST,0))
41 Q:'$L($P($G(^GMT(142,+GMTST,0)),"^",1))
42 S U="^",GMTSCC=$$CSI(GMTST) Q:+GMTSCC'>0
43 S X="Health Summary Type '"_$P($G(^GMT(142,+GMTST,0)),"^",1)
44 S X=X_"' has "_$S(+GMTSCC>1:GMTSCC,1:"one")_" Health Summary Component"_$S(+GMTSCC>1:"s",1:"")
45 S X=X_" with multiple selection items."
46 S:GMTSCC=1 X=X_" Do you want to resequence those selection items now?"
47 S:GMTSCC>1 X=X_" Do you want to resequence any of those selection items now?"
48 K ^UTILITY($J,"W") S DIWL=0,DIWF="C60" D ^DIWP S GMTSNN="^UTILITY("_$J_",""W"")",GMTSNC="^UTILITY("_$J_",""W"","
49 S GMTSC=0 F S GMTSNN=$Q(@GMTSNN) Q:GMTSNN=""!(GMTSNN'[GMTSNC) I GMTSNN'["""W"",0)" S GMTSC=GMTSC+1,DIR("A",GMTSC)=@GMTSNN
50 Q:+GMTSC'>0 K ^UTILITY($J,"W") S DIR("A")=$G(DIR("A",GMTSC))_" (Y/N) " K DIR("A",GMTSC)
51 S (GMTSCN,GMTSCI)=0,GMTSCP="" F S GMTSCI=$O(^GMT(142,+GMTST,1,GMTSCI)) Q:+GMTSCI=0 D
52 . S GMTSCP=+($P($G(^GMT(142,+GMTST,1,GMTSCI,0)),"^",2)) Q:+GMTSCP'>0
53 . S GMTSCP=$P($G(^GMT(142.1,+GMTSCP,0)),"^",1) Q:'$L(GMTSCP)
54 . S (GMTSS,GMTSSI)=0 F S GMTSSI=$O(^GMT(142,+GMTST,1,+GMTSCI,1,GMTSSI)) Q:+GMTSSI=0 S GMTSS=+GMTSS+1
55 . Q:+GMTSS'>1 S GMTSCN=+($G(GMTSCN))+1
56 . W:GMTSCC=1 !,?4," ",GMTSCP
57 S DIR(0)="YAO",DIR("B")="N" W ! D ^DIR S GMTSRO=0 S:+($G(Y))>0 GMTSRO=1
58 I +($G(Y))>0 D
59 . S DA(1)=+($G(GMTST)) D:+GMTSCC=1 ONE(GMTST) D:+GMTSCC>1 MUL(GMTST)
60 I $D(GMTSRO),+($G(GMTSRO))=0 D ALL(GMTST)
61 Q
62ALL(TYPE) ; Resequence (only) All Components Selection Items
63 N DA,GMTST,GMTSCN,GMTSCI,GMTSCN,GMTSCI
64 S GMTST=+($G(TYPE)) Q:+GMTST=0 Q:'$D(^GMT(142,+GMTST,0)) S DA(2)=+GMTST
65 S (DA,GMTSCN,GMTSCI)=0 F S GMTSCI=$O(^GMT(142,+GMTST,1,GMTSCI)) Q:+GMTSCI=0 D
66 . S DA(1)=GMTSCI Q:'$D(^GMT(142,+DA(2),1,+DA(1),1,"B")) S GMTSRO=0
67 . I +($G(DA(2)))>0,+($G(DA(1)))>0,$D(^GMT(142,+($G(DA(2))),1,+($G(DA(1))))) D RSI^GMTSRS2
68 Q
69ONE(TYPE) ; Reorder/Resequence One Component Selection Items
70 N DA,GMTST,GMTSCN,GMTSCI,GMTSCN,GMTSCI
71 S GMTST=+($G(TYPE)) Q:+GMTST=0 Q:'$D(^GMT(142,+GMTST,0)) S DA(2)=+GMTST
72 S (DA,GMTSCN,GMTSCI)=0 F S GMTSCI=$O(^GMT(142,+GMTST,1,GMTSCI)) Q:+GMTSCI=0 D Q:+($G(DA(1)))>0
73 . S (GMTSS,GMTSSI)=0 F S GMTSSI=$O(^GMT(142,+GMTST,1,+GMTSCI,1,GMTSSI)) Q:+($G(DA(1)))>0 Q:+GMTSSI=0 S GMTSS=+GMTSS+1
74 . Q:+GMTSS'>1 S DA(1)=GMTSCI
75 I +($G(DA(2)))>0,+($G(DA(1)))>0,$D(^GMT(142,+($G(DA(2))),1,+($G(DA(1))))) D RSI^GMTSRS2
76 I +($G(DA(2)))'>0!(+($G(DA(1)))'>0)!('$D(^GMT(142,+($G(DA(2))),1,+($G(DA(1)))))) Q
77 Q
78MUL(TYPE) ; Reorder/Resequence Multiple Components
79 N GMTST,GMTSCW,GMTSMAX
80 S GMTST=+($G(TYPE)) Q:+GMTST=0 Q:'$D(^GMT(142,+GMTST,0))
81 D ARY(+($G(GMTST)),.GMTSCW) S GMTSMAX=+($G(GMTSCW(0))) Q:+GMTSMAX'>1
82 F S X=$$MUL2(GMTST,GMTSMAX,.GMTSCW) Q:+($G(X))'>0
83 Q
84MUL2(GMTST,GMTSMAX,GMTSCW) ; Multiple Component Selection
85 N DIR,DIROUT,DIRUT,DTOUT,DUOUT,GMTS,GMTSA,GMTSC,GMTSI,GMTSN,GMTSTR
86 N GMTSTX,X,Y
87 S DIR(0)="NAO^1:"_GMTSMAX_":0"
88 S (DIR("?"),DIR("??"))="^D MULH^GMTSRS"
89 S DIR("A",1)="The following Components have multiple Selection Items:"
90 S DIR("A",2)=" "
91 S (GMTSI,GMTSC)=0 F S GMTSI=$O(GMTSCW(GMTSI)) Q:+GMTSI=0 D
92 . S GMTSN=$P($G(GMTSCW(GMTSI)),"^",2) Q:'$L(GMTSN)
93 . S GMTSC=GMTSC+1,GMTSA=GMTSC+2,DIR("A",GMTSA)=" "_$J(GMTSC,2)_" "_GMTSN
94 S GMTSA=+($O(DIR("A"," "),-1))+1,DIR("A",GMTSA)=" "
95 S DIR("A")="To resequence Selection Items, select 1-"_GMTSMAX_": "
96 W ! D ^DIR
97 Q:+Y'>0 -1
98 S:X="" (X,Y)=-1 S X=-1 S:+Y>0 X=+($G(GMTSCW(+Y)))
99 S:$D(DIROUT)!($D(DIRUT))!($D(DTOUT))!($D(DUOUT)) X=-1
100 S Y=X D:+Y>0 Y(+($G(GMTST)),+Y) S DA(2)=+($G(GMTST)) S:+Y>0 DA(1)=+Y
101 I +($G(DA(2)))>0,+($G(DA(1)))>0,$D(^GMT(142,+($G(DA(2))),1,+($G(DA(1))))) D RSI^GMTSRS2
102 S GMTST=+Y
103 Q GMTST
104MULH ; Multiple Structure Selection Help
105 W !!,"Select 1-"_GMTSMAX_" to resequence, or return or '^' to exit.",!
106 Q
107Y(TYPE,COMP) ; Results for Y
108 N GMTSS,GMTST S GMTST=+($G(TYPE)),GMTSS=+($G(COMP)) Q:'$D(^GMT(142,+GMTST))
109 I +GMTSS>0,($D(^GMT(142,+($G(GMTST)),1,+GMTSS,0))) D
110 . S Y=+GMTSS,Y(0)=$G(^GMT(142,+($G(GMTST)),1,+GMTSS,0)),Y(142.1)=+($P($G(^GMT(142,+($G(GMTST)),1,+GMTSS,0)),"^",2))
111 . S Y(142.1,0)=$G(^GMT(142.1,+($P($G(^GMT(142,+($G(GMTST)),1,+GMTSS,0)),"^",2)),0))
112 Q
113CS(X) ; Components
114 N GMTSI,GMTSC,GMTSCI S (GMTSC,GMTSCI)=0,GMTSI=+($G(X)) Q:+GMTSI'>0 0
115 F S GMTSCI=$O(^GMT(142,+GMTSI,1,GMTSCI)) Q:+GMTSCI=0 S GMTSC=GMTSC+1
116 S X=GMTSC Q X
117 ;
118CSI(X) ; Components with Multiple Selection Types
119 N GMTSI,GMTSS,GMTSSI,GMTSC,GMTSCI,GMTSEL S (GMTSEL,GMTSC,GMTSCI)=0,GMTSI=+($G(X)) Q:+GMTSI'>0 0
120 F S GMTSCI=$O(^GMT(142,+GMTSI,1,GMTSCI)) Q:+GMTSCI=0 D
121 . S (GMTSS,GMTSSI)=0
122 . F S GMTSSI=$O(^GMT(142,GMTSI,1,GMTSCI,1,GMTSSI)) Q:+GMTSSI=0 D
123 . . S GMTSS=+($G(GMTSS))+1
124 . S:+($G(GMTSS))>1 GMTSEL=+($G(GMTSEL))+1
125 S X=GMTSEL Q X
126 ;
127ARY(X,ARY) ; Array of Components with Multiple Selection Types
128 N GMTSI,GMTSS,GMTSSI,GMTSC,GMTSCI,GMTSEL,GMTSSN S (GMTSC,GMTSCI,GMTSSN,GMTSEL)=0,GMTSI=+($G(X)) Q:+GMTSI'>0
129 F S GMTSCI=$O(^GMT(142,+GMTSI,1,GMTSCI)) Q:+GMTSCI=0 D
130 . S (GMTSS,GMTSSI)=0 F S GMTSSI=$O(^GMT(142,GMTSI,1,GMTSCI,1,GMTSSI)) Q:+GMTSSI=0 S GMTSS=+($G(GMTSS))+1
131 . I +($G(GMTSS))>1 S GMTSEL=+($G(GMTSEL))+1,ARY(GMTSEL)=+GMTSCI_"^"_$P(^GMT(142.1,+($P($G(^GMT(142,+GMTSI,1,GMTSCI,0)),"^",2)),0),"^",1),ARY(0)=GMTSEL
132 Q
133TRIM(X) ; Remove Spaces
134 S X=$G(X) F Q:$E(X,1)'=" " S X=$E(X,2,$L(X))
135 F Q:$E(X,$L(X))'=" " S X=$E(X,1,($L(X)-1))
136 Q X
Note: See TracBrowser for help on using the repository browser.