IBDFUTL3.m

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