- IBDFUTL3 ;ALB/MAF - MAINTENANCE UTILITY CONT. - 4/24/95
- ;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
- ;
- ;
- REPLACE ; -- Replace invalid code with another valid code... it will be in
- ; the same place as the old invalid code.
- N IBDFVALM,VALMY,IBBLK,IBDFSLC,IBDFSLC1,IBDFSLC2,IBFORM,IBGRP,IBLIST,DA,IBSEL,ORDER,IEN
- S VALMBCK=""
- D EN^VALM2($G(XQORNOD(0))) G REP:'$O(VALMY(0)) S IBDFVALM=0
- D FULL^VALM1 S VALMBCK="R"
- F IBDFVALM=0:0 S IBDFVALM=$O(VALMY(IBDFVALM)) Q:IBDFVALM']"" S (IBDFSEL,DA)=$P($G(^TMP("CPTIDX",$J,IBDFVALM)),"^",4) I DA]"" S IBDFSLC=$G(^IBE(357.3,DA,0)),IBDFSLC1=$G(^IBE(357.3,DA,1,1,0)),IBDFSLC2=$G(^IBE(357.3,DA,1,2,0)) D
- .S IBFORM=$P($G(^TMP("CPTIDX",$J,IBDFVALM)),"^",5)
- .S IBGRP=$P(IBDFSLC,"^",4)
- .S IBLIST=$P(IBDFSLC,"^",3)
- .S ORDER=$P(IBDFSLC,"^",5)
- .S IBBLK=$P($G(^TMP("CPTIDX",$J,IBDFVALM)),"^",6)
- D REPLC(IBLIST,IBGRP,ORDER,.IBSEL,IBBLK,IBFORM)
- K IBDF,^TMP("UTIL",$J) D INIT^IBDFUTL S VALMBCK="R" Q
- ;
- ;
- REPLC(IBLIST,IBGRP,ORDER,IBSEL,IBBLK,IBFORM) ;allows the user to add a selection to the selection group for replacement - returns 0 if it was done, 1 otherwise
- N SUB,IBRTN
- ;
- Q:'$$FORMDSCR^IBDFU1C(.IBFORM)
- Q:$$BLKDESCR^IBDFU1B(.IBBLK) 1
- Q:$$LSTDESCR^IBDFU1(.IBLIST) 1
- S IBRTN=IBLIST("RTN")
- D RTNDSCR^IBDFU1B(.IBRTN)
- N QUIT S QUIT=0
- I IBRTN("ACTION")'=3 D NOGOOD^IBDF4 Q 1
- K @IBRTN("DATA_LOCATION")
- I '$$DORTN^IBDFU1B(.IBRTN) D NOGOOD^IBDF4 Q 1
- I '$D(@IBRTN("DATA_LOCATION")) Q
- D ADDREC^IBDF4(.QUIT,ORDER,.IBSEL) ;edits and adds the selection
- K @IBRTN("DATA_LOCATION")
- ; -- If a selection has been chosen, the old node is killed off and
- ; the block/selection list is updated.
- I QUIT=0 S DA=IBDFSEL,DIK="^IBE(357.3," D ^DIK K DIK D BLKCHNG^IBDF19(IBFORM,IBBLK)
- Q
- REP K IBDF D INIT^IBDFUTL S VALMBG=1,VALMBCK="R"
- Q
- IBDFUTL3 ;ALB/MAF - MAINTENANCE UTILITY CONT. - 4/24/95
- +1 ;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
- +2 ;
- +3 ;
- REPLACE ; -- Replace invalid code with another valid code... it will be in
- +1 ; the same place as the old invalid code.
- +2 NEW IBDFVALM,VALMY,IBBLK,IBDFSLC,IBDFSLC1,IBDFSLC2,IBFORM,IBGRP,IBLIST,DA,IBSEL,ORDER,IEN
- +3 SET VALMBCK=""
- +4 DO EN^VALM2($GET(XQORNOD(0)))
- IF '$ORDER(VALMY(0))
- GOTO REP
- SET IBDFVALM=0
- +5 DO FULL^VALM1
- SET VALMBCK="R"
- +6 FOR IBDFVALM=0:0
- SET IBDFVALM=$ORDER(VALMY(IBDFVALM))
- IF IBDFVALM']""
- QUIT
- SET (IBDFSEL,DA)=$PIECE($GET(^TMP("CPTIDX",$JOB,IBDFVALM)),"^",4)
- IF DA]""
- SET IBDFSLC=$GET(^IBE(357.3,DA,0))
- SET IBDFSLC1=$GET(^IBE(357.3,DA,1,1,0))
- SET IBDFSLC2=$GET(^IBE(357.3,DA,1,2,0))
- Begin DoDot:1
- +7 SET IBFORM=$PIECE($GET(^TMP("CPTIDX",$JOB,IBDFVALM)),"^",5)
- +8 SET IBGRP=$PIECE(IBDFSLC,"^",4)
- +9 SET IBLIST=$PIECE(IBDFSLC,"^",3)
- +10 SET ORDER=$PIECE(IBDFSLC,"^",5)
- +11 SET IBBLK=$PIECE($GET(^TMP("CPTIDX",$JOB,IBDFVALM)),"^",6)
- End DoDot:1
- +12 DO REPLC(IBLIST,IBGRP,ORDER,.IBSEL,IBBLK,IBFORM)
- +13 KILL IBDF,^TMP("UTIL",$JOB)
- DO INIT^IBDFUTL
- SET VALMBCK="R"
- QUIT
- +14 ;
- +15 ;
- REPLC(IBLIST,IBGRP,ORDER,IBSEL,IBBLK,IBFORM) ;allows the user to add a selection to the selection group for replacement - returns 0 if it was done, 1 otherwise
- +1 NEW SUB,IBRTN
- +2 ;
- +3 IF '$$FORMDSCR^IBDFU1C(.IBFORM)
- QUIT
- +4 IF $$BLKDESCR^IBDFU1B(.IBBLK)
- QUIT 1
- +5 IF $$LSTDESCR^IBDFU1(.IBLIST)
- QUIT 1
- +6 SET IBRTN=IBLIST("RTN")
- +7 DO RTNDSCR^IBDFU1B(.IBRTN)
- +8 NEW QUIT
- SET QUIT=0
- +9 IF IBRTN("ACTION")'=3
- DO NOGOOD^IBDF4
- QUIT 1
- +10 KILL @IBRTN("DATA_LOCATION")
- +11 IF '$$DORTN^IBDFU1B(.IBRTN)
- DO NOGOOD^IBDF4
- QUIT 1
- +12 IF '$DATA(@IBRTN("DATA_LOCATION"))
- QUIT
- +13 ;edits and adds the selection
- DO ADDREC^IBDF4(.QUIT,ORDER,.IBSEL)
- +14 KILL @IBRTN("DATA_LOCATION")
- +15 ; -- If a selection has been chosen, the old node is killed off and
- +16 ; the block/selection list is updated.
- +17 IF QUIT=0
- SET DA=IBDFSEL
- SET DIK="^IBE(357.3,"
- DO ^DIK
- KILL DIK
- DO BLKCHNG^IBDF19(IBFORM,IBBLK)
- +18 QUIT
- REP KILL IBDF
- DO INIT^IBDFUTL
- SET VALMBG=1
- SET VALMBCK="R"
- +1 QUIT
