source: WorldVistAEHR/trunk/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DICM1.m@ 1710

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

initial load of WorldVistAEHR

File size: 3.7 KB
RevLine 
[613]1DICM1 ;SFISC/XAK,TKW-LOOKUP WHEN INPUT MUST BE TRANSFORMED ;2/8/00 09:29
2 ;;22.0;VA FileMan;**20,29**;Mar 30, 1999
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 G @Y
5 ;
6P ;POINTERS
7 G P^DICM0
8 ;
9D ;DATES
10 I $S(X'?.N:1,$L(X)>15:0,1:X>49) S %DT=$S($D(^DD(+DO(2),.001)):"N",1:"")_$P($P(DS,"%DT=""",2),"""") F %="E","R" D DZ
11 I D ^%DT S X=Y K %DT I X>1 D Q
12 . I $D(DINDEX(1,"TRANCODE"))#2 D Q
13 . . X DINDEX(1,"TRANCODE") I $G(X)="" K X S Y=-1 Q
14 . . I ('$D(DINDEX(1,"TRANOUT"))#2)!(DIC(0)'["E")!($D(DDS)) Q
15 . . N % S %=X N X S X=% X DINDEX(1,"TRANOUT") W " ",X Q
16 . Q:DIC(0)'["E"
17 . I '$D(DDS) W " " D DT^DIQ
18 . S DIDA=1 Q
19 K X Q
20DZ S %DT=$P(%DT,%)_$P(%DT,%,2) Q
21 ;
22S ;SETS
23 N A8,A9,DDH S DDH=0
24 I $P(DS,U,2)["*"!($D(DIC("S"))) D SC
25 S DICR(DICR,1)=1,I=$P(DS,U,3),DD=$P(";"_I,";"_X_":",2)
26 N DS S DS=0
27 I DD]"" S Y=X X:$D(A9) A9 I D SDSP,SK Q
28SS S DICMF=0
29 F DICM=1:1 S DD=$P(I,";",DICM) Q:DD="" I $P($P(DD,":",2),X)="" D
30 . S Y=$P(DD,":"),DD=$P(DD,":",2) Q:DIC(0)["X"&(DD'=X)
31 . I $D(A9) X A9 E Q
32 . I DIC(0)["O"!(DIC(0)'["E") S:DD=X DICMF=1 I DD'=X,DICMF=1 Q
33 . S DS=DS+1 D SDSP
34 . S DS(DS)=Y_"^ "_DDH_" "_DDH(DDH,Y)
35 G:DDH=0 NO
36 I DDH=1 D G SK
37 . S X=$O(DDH(1,""))
38 . W:DIC(0)["E"&('$D(DDS)) " ("_DDH(1,X)_")"
39 . S:$D(DS(1,"T")) X=DS(1,"T") Q
40 G:DIC(0)'["E" NO
41 I $D(DDS) S DD=DDH,DDD=2 K DDQ D LIST^DDSU K DDD,DDQ G:$D(DTOUT) NO
42 I '$D(DDS) F D Q:DICM'="AGN"
43 . F DICM=1:1:DDH W !,$P(DS(DICM),U,2,999)
44 . W !,"CHOOSE 1-"_DDH_": "
45 . R DIY:$S($D(DTIME):DTIME,1:300) E Q
46 . Q:U[DIY!(DIY[U) I DIY?1.N,$D(DS(+DIY)) Q
47 . W $C(7),"??" S DICM="AGN"
48 G:+$P(DIY,"E")'=DIY NO G:'$D(DS(+DIY)) NO
49 S X=$P(DS(DIY),U)
50 I '$D(DDS) W " "_DDH(DIY,X),!
51 S:$D(DS(DIY,"T")) X=DS(DIY,"T")
52 G SK
53 ;
54NO K X,Y S Y=-1
55SK K DIC("S") S:$D(A8) DIC("S")=A8
56 K DDH,DICM,DICMF,DICMS
57 Q
58SC ;SCREENS ON SETS
59 S:$D(DIC("S")) A8=DIC("S") Q:$P(DS,U,2)'["*"
60 Q:'$D(^DD(+DO(2),.01,12.1)) X ^(12.1) Q:'$D(DIC("S"))
61 S Y="("_DIC,I="DIC"_DICR,%=""""_%_"""",A9="X DIC(""S"")"
62 Q:$G(DICR(DICR))?1"""".E1""""
63 ;I DS["DINUM=X" S D=D_" E I $D"_Y_"Y,0))" Q
64 S A9=A9_" E F "_I_"=0:0 S "_I_"=$O"_Y
65 I @("$O"_Y_%_",0))'=""""") S A9=A9_%_",Y,"_I_")) Q:"_I_"="""" "_$S($D(A8):"X ""N Y S Y="_I_" ""_A8 I $T,",1:"I ")_"$D"_Y_I_",0)) Q" Q
66 S A9=A9_I_")) Q:'"_I_" "_$S($D(A8):"X ""N Y S Y="_I_" ""_A8 I $T,",1:"I ")_"$P(^("_I_",0),U)=Y Q" Q
67 ;
68SDSP ; Execute screen, transform, set up output for display
69 N DISAVX,DISAVY,DIXX,DIOUT S DIOUT=0,DIXX=Y
70 S DDH=DDH+1,DDH(DDH,Y)=$P(" (^",U,(DS=0))_Y
71 I $D(DINDEX(1,"TRANCODE"))#2 D S:'DIOUT&('DS) X=DIXX I DIOUT S Y=-1 Q
72 . S DISAVY=Y N X,Y S X=DISAVY
73 . X DINDEX(1,"TRANCODE") I $G(X)="" S DIOUT=1 Q
74 . S DIXX=X I DS S DS(DS,"T")=X Q
75 I $G(DINDEX(1,"TRANOUT"))]"" D
76 . S DISAVY=Y N X,Y S X=DIXX X DINDEX(1,"TRANOUT")
77 . S DDH(DDH,DISAVY)=$P(" (^",U,(DS=0))_$G(X) Q
78 S DDH(DDH,Y)=DDH(DDH,Y)_" "_$P(DD,";")_$P(")^",U,(DS=0))
79 I DS=0,DIC(0)["E",'$D(DDS) W DDH(DDH,Y)
80 Q
81 ;
82V ;VARIABLE POINTER
83 I X["?BAD" K X Q
84 D ^DICM2,DO^DIC1
85 Q
86 ;
87T ; Execute TRANSFORM code for indexes other than Pointers, Date, VP or Sets.
88 N DIXX S DIXX=X
89 X DINDEX(1,"TRANCODE") I $G(X)="" K X S Y=-1 Q
90 I DIXX=X K X S Y=-1
91 Q
92 ;
93SOU ;
94 S DSOU="01230129022455012623019202",DSOV=X,X=$C($A(X)-(X?1L.E*32)),DIX=$E(DSOU,$A(X)-64) F DIY=2:1 S Y=$E(DSOV,DIY) Q:","[Y I Y?1A S %=$E(DSOU,$A(Y)-$S(Y?1U:64,1:96)) I %-DIX,%-9 S DIX=% I % S X=X_% Q:$L(X)=4
95 S X=$E(X_"000",1,4) K DSOU,DSOV Q
96 ;
97ACT ;
98 S DIY=Y,DIY(1)=DIC,DIC("W")="",DIX=X
99A X:$D(^DD(+DO(2),0,"ACT")) ^("ACT") I Y<0 S DIC=DIY(1),X=DIX K DIC("W"),DO Q
100 I DO(2)["P" N % S %=^DD(+DO(2),.01,0) I $P(%,U,2)["P",$P(%,U,3)]"" S DIC=U_$P(%,U,3) K DO D DO^DIC1 I $D(@(DIC_+$P(Y,U,2)_",0)")) S Y=+$P(Y,U,2)_U_$P(^(0),U) G A
101 S Y=DIY,DIC=DIY(1),X=DIX K DIC("W"),DO D DO^DIC1 Q
Note: See TracBrowser for help on using the repository browser.