- 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 Mar 13, 2025@20:46:14 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
