- 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBDY338 2129 printed Feb 19, 2025@00:21:44 Page 2
- 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