- DVBAPRE ;ALB ISC/JLU-PREINIT ROUTINE ;02/02/91
- ;;2.7;AMIE;;Apr 10, 1995
- ;
- EN S CNT=1
- D REMD
- D CORSPEL
- Q
- ;
- REMD ;this entry point is to remove the 'D' cross reference in file 396.3
- D BUMPBLK^DVBAPOST,BUMPBLK^DVBAPOST,BUMPBLK^DVBAPOST
- S VAR="Removing the 'D' cross reference from file 396.3"
- D BUMP^DVBAPOST(VAR)
- W !,VAR
- REMD1 ;gets you around the displays
- N JL
- S JL=0
- F S JL=$O(^DD(396.3,17,1,JL)) Q:'JL I $D(^(JL,0)),^(0)="396.3^D^MUMPS" DO Q
- .S DIK="^DD(396.3,17,1,",DA(2)=396.3,DA(1)=17,DA=JL
- .D ^DIK
- .K ^DVB(396.3,"D")
- .S VAR="Cross reference and data for 'D' in 396.3 deleted!"
- .D BUMP^DVBAPOST(VAR)
- .D BUMPBLK^DVBAPOST
- .D BUMPBLK^DVBAPOST
- .W !,VAR
- .K DIK,DA
- .Q
- ;
- REMC ;to remove the 'C' cross reference
- S VAR="Removing the 'C' cross reference from 396"
- D BUMP^DVBAPOST(VAR)
- W !!,VAR
- REMC1 ;around the displays
- N JL
- S JL=0
- F S JL=$O(^DD(396,6.82,1,JL)) Q:'JL I $D(^(JL,0)),^(0)="396^C^MUMPS" DO Q
- .S DIK="^DD(396,6.82,1,",DA(2)=396,DA(1)=6.82,DA=JL
- .D ^DIK
- .K ^DVB(396,"C")
- .S VAR="Cross reference and data for 'C' in 396 deleted!"
- .D BUMP^DVBAPOST(VAR)
- .W !,VAR
- .K DI,DA
- .Q
- D BUMPBLK^DVBAPOST
- D BUMPBLK^DVBAPOST
- Q
- ;
- CORSPEL ;this subroutine is to correct the spelling of an entry in 396.6
- ;It should be removed for future versions of AMIE.
- ;
- N DVBAPRE
- S DVBAPRE=$O(^DVB(396.6,"B","EPILEPESY AND NARCOLEPSY",""))
- I DVBAPRE DO
- .S DIE="^DVB(396.6,",DA=DVBAPRE,DR=".01///EPILEPSY AND NARCOLEPSY"
- .D ^DIE
- .K DIE,DA,DR
- .S VAR="Renaming of ""EPILEPESY AND NARCOLEPSY"" to ""EPILEPSY AND NARCOLEPSY"" is complete!"
- .D BUMPBLK^DVBAPOST
- .D BUMPBLK^DVBAPOST
- .W !!,VAR,!!
- .D BUMP^DVBAPOST(VAR)
- .D BUMPBLK^DVBAPOST
- .D BUMPBLK^DVBAPOST
- .K VAR
- .Q
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBAPRE 1772 printed Jan 18, 2025@02:43:05 Page 2
- DVBAPRE ;ALB ISC/JLU-PREINIT ROUTINE ;02/02/91
- +1 ;;2.7;AMIE;;Apr 10, 1995
- +2 ;
- EN SET CNT=1
- +1 DO REMD
- +2 DO CORSPEL
- +3 QUIT
- +4 ;
- REMD ;this entry point is to remove the 'D' cross reference in file 396.3
- +1 DO BUMPBLK^DVBAPOST
- DO BUMPBLK^DVBAPOST
- DO BUMPBLK^DVBAPOST
- +2 SET VAR="Removing the 'D' cross reference from file 396.3"
- +3 DO BUMP^DVBAPOST(VAR)
- +4 WRITE !,VAR
- REMD1 ;gets you around the displays
- +1 NEW JL
- +2 SET JL=0
- +3 FOR
- SET JL=$ORDER(^DD(396.3,17,1,JL))
- if 'JL
- QUIT
- IF $DATA(^(JL,0))
- IF ^(0)="396.3^D^MUMPS"
- Begin DoDot:1
- +4 SET DIK="^DD(396.3,17,1,"
- SET DA(2)=396.3
- SET DA(1)=17
- SET DA=JL
- +5 DO ^DIK
- +6 KILL ^DVB(396.3,"D")
- +7 SET VAR="Cross reference and data for 'D' in 396.3 deleted!"
- +8 DO BUMP^DVBAPOST(VAR)
- +9 DO BUMPBLK^DVBAPOST
- +10 DO BUMPBLK^DVBAPOST
- +11 WRITE !,VAR
- +12 KILL DIK,DA
- +13 QUIT
- End DoDot:1
- QUIT
- +14 ;
- REMC ;to remove the 'C' cross reference
- +1 SET VAR="Removing the 'C' cross reference from 396"
- +2 DO BUMP^DVBAPOST(VAR)
- +3 WRITE !!,VAR
- REMC1 ;around the displays
- +1 NEW JL
- +2 SET JL=0
- +3 FOR
- SET JL=$ORDER(^DD(396,6.82,1,JL))
- if 'JL
- QUIT
- IF $DATA(^(JL,0))
- IF ^(0)="396^C^MUMPS"
- Begin DoDot:1
- +4 SET DIK="^DD(396,6.82,1,"
- SET DA(2)=396
- SET DA(1)=6.82
- SET DA=JL
- +5 DO ^DIK
- +6 KILL ^DVB(396,"C")
- +7 SET VAR="Cross reference and data for 'C' in 396 deleted!"
- +8 DO BUMP^DVBAPOST(VAR)
- +9 WRITE !,VAR
- +10 KILL DI,DA
- +11 QUIT
- End DoDot:1
- QUIT
- +12 DO BUMPBLK^DVBAPOST
- +13 DO BUMPBLK^DVBAPOST
- +14 QUIT
- +15 ;
- CORSPEL ;this subroutine is to correct the spelling of an entry in 396.6
- +1 ;It should be removed for future versions of AMIE.
- +2 ;
- +3 NEW DVBAPRE
- +4 SET DVBAPRE=$ORDER(^DVB(396.6,"B","EPILEPESY AND NARCOLEPSY",""))
- +5 IF DVBAPRE
- Begin DoDot:1
- +6 SET DIE="^DVB(396.6,"
- SET DA=DVBAPRE
- SET DR=".01///EPILEPSY AND NARCOLEPSY"
- +7 DO ^DIE
- +8 KILL DIE,DA,DR
- +9 SET VAR="Renaming of ""EPILEPESY AND NARCOLEPSY"" to ""EPILEPSY AND NARCOLEPSY"" is complete!"
- +10 DO BUMPBLK^DVBAPOST
- +11 DO BUMPBLK^DVBAPOST
- +12 WRITE !!,VAR,!!
- +13 DO BUMP^DVBAPOST(VAR)
- +14 DO BUMPBLK^DVBAPOST
- +15 DO BUMPBLK^DVBAPOST
- +16 KILL VAR
- +17 QUIT
- End DoDot:1
- +18 QUIT