source: WorldVistAEHR/trunk/r/HEALTH_SUMMARY-GMTS/GMTSXQ08.m@ 703

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

initial load of WorldVistAEHR

File size: 2.0 KB
Line 
1GMTSXQ08 ; SLC/JER - XQORM2 for Export w/Health Summary ;1/10/92 15:03
2 ;;2.5;Health Summary;;Dec 16, 1992
3XQORM2 ; SLC/KCM - Lookup for Menu Utility ;11/20/90 11:32 ;
4 ;;6.52;Copyright 1990, DVA;
5EN ;From: XQORM Entry: X,XQORM Exit: X,Y,XQORM
6 K Y,OROTHER I X=" " S XQORM(0)=XQORM(0)_"X" D LAST^XQORM4 I '$L(X) S Y=-1 Q
7 D UP^XQORM1 K ORUX S ORUX=X,(ORUT,ORUER,Y)=0,XQORMSF=""
8 F J=1:1:$L(ORUX,",") S X=$P(ORUX,",",J) D EAT,SET D:X["-" RNG^XQORM3 Q:ORUER F K=1:1:$L(X,",") I $L($P(X,",",K)) S ORUT=ORUT+1,ORUX(ORUT)=$P(X,",",K) S:$L(ORUFG) ORUX(ORUT,"=")=ORUFG S:ORUSB ORUX(ORUT,"'")=""
9 I 'ORUER S (ORUSQ,ORUT)=0 F I=0:0 S ORUT=$O(ORUX(ORUT)) Q:ORUT="" S X=ORUX(ORUT) D SPCL I $L(X) D LOOK^XQORM3,CHAL Q:ORUER
10 I +XQORM(0),+Y>XQORM(0) D:XQORM(0)["A" NE^XQORM4 S ORUER=1,Y=-1
11 I 'ORUER S ORUB=0 F I=0:0 S ORUB=$O(Y(ORUB)) Q:ORUB'>0 D SCRN I 'ORUFG D:ORUX["ALL" SUB I ORUX'["ALL" D:XQORM(0)["A" NS^XQORM4 S ORUER=1
12 I 'ORUER,Y>0 W:XQORM(0)["A" " " S ORUFG=$S($X>(IOM-30):9,1:$X) K:XQORM(0)'["F" ^DISV(DUZ,"XQORM",XQORM) F I=0:0 S I=$O(Y(I)) Q:I'>0 D:XQORM(0)["A" ECHO D:XQORM(0)'["F" DISV
13 S X=ORUX I ORUER K Y S Y=-1
14KILL K ORUX,ORUFG,ORUSB,ORUT,ORUER,ORUFD,ORUB,ORUDA,ORUW,ORUSQ,XQORMSF,DA,J,K,Y("B") Q
15SCRN S ORUFG=1 I $D(XQORM("S"))'[0,$L(XQORM("S")) S DA(1)=+XQORM,DA=+Y(ORUB) I DA N Y X XQORM("S") S ORUFG=$T
16 Q
17SET S ORUSB=0 I $E(X)="-",$L(X)>1 S ORUSB=1,X=$P(X,"-",2,99)
18 S ORUFG="" I $E(X)'="=" S ORUFG=$P(X,"=",2,99),X=$P(X,"=",1)
19 Q
20SPCL I $E(X,1,2)="^^" S Y=Y+1,ORUSQ=ORUSQ+1,Y(ORUSQ)="^"_X,X="" S:$D(ORUX(ORUT,"=")) $P(Y(ORUSQ),"=",2)=ORUX(ORUT,"=") Q
21 I XQORM(0)["+","+-"[X S Y=Y+1,ORUSQ=ORUSQ+1,Y(ORUSQ)=X,X="" Q
22 I $E(X)=";" D SC^XQORM4 S X="",ORUER=1 Q
23 S X=$P(X,";",1) D EAT
24 Q
25CHAL I ORUX(ORUT)="ALL" S X="ALL",ORUER=0 D ALL^XQORM4 Q
26 Q:ORUER D:ORUDA UPD^XQORM3
27 Q
28EAT F I=0:0 Q:$E(X)]" " Q:'$L(X) S X=$E(X,2,999)
29 F I=0:0 Q:$E(X,$L(X))]" " Q:'$L(X) S X=$E(X,1,$L(X)-1)
30 Q
31ECHO W:($X+$L($P(Y(I),"^",3))+4)>IOM !,?ORUFG W $P(Y(I),"^",3)," " Q
32DISV S ^DISV(DUZ,"XQORM",XQORM,I)=$P(Y(I),"^",3) Q
33SUB K Y(ORUB) S Y=Y-1 Q
Note: See TracBrowser for help on using the repository browser.