source: FOIAVistA/trunk/r/SPINAL_CORD_DYSFUNCTION-SPN/SPNAHOCV.m@ 1704

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

initial load of FOIAVistA 6/30/08 version

File size: 4.5 KB
Line 
1SPNAHOCV ;HISC/DAD-AD HOC REPORTS: MACRO EXPORT COMPILER ; [ 06/15/95 8:23 PM ]
2 ;;2.0;Spinal Cord Dysfunction;;01/02/1997
3 ;
4BUILD ; *** Move macro data into routine
5 W !!,"Building the Ad Hoc macro export routine(s)...",!
6 S SPNMACRO="",SPNLN=1000,(SPNDONE,SPNLEN,SPNRTNNO,SPNTAB)=0
7 K ^TMP($J,"SPNROU") D SAVE("PROG1")
8 F S SPNMACRO=$O(^TMP($J,"SPNMACRO",SPNMACRO)) Q:SPNMACRO="" D
9 . S SPND0=0
10 . F S SPND0=$O(^TMP($J,"SPNMACRO",SPNMACRO,SPND0)) Q:SPND0'>0 D
11 .. S X=$G(^SPNL(154.8,SPND0,0)),SPNTYPE=$P(X,U,2) Q:X="" D BLD(X)
12 .. S SPND1=0
13 .. F S SPND1=$O(^SPNL(154.8,SPND0,"FLD",SPND1)) Q:SPND1'>0 D
14 ... S X=$G(^SPNL(154.8,SPND0,"FLD",SPND1,0)) Q:X="" D BLD(X)
15 ... I SPNTYPE="s" D
16 .... S X=$G(^SPNL(154.8,SPND0,"FLD",SPND1,"FRTO")) S:X="" X=U D BLD(X)
17 .... Q
18 ... Q
19 .. D BLD("")
20 .. S SPNDONE=$O(^TMP($J,"SPNMACRO",SPNMACRO))=""
21 .. S SPNDONE=$O(^TMP($J,"SPNMACRO",SPNMACRO,SPND0))'>0&SPNDONE
22 .. I SPNLEN'<4000!SPNDONE D SAVE("PROG2")
23 .. Q
24 . Q
25 W !!,"Enter 'DO ^",SPNPROG,"' to install the exported Ad Hoc macros."
26 Q
27SAVE(PROG) ; *** Save routine
28 S SPNRTN=$S(SPNRTNNO=0:SPNPROG,1:$E(SPNPROG,1,8-$L(SPNRTNNO))_SPNRTNNO)
29 S SPNRTNXT=$S(SPNDONE:"",1:$E(SPNPROG,1,8-$L(SPNRTNNO+1))_(SPNRTNNO+1))
30 F SP=1:1 S X=$P($T(@PROG+SP),";;",2,99) Q:X="" D
31 . X "S Y="_X S ^TMP($J,"SPNROU",SP,0)=Y
32 . Q
33 S DIE="^TMP($J,""SPNROU"",",XCN=0,X=SPNRTN X ^%ZOSF("SAVE")
34 K ^TMP($J,"SPNROU") S SPNLEN=0,SPNRTNNO=SPNRTNNO+1
35 W:SPNTAB=0 ! W ?SPNTAB,SPNRTN S SPNTAB=SPNTAB+$S(SPNTAB=70:-70,1:10)
36 Q
37BLD(X) ; *** Build data line
38 S X=" ;;"_X,SPNLEN=SPNLEN+$L(X)+2
39 S ^TMP($J,"SPNROU",SPNLN,0)=X,SPNLN=SPNLN+1
40 Q
41ID(D0) ; *** Macro identifiers
42 W " ",$$GET1^DIQ(154.8,D0_",",.02)
43 W " ",$$GET1^DIQ(154.8,D0_",",.03)
44 Q
45PROG1 ;; *** Routine that processes the Ad Hoc macros
46 ;;SPNRTN_" ;HISC/DAD-AD HOC REPORTS: EXPORTED MACROS ;"_SPNTODAY
47 ;;" ;;0.0;Package Name;;Mmm DD, YYYY"
48 ;;" ;;"_$P($T(SPNAHOCV+1),";",3,4)_";;"_$P($T(SPNAHOCV+1),";",6)
49 ;;" W !,""=== Ad Hoc Macro Installer ==="""
50 ;;" I $$VFILE^DILFD(154.8)=0 D G EXIT"
51 ;;" . W $C(7),!!?3,""The Ad Hoc Macro file does not exist !!"""
52 ;;" . Q"
53 ;;" K DIR S DIR(0)=""YOAM"",DIR(""A"")=""Install macros? "",DIR(""B"")=""No"""
54 ;;" W ! D ^DIR W ! I Y D ^"_SPNRTNXT
55 ;;"EXIT ; *** Clean-up and quit"
56 ;;" K DA,DD,DIC,DIE,DIK,DINUM,DIR,DIRUT,DLAYGO,DO,DR,DTOUT,DUOUT,SPND0"
57 ;;" K SPNDATA,SPNDHD,SPNDIPCR,SPNCHKSM,SPNFIELD,SPNFOUND,SPNINCR,SPNMACRO"
58 ;;" K SPNMD0,SPNMD1,SPNNAME,SPNPFILE,SPNTYPE,X,Y"
59 ;;" Q"
60 ;;"PROCESS ; *** Process a macro"
61 ;;" S SPNNAME=$P(SPNDATA(0),U),SPNTYPE=$P(SPNDATA(0),U,2)"
62 ;;" S SPNPFILE=$P(SPNDATA(0),U,3),SPNCHKSM=$P(SPNDATA(0),U,4)"
63 ;;" S SPNDIPCR=$P(SPNDATA(0),U,5),SPNDHD=$P(SPNDATA(0),U,6)"
64 ;;" S (SPND0,SPNFOUND)=0"
65 ;;" F S SPND0=$O(^SPNL(154.8,""B"",SPNNAME,SPND0)) Q:SPND0'>0!SPNFOUND D"
66 ;;" . S SPNDATA=$G(^SPNL(154.8,SPND0,0))"
67 ;;" . I $P(SPNDATA,U,1,3)=$P(SPNDATA(0),U,1,3) S SPNFOUND=1"
68 ;;" . I SPNCHKSM=$P(SPNDATA,U,4)!'SPNFOUND Q"
69 ;;" . S SPNFOUND=0,DA=SPND0,DIK=""^SPNL(154.8,"" D ^DIK"
70 ;;" . Q"
71 ;;" I SPNFOUND W !,""Skipping Ad Hoc macro '"",SPNNAME,""', already exists."" Q"
72 ;;" W !,""Adding Ad Hoc macro '"",SPNNAME,""'."""
73 ;;" K DD,DIC,DINUM,DO S DIC=""^SPNL(154.8,"",DIC(0)=""LM"""
74 ;;" S DLAYGO=154.8,X=SPNNAME D FILE^DICN S SPNMD0=+Y"
75 ;;" I SPNMD0'>0 W !?5,""Could not add Ad Hoc macro '"",SPNNAME,""'?!"" Q"
76 ;;" S DR="".02////""_SPNTYPE_"";.03////""_SPNPFILE"
77 ;;" S DR=DR_"";.04////""_SPNCHKSM_"";.05////""_SPNDIPCR"
78 ;;" S DIE=""^SPNL(154.8,"",DA=SPNMD0 D ^DIE"
79 ;;" S $P(^SPNL(154.8,SPNMD0,0),U,6)=SPNDHD"
80 ;;" S SPNMD1=0,SPNINCR=$S(SPNTYPE=""s"":2,1:1)"
81 ;;" F SPNFIELD=1:SPNINCR S SPNDATA=$G(SPNDATA(SPNFIELD)) Q:SPNDATA="""" D"
82 ;;" . S SPNMD1=SPNMD1+1"
83 ;;" . S ^SPNL(154.8,SPNMD0,""FLD"",SPNMD1,0)=SPNDATA"
84 ;;" . I SPNTYPE=""p"" Q"
85 ;;" . S SPNDATA=$G(SPNDATA(SPNFIELD+1))"
86 ;;" . S ^SPNL(154.8,SPNMD0,""FLD"",SPNMD1,""FRTO"")=SPNDATA"
87 ;;" . Q"
88 ;;" S SPNDATA=$$GET1^DID(154.8,1,"""",""SPECIFIER"")_U_SPNMD1_U_SPNMD1"
89 ;;" S ^SPNL(154.8,SPNMD0,""FLD"",0)=SPNDATA"
90 ;;" S DIK=""^SPNL(154.8,"",DA=SPNMD0 D IX1^DIK"
91 ;;" Q"
92 ;;
93PROG2 ;; *** Routine that contains the Ad Hoc macros
94 ;;SPNRTN_" ;HISC/DAD-AD HOC REPORTS: EXPORTED MACROS ;"_SPNTODAY
95 ;;" ;;0.0;Package Name;;Mmm DD, YYYY"
96 ;;" ;;"_$P($T(SPNAHOCV+1),";",3,4)_";;"_$P($T(SPNAHOCV+1),";",6)
97 ;;" K SPNDATA S SPNFIELD=0"
98 ;;" F SPNMACRO=1:1 S SPNDATA=$T(MACRO+SPNMACRO) Q:SPNDATA="""" D"
99 ;;" . S SPNDATA=$P(SPNDATA,"";"",3,99)"
100 ;;" . I SPNDATA="""" D PROCESS^"_SPNPROG_" K SPNDATA S SPNFIELD=0 Q"
101 ;;" . S SPNDATA(SPNFIELD)=SPNDATA,SPNFIELD=SPNFIELD+1"
102 ;;" . Q"
103 ;;$S(SPNRTNXT]"":" G ^"_SPNRTNXT,1:" Q")
104 ;;"MACRO ;;Macro data"
105 ;;
Note: See TracBrowser for help on using the repository browser.