IBDY338.m

IBDY338 ;ALB/DHH - POST INSTALL FOR PATCH IBD*3*38 ; OCT 1, 1999

 ;;3.0;AUTOMATED INFO COLLECTION SYS;**38**;APR 24, 1997

 ;

 D ASK,ASK1

 ;

 ;-- Add CPT Modifier Tool Kit Blocks to Tool Kit

 D AUTOINS

 Q

 ;

ASK ;-- Set ASK CPT MODIFIERS to yes for DG SELECT CPT PROCEDURE CODES

 ;   in the package interface file

 ;

 D MES^XPDUTL(">>> Updating DG SELECT CPT PROCEDURE CODES Package Interface.")

 N I,J,X

 S I=0

 F  S I=$O(^IBE(357.6,"B",$E("DG SELECT CPT PROCEDURE CODES",1,30),I)) Q:'I  D

 .I $P($G(^IBE(357.6,I,0)),"^")="DG SELECT CPT PROCEDURE CODES" S $P(^IBE(357.6,I,0),"^",21)=1

 Q

 ;

ASK1 ;-- Set ASK CPT MODIFIERS to yes for DG SELECT VISIT TYPE PROCEDURES

 ;   in the package interface file

 ;

 D MES^XPDUTL(">>> Updating DG SELECT VISIT TYPE CPT PROCEDURES Package Interface.")

 N I,J,X

 S I=0

 F  S I=$O(^IBE(357.6,"B",$E("DG SELECT VISIT TYPE CPT PROCEDURES",1,30),I)) Q:'I  D

 .I $P($G(^IBE(357.6,I,0)),"^")="DG SELECT VISIT TYPE CPT PROCEDURES" S $P(^IBE(357.6,I,0),"^",21)=1

 Q

 ;

AUTOINS ;-- Auto install CPT Modifier tool kit blocks into AICS Tool Kit

 N FORM,NEWFORM,FORMNM,CNT,CNT1,ARY,NAME,X,Y,NEWBLOCK,A,EXCLUDE,BLK,CNTF,CNTB

 D MES^XPDUTL(">>> Adding CPT Modifier Tool Kit Blocks to AICS Tool Kit.")

 S (CNTB,CNTF)=0

 ;

 ;-- Add all tool kit blocks

 S FORMNM="TOOL KIT"

 I '$O(^IBE(357,"B",FORMNM,0)) Q

 S ORD="" F  S ORD=$O(^IBE(358.1,"D",ORD)) Q:ORD=""  S BLK=0 F  S BLK=$O(^IBE(358.1,"D",ORD,BLK)) Q:'BLK  D

 .S NAME=$P($G(^IBE(358.1,+BLK,0)),"^")

 .Q:$P($G(^IBE(358.1,BLK,0)),"^",14)'=1  ;not toolkit

 .I $O(^IBE(357.1,"B",NAME,0)) D MES^XPDUTL("     Block "_NAME_" already exists") Q

 .D MES^XPDUTL("    Moving block '"_$P($G(^IBE(358.1,+BLK,0)),"^")_"' from Import/Export files to Tool Kit")

 .N IBTKBLK S IBTKBLK=1

 .S NEWBLOCK=$$COPYBLK^IBDFU2(BLK,$$TKFORM^IBDFU2C,358.1,357.1,"","",$$TKORDER^IBDF13),CNTB=CNTB+1

 .D:$G(NEWBLOCK) DLTBLK^IBDFU3(BLK,"",358.1)

 ;

 ;-- Clear workspace

 D DLTALL^IBDE2

 Q

PREINIT ; Pre-Init for Patch 38

 ; clearing workspace - imp/exp

 D MES^XPDUTL(">>> Clearing Import/Export Workspace Now...")

 D DLTALL^IBDE2

 Q

IBDY338   ;ALB/DHH - POST INSTALL FOR PATCH IBD*3*38 ; OCT 1, 1999

 +1       ;;3.0;AUTOMATED INFO COLLECTION SYS;**38**;APR 24, 1997

 +2       ;

 +3        DO ASK

           DO ASK1

 +4       ;

 +5       ;-- Add CPT Modifier Tool Kit Blocks to Tool Kit

 +6        DO AUTOINS

 +7        QUIT 

 +8       ;

