source: WorldVistAEHR/trunk/r/AUTOMATED_MED_INFO_EXCHANGE-DVBA-DVBC/DVBAPBDY.m@ 1259

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

initial load of WorldVistAEHR

File size: 1.9 KB
Line 
1DVBAPBDY ;ALB/CMM BODY SYSTEM FILE UPDATE ;1/19/94
2 ;;2.7;AMIE;;Apr 10, 1995
3 ;
4EN ;
5 N BDYCNT
6 S BDYCNT=0
7 D SET
8 D LOOP
9 D SG1
10 D EXIT
11 Q
12SET N VAR
13 S VAR=" - Adding to 2507 Body System File."
14 D BUMPBLK^DVBAPOST
15 D BUMPBLK^DVBAPOST
16 D BUMPBLK^DVBAPOST
17 W !!!,VAR
18 D BUMP^DVBAPOST(VAR)
19 D BUMPBLK^DVBAPOST
20SET1 ;
21 S DIF="^TMP($J,""DVBA"",",XCNP=0
22 K ^TMP($J,"DVBA")
23 F ROU="DVBAPB1" S X=ROU X ^%ZOSF("LOAD") W "."
24 K DIF,XCNP,ROU
25 Q
26LOOP ;
27 N LP,LP1
28 S LP=0
29 F S LP=$O(^TMP($J,"DVBA",LP)) Q:(LP="") D
30 .K STOP
31 .S LINE=^TMP($J,"DVBA",LP,0)
32 .I (LINE'[";;")!(LINE[";AMIE;")!(LINE="") Q
33 .S BODY=$P(LINE,";",3)
34 .D GET
35 .I $D(STOP) Q
36 .I '$D(^DVB(396.7,BODY,1,0)) S ^DVB(396.7,BODY,1,0)="^396.701P^0^0"
37 .F LP1=4:1:999 S X=$P(LINE,";",LP1) Q:X="" D
38 ..K STOP
39 ..D CHK
40 ..I $D(STOP) Q
41 ..K DA
42 ..D SETUP
43 ..I $D(STOP) Q
44 ..K DD,DO
45 ..S DLAYGO=396,DIC="^DVB(396.7,"_BODY_",1,",DA(1)=BODY,DIC(0)="LMZ" D FILE^DICN
46 ..K DIC,DA,DLAYGO,DD,DO
47 ..I Y<0 D SE Q
48 ..W:'(LP1#10) "."
49 ..S BDYCNT=BDYCNT+1
50 Q
51GET ;
52 K DIC
53 S DIC="^DVB(396.7,",X=BODY,DIC(0)="MOZ"
54 D ^DIC
55 I Y<0 D SE1 S STOP=1 Q
56 S BODY=+Y
57 Q
58SE ;
59 N VAR
60 S VAR="Could not add code "_X_" to body system "_BODY
61 W !!,VAR
62 D BUMP^DVBAPOST(VAR)
63 Q
64SE1 ;
65 N VAR
66 S VAR="Could not find body system "_BODY
67 W !!,VAR
68 D BUMP^DVBAPOST(VAR)
69 Q
70CHK ;
71 N COD,COD1
72 S COD=$O(^DIC(31,"C",X,""))
73 I COD="" S STOP=1 W !,"Error adding exam "_X Q
74 S COD1=$O(^DVB(396.7,BODY,1,"B",COD,""))
75 I COD1'="" S STOP=1
76 Q
77SG1 ;writes and updates the tmp global with the finish
78 N LP1,V1
79 F LP1=1:1:2 D BUMPBLK^DVBAPOST
80 S V1="I have updated "_BDYCNT_" exams to the 2507 Body System File!"
81 W !!,V1
82 D BUMP^DVBAPOST(V1)
83 D BUMPBLK^DVBAPOST
84 Q
85EXIT ;
86 K X,Y,BODY,STOP,LINE,^TMP($J,"DVBA")
87 Q
88SETUP ;
89 S DVBAVAR=$O(^DIC(31,"C",X,""))
90 I '$D(^DIC(31,DVBAVAR,0)) D SE2 S STOP=1 Q
91 S X=DVBAVAR
92 Q
93SE2 ;
94 N VAR
95 S VAR="Zero node of the "_X_" code does not exist. Please investigate!"
96 W !!,VAR
97 D BUMP^DVBAPOST(VAR)
98 Q
Note: See TracBrowser for help on using the repository browser.