DVBAPBDY ;ALB/CMM BODY SYSTEM FILE UPDATE ;1/19/94
;;2.7;AMIE;;Apr 10, 1995
;
EN ;
N BDYCNT
S BDYCNT=0
D SET
D LOOP
D SG1
D EXIT
Q
SET N VAR
S VAR=" - Adding to 2507 Body System File."
D BUMPBLK^DVBAPOST
D BUMPBLK^DVBAPOST
D BUMPBLK^DVBAPOST
W !!!,VAR
D BUMP^DVBAPOST(VAR)
D BUMPBLK^DVBAPOST
SET1 ;
S DIF="^TMP($J,""DVBA"",",XCNP=0
K ^TMP($J,"DVBA")
F ROU="DVBAPB1" S X=ROU X ^%ZOSF("LOAD") W "."
K DIF,XCNP,ROU
Q
LOOP ;
N LP,LP1
S LP=0
F S LP=$O(^TMP($J,"DVBA",LP)) Q:(LP="") D
.K STOP
.S LINE=^TMP($J,"DVBA",LP,0)
.I (LINE'[";;")!(LINE[";AMIE;")!(LINE="") Q
.S BODY=$P(LINE,";",3)
.D GET
.I $D(STOP) Q
.I '$D(^DVB(396.7,BODY,1,0)) S ^DVB(396.7,BODY,1,0)="^396.701P^0^0"
.F LP1=4:1:999 S X=$P(LINE,";",LP1) Q:X="" D
..K STOP
..D CHK
..I $D(STOP) Q
..K DA
..D SETUP
..I $D(STOP) Q
..K DD,DO
..S DLAYGO=396,DIC="^DVB(396.7,"_BODY_",1,",DA(1)=BODY,DIC(0)="LMZ" D FILE^DICN
..K DIC,DA,DLAYGO,DD,DO
..I Y<0 D SE Q
..W:'(LP1#10) "."
..S BDYCNT=BDYCNT+1
Q
GET ;
K DIC
S DIC="^DVB(396.7,",X=BODY,DIC(0)="MOZ"
D ^DIC
I Y<0 D SE1 S STOP=1 Q
S BODY=+Y
Q
SE ;
N VAR
S VAR="Could not add code "_X_" to body system "_BODY
W !!,VAR
D BUMP^DVBAPOST(VAR)
Q
SE1 ;
N VAR
S VAR="Could not find body system "_BODY
W !!,VAR
D BUMP^DVBAPOST(VAR)
Q
CHK ;
N COD,COD1
S COD=$O(^DIC(31,"C",X,""))
I COD="" S STOP=1 W !,"Error adding exam "_X Q
S COD1=$O(^DVB(396.7,BODY,1,"B",COD,""))
I COD1'="" S STOP=1
Q
SG1 ;writes and updates the tmp global with the finish
N LP1,V1
F LP1=1:1:2 D BUMPBLK^DVBAPOST
S V1="I have updated "_BDYCNT_" exams to the 2507 Body System File!"
W !!,V1
D BUMP^DVBAPOST(V1)
D BUMPBLK^DVBAPOST
Q
EXIT ;
K X,Y,BODY,STOP,LINE,^TMP($J,"DVBA")
Q
SETUP ;
S DVBAVAR=$O(^DIC(31,"C",X,""))
I '$D(^DIC(31,DVBAVAR,0)) D SE2 S STOP=1 Q
S X=DVBAVAR
Q
SE2 ;
N VAR
S VAR="Zero node of the "_X_" code does not exist. Please investigate!"
W !!,VAR
D BUMP^DVBAPOST(VAR)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBAPBDY 2040 printed Nov 22, 2024@16:51:47 Page 2
DVBAPBDY ;ALB/CMM BODY SYSTEM FILE UPDATE ;1/19/94
+1 ;;2.7;AMIE;;Apr 10, 1995
+2 ;
EN ;
+1 NEW BDYCNT
+2 SET BDYCNT=0
+3 DO SET
+4 DO LOOP
+5 DO SG1
+6 DO EXIT
+7 QUIT
SET NEW VAR
+1 SET VAR=" - Adding to 2507 Body System File."
+2 DO BUMPBLK^DVBAPOST
+3 DO BUMPBLK^DVBAPOST
+4 DO BUMPBLK^DVBAPOST
+5 WRITE !!!,VAR
+6 DO BUMP^DVBAPOST(VAR)
+7 DO BUMPBLK^DVBAPOST
SET1 ;
+1 SET DIF="^TMP($J,""DVBA"","
SET XCNP=0
+2 KILL ^TMP($JOB,"DVBA")
+3 FOR ROU="DVBAPB1"
SET X=ROU
XECUTE ^%ZOSF("LOAD")
WRITE "."
+4 KILL DIF,XCNP,ROU
+5 QUIT
LOOP ;
+1 NEW LP,LP1
+2 SET LP=0
+3 FOR
SET LP=$ORDER(^TMP($JOB,"DVBA",LP))
if (LP="")
QUIT
Begin DoDot:1
+4 KILL STOP
+5 SET LINE=^TMP($JOB,"DVBA",LP,0)
+6 IF (LINE'[";;")!(LINE[";AMIE;")!(LINE="")
QUIT
+7 SET BODY=$PIECE(LINE,";",3)
+8 DO GET
+9 IF $DATA(STOP)
QUIT
+10 IF '$DATA(^DVB(396.7,BODY,1,0))
SET ^DVB(396.7,BODY,1,0)="^396.701P^0^0"
+11 FOR LP1=4:1:999
SET X=$PIECE(LINE,";",LP1)
if X=""
QUIT
Begin DoDot:2
+12 KILL STOP
+13 DO CHK
+14 IF $DATA(STOP)
QUIT
+15 KILL DA
+16 DO SETUP
+17 IF $DATA(STOP)
QUIT
+18 KILL DD,DO
+19 SET DLAYGO=396
SET DIC="^DVB(396.7,"_BODY_",1,"
SET DA(1)=BODY
SET DIC(0)="LMZ"
DO FILE^DICN
+20 KILL DIC,DA,DLAYGO,DD,DO
+21 IF Y<0
DO SE
QUIT
+22 if '(LP1#10)
WRITE "."
+23 SET BDYCNT=BDYCNT+1
End DoDot:2
End DoDot:1
+24 QUIT
GET ;
+1 KILL DIC
+2 SET DIC="^DVB(396.7,"
SET X=BODY
SET DIC(0)="MOZ"
+3 DO ^DIC
+4 IF Y<0
DO SE1
SET STOP=1
QUIT
+5 SET BODY=+Y
+6 QUIT
SE ;
+1 NEW VAR
+2 SET VAR="Could not add code "_X_" to body system "_BODY
+3 WRITE !!,VAR
+4 DO BUMP^DVBAPOST(VAR)
+5 QUIT
SE1 ;
+1 NEW VAR
+2 SET VAR="Could not find body system "_BODY
+3 WRITE !!,VAR
+4 DO BUMP^DVBAPOST(VAR)
+5 QUIT
CHK ;
+1 NEW COD,COD1
+2 SET COD=$ORDER(^DIC(31,"C",X,""))
+3 IF COD=""
SET STOP=1
WRITE !,"Error adding exam "_X
QUIT
+4 SET COD1=$ORDER(^DVB(396.7,BODY,1,"B",COD,""))
+5 IF COD1'=""
SET STOP=1
+6 QUIT
SG1 ;writes and updates the tmp global with the finish
+1 NEW LP1,V1
+2 FOR LP1=1:1:2
DO BUMPBLK^DVBAPOST
+3 SET V1="I have updated "_BDYCNT_" exams to the 2507 Body System File!"
+4 WRITE !!,V1
+5 DO BUMP^DVBAPOST(V1)
+6 DO BUMPBLK^DVBAPOST
+7 QUIT
EXIT ;
+1 KILL X,Y,BODY,STOP,LINE,^TMP($JOB,"DVBA")
+2 QUIT
SETUP ;
+1 SET DVBAVAR=$ORDER(^DIC(31,"C",X,""))
+2 IF '$DATA(^DIC(31,DVBAVAR,0))
DO SE2
SET STOP=1
QUIT
+3 SET X=DVBAVAR
+4 QUIT
SE2 ;
+1 NEW VAR
+2 SET VAR="Zero node of the "_X_" code does not exist. Please investigate!"
+3 WRITE !!,VAR
+4 DO BUMP^DVBAPOST(VAR)
+5 QUIT