ASK       ;-- Set ASK CPT MODIFIERS to yes for DG SELECT CPT PROCEDURE CODES

 +1       ;   in the package interface file

 +2       ;

 +3        DO MES^XPDUTL(">>> Updating DG SELECT CPT PROCEDURE CODES Package Interface.")

 +4        NEW I,J,X

 +5        SET I=0

 +6        FOR 

               SET I=$ORDER(^IBE(357.6,"B",$EXTRACT("DG SELECT CPT PROCEDURE CODES",1,30),I))

               IF 'I

                   QUIT 

               Begin DoDot:1

 +7                IF $PIECE($GET(^IBE(357.6,I,0)),"^")="DG SELECT CPT PROCEDURE CODES"

                       SET $PIECE(^IBE(357.6,I,0),"^",21)=1

               End DoDot:1

 +8        QUIT 

 +9       ;

ASK1      ;-- Set ASK CPT MODIFIERS to yes for DG SELECT VISIT TYPE PROCEDURES

 +1       ;   in the package interface file

 +2       ;

 +3        DO MES^XPDUTL(">>> Updating DG SELECT VISIT TYPE CPT PROCEDURES Package Interface.")

 +4        NEW I,J,X

 +5        SET I=0

 +6        FOR 

               SET I=$ORDER(^IBE(357.6,"B",$EXTRACT("DG SELECT VISIT TYPE CPT PROCEDURES",1,30),I))

               IF 'I

                   QUIT 

               Begin DoDot:1

 +7                IF $PIECE($GET(^IBE(357.6,I,0)),"^")="DG SELECT VISIT TYPE CPT PROCEDURES"

                       SET $PIECE(^IBE(357.6,I,0),"^",21)=1

               End DoDot:1

 +8        QUIT 

 +9       ;

AUTOINS   ;-- Auto install CPT Modifier tool kit blocks into AICS Tool Kit

 +1        NEW FORM,NEWFORM,FORMNM,CNT,CNT1,ARY,NAME,X,Y,NEWBLOCK,A,EXCLUDE,BLK,CNTF,CNTB

 +2        DO MES^XPDUTL(">>> Adding CPT Modifier Tool Kit Blocks to AICS Tool Kit.")

 +3        SET (CNTB,CNTF)=0

 +4       ;

 +5       ;-- Add all tool kit blocks

 +6        SET FORMNM="TOOL KIT"

 +7        IF '$ORDER(^IBE(357,"B",FORMNM,0))

               QUIT 

 +8        SET ORD=""

           FOR 

               SET ORD=$ORDER(^IBE(358.1,"D",ORD))

               IF ORD=""

                   QUIT 

               SET BLK=0

               FOR 

                   SET BLK=$ORDER(^IBE(358.1,"D",ORD,BLK))

                   IF 'BLK

                       QUIT 

                   Begin DoDot:1

 +9                    SET NAME=$PIECE($GET(^IBE(358.1,+BLK,0)),"^")

 +10      ;not toolkit

                       IF $PIECE($GET(^IBE(358.1,BLK,0)),"^",14)'=1

                           QUIT 

 +11                   IF $ORDER(^IBE(357.1,"B",NAME,0))

                           DO MES^XPDUTL("     Block "_NAME_" already exists")

                           QUIT 

 +12                   DO MES^XPDUTL("    Moving block '"_$PIECE($GET(^IBE(358.1,+BLK,0)),"^")_"' from Import/Export files to Tool Kit")

 +13                   NEW IBTKBLK

                       SET IBTKBLK=1

 +14                   SET NEWBLOCK=$$COPYBLK^IBDFU2(BLK,$$TKFORM^IBDFU2C,358.1,357.1,"","",$$TKORDER^IBDF13)

                       SET CNTB=CNTB+1

 +15                   IF $GET(NEWBLOCK)

                           DO DLTBLK^IBDFU3(BLK,"",358.1)

                   End DoDot:1

 +16      ;

 +17      ;-- Clear workspace

 +18       DO DLTALL^IBDE2

 +19       QUIT 

PREINIT   ; Pre-Init for Patch 38

 +1       ; clearing workspace - imp/exp

 +2        DO MES^XPDUTL(">>> Clearing Import/Export Workspace Now...")

 +3        DO DLTALL^IBDE2

 +4        QUIT