Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: XINDX12

XINDX12.m

Go to the documentation of this file. 
  1. XINDX12 ;OSE/CJE - Create phantom routines for build components ;03/01/2018  8:37 AM
  1.  ;;7.3;TOOLKIT;**140,147,148**;Apr 25, 1995;Build 3
  1.  ; Per VHA Directive 2004-038, this routine should not be modified.
  1.  ; Entire routine authored by Chirstopher Edwards
  1.  ; p148 remove all status writes, they are now done in XINDX11
  1.  ; Variables passed through the stack:
  1.  ; B = {IEN}
  1.  ; INDLC = {counter}
  1.  ; INDRN = {faux routine prefix}
  1.  ; INDC = {IEN} ; {NAME} - {DISPLAY NAME}
  1.  ; INDX = {code to be XINDEXED}
  1.  ; INDL = {NAME field (.01) of IEN}
  1.  ;
  1.  ; FAUX Routine Structure
  1.  ; ^UTILITY($J,1,INDRN,0,INDLC,0)={Field Name (INDC)}
  1.  ; ^UTILITY($J,1,INDRN,0,INDLC+1,0)={MUMPS Code (INDX)}
  1.  ;
  1. SORT ;Process Sort Templates
  1.  ; ========  =====  ===============================  ===================================  =============================================
  1.  ; File      Field  Field Name                       Global Location                      Comments
  1.  ; ========  =====  ===============================  ===================================  =============================================
  1.  ; .401      1815   ROUTINE INVOKED                  ^DIBT(D0,ROU)
  1.  ; .401      1816   PREVIOUS ROUTINE INVOKED         ^DIBT(D0,ROUOLD)
  1.  ; .4014     10     GET CODE                         ^DIBT(D0,2,D1,GET)                   Part of Sort Field Data Subfile
  1.  ; .4014     11     QUERY CONDITION                  ^DIBT(D0,2,D1,QCON)                  Part of Sort Field Data Subfile
  1.  ; .4014     16     COMPUTED FIELD CODE              ^DIBT(D0,2,D1,CM)                    Part of Sort Field Data Subfile
  1.  ; .4014     20     SUBHEADER OUTPUT                 ^DIBT(D0,2,D1,OUT)                   Part of Sort Field Data Subfile
  1.  ; .401418   5      RELATIONAL CODE                  ^DIBT(D0,2,D1,2,D2,RCOD)             Part of Relational Jump Field Data Subfile
  1.  ; .401419   2      OVERFLOW CODE                    ^DIBT(D0,2,D1,3,D2,OVF0)             Part of Overflow Data Subfile
  1.  ; .4011624  4      DISPAR(0,n,OUT)                  ^DIBT(D0,BY0D,D1,2)                  Part of Sort Range Data For BY(0)
  1.  ; ========  =====  ===============================  ===================================  =============================================
  1.  S INDX=$S($L($G(^DIBT(B,"ROU"))):"D "_$G(^DIBT(B,"ROU")),1:";")
  1.  S INDC=B_" ; "_INDL_" - ROUTINE INVOKED (#1815)"
  1.  D ADD^XINDX11
  1.  ;
  1.  S INDX=$S($L($G(^DIBT(B,"ROUOLD"))):"D ^"_$G(^DIBT(B,"ROUOLD")),1:";")
  1.  S INDC=" ; "_INDL_" - PREVIOUS ROUTINE INVOKED (#1816)"
  1.  D ADD^XINDX11
  1.  ;
  1.  N SUB,SUB2
  1.  S (SUB,SUB2)=""
  1.  F  S SUB=$O(^DIBT(B,2,SUB)) Q:SUB=""  Q:SUB'=+SUB  D
  1.  . S INDX=$S($L($G(^DIBT(B,2,SUB,"GET"))):$G(^DIBT(B,2,SUB,"GET")),1:";")
  1.  . S INDC=B_"P"_SUB_" ; "_INDL_" - GET CODE (#10) - "_SUB
  1.  . D ADD^XINDX11
  1.  . ;
  1.  . S INDX=$S($L($G(^DIBT(B,2,SUB,"QCON"))):$G(^DIBT(B,2,SUB,"QCON")),1:";")
  1.  . S INDC=" ; "_INDL_" - QUERY CONDITION (#11) - "_SUB
  1.  . D ADD^XINDX11
  1.  . ;
  1.  . S INDX=$S($L($G(^DIBT(B,2,SUB,"CM"))):$G(^DIBT(B,2,SUB,"CM")),1:";")
  1.  . S INDC=" ; "_INDL_" - COMPUTED FIELD CODE (#16) - "_SUB
  1.  . D ADD^XINDX11
  1.  . ;
  1.  . S INDX=$S($L($G(^DIBT(B,2,SUB,"OUT"))):$G(^DIBT(B,2,SUB,"OUT")),1:";")
  1.  . S INDC=" ; "_INDL_" - SUBHEADER OUTPUT (#20) - "_SUB
  1.  . D ADD^XINDX11
  1.  . ;
  1.  . F  S SUB2=$O(^DIBT(B,2,SUB,2,SUB2)) Q:SUB2=""  Q:SUB2'=+SUB2  D
  1.  . . S INDX=$S($L($G(^DIBT(B,2,SUB,2,SUB2,"RCOD"))):$G(^DIBT(B,2,SUB,2,SUB2,"RCOD")),1:";")
  1.  . . S INDC=B_"RCOD"_SUB_"P"_SUB2_" ; "_INDL_" - RELATIONAL CODE (#5) - "_SUB_" - "_SUB2
  1.  . . D ADD^XINDX11
  1.  . ;
  1.  . S SUB2=""
  1.  . F  S SUB2=$O(^DIBT(B,2,SUB,3,SUB2)) Q:SUB2=""  Q:SUB2'=+SUB2  D
  1.  . . S INDX=$S($L($G(^DIBT(B,2,SUB,3,SUB2,"OVF0"))):$G(^DIBT(B,2,SUB,3,SUB2,"OVF0")),1:";")
  1.  . . S INDC=B_"OVF0"_SUB_"P"_SUB2_" ; "_INDL_" - OVERFLOW CODE (#2) - "_SUB_" - "_SUB2
  1.  . . D ADD^XINDX11
  1.  ;
  1.  S SUB=""
  1.  F  S SUB=$O(^DIBT(B,"BY0D",SUB)) Q:SUB=""  Q:SUB'=+SUB  D
  1.  . S INDX=$S($L($G(^DIBT(B,"BY0D",SUB,2))):$G(^DIBT(B,"BY0D",SUB,2)),1:";")
  1.  . S INDC=B_"BY0D"_SUB_" ; "_INDL_" - DISPAR (#4) - "_SUB
  1.  . D ADD^XINDX11
  1.  Q
  1.  ; Input and Print templates are implemented in XINDX13
  1.  ; The executable code doesn't have defined field numbers in the DD,
  1.  ; So we put all of the lines together as "EXECUTABLE CODE"
  1.  ; Thanks to Sam Habiel for the implementation requried to support this.
  1. INPUT ; Input Templates
  1.  S INDC=B_" ; "_INDL_" - EXECUTABLE CODE"
  1.  D ADD^XINDX11
  1.  D DIETM^XINDX13
  1.  Q
  1. PRINT ; Print Templates
  1.  S INDC=B_" ; "_INDL_" - EXECUTABLE CODE"
  1.  D ADD^XINDX11
  1.  D DIPTM^XINDX13
  1.  Q
  1. FORM ;Process Forms
  1.  ; ========  =====  ===============================  ===================================  =============================================
  1.  ; File      Field  Field Name                       Global Location                      Comments
  1.  ; ========  =====  ===============================  ===================================  =============================================
  1.  ; .403      11     PRE ACTION                       ^DIST(.403,D0,11)
  1.  ; .403      12     POST ACTION                      ^DIST(.403,D0,12)
  1.  ; .403      14     POST SAVE                        ^DIST(.403,D0,14)
  1.  ; .403      20     DATA VALIDATION                  ^DIST(.403,D0,20)
  1.  ; .4031     11     PRE ACTION                       ^DIST(.403,D0,40,D1,11)
  1.  ; .4031     12     POST ACTION                      ^DIST(.403,D0,40,D1,12)
  1.  ; .4032     11     PRE ACTION                       ^DIST(.403,D0,40,D1,40,D2,11)
  1.  ; .4032     12     POST ACTION                      ^DIST(.403,D0,40,D1,40,D2,12)
  1.  ; .4032     98     COMPUTED MULTIPLE                ^DIST(.403,D0,40,D1,40,D2,COMP MUL)
  1.  ; ========  =====  ===============================  ===================================  =============================================
  1.  S INDX=$S($L($G(^DIST(.403,B,11))):$G(^DIST(.403,B,11)),1:";")
  1.  S INDC=B_" ; "_INDL_" - PRE ACTION (#11)"
  1.  D ADD^XINDX11
  1.  ;
  1.  S INDX=$S($L($G(^DIST(.403,B,12))):$G(^DIST(.403,B,12)),1:";")
  1.  S INDC=" ; "_INDL_" - POST ACTION (#12)"
  1.  D ADD^XINDX11
  1.  ;
  1.  S INDX=$S($L($G(^DIST(.403,B,14))):$G(^DIST(.403,B,14)),1:";")
  1.  S INDC=" ; "_INDL_" - POST SAVE (#14)"
  1.  D ADD^XINDX11
  1.  ;
  1.  S INDX=$S($L($G(^DIST(.403,B,20))):$G(^DIST(.403,B,20)),1:";")
  1.  S INDC=" ; "_INDL_" - DATA VALIDATION (#20)"
  1.  D ADD^XINDX11
  1.  ;
  1.  N SUB,SUB2
  1.  S (SUB,SUB2)=""
  1.  F  S SUB=$O(^DIST(.403,B,40,SUB)) Q:SUB=""  Q:SUB'=+SUB  D
  1.  . S INDX=$S($L($G(^DIST(.403,B,40,SUB,11))):$G(^DIST(.403,B,40,SUB,11)),1:";")
  1.  . S INDC=B_"P"_SUB_" ; "_INDL_" - PRE ACTION FILE (#.4031) FIELD (#11) - "_SUB
  1.  . D ADD^XINDX11
  1.  . ;
  1.  . S INDX=$S($L($G(^DIST(.403,B,40,SUB,12))):$G(^DIST(.403,B,40,SUB,12)),1:";")
  1.  . S INDC=" ; "_INDL_" - POST ACTION FILE (#.4031) FIELD (#12) - "_SUB
  1.  . D ADD^XINDX11
  1.  . ;
  1.  . F  S SUB2=$O(^DIST(.403,B,40,SUB,40,SUB2)) Q:SUB2=""  Q:SUB2'=+SUB2  D
  1.  . . S INDX=$S($L($G(^DIST(.403,B,40,SUB,40,SUB2,11))):$G(^DIST(.403,B,40,SUB,40,SUB2,11)),1:";")
  1.  . . S INDC=B_"P"_SUB_"P"_SUB2_" ; "_INDL_" - PRE ACTION FILE (#.4032) FIELD (#11) - "_SUB_" - "_SUB2
  1.  . . D ADD^XINDX11
  1.  . . ;
  1.  . . S INDX=$S($L($G(^DIST(.403,B,40,SUB,40,SUB2,12))):$G(^DIST(.403,B,40,SUB,40,SUB2,12)),1:";")
  1.  . . S INDC=" ; "_INDL_" - POST ACTION FILE (#.4032) FIELD (#12) - "_SUB_" - "_SUB2
  1.  . . D ADD^XINDX11
  1.  . . ;
  1.  . . S INDX=$S($L($G(^DIST(.403,B,40,SUB,40,SUB2,"COMP MUL"))):$G(^DIST(.403,B,40,SUB,40,SUB2,"COMP MUL")),1:";")
  1.  . . S INDC=" ; "_INDL_" - COMPUTED MULTIPLE FILE (#.4032) FIELD (#98) - "_SUB_" - "_SUB2
  1.  . . D ADD^XINDX11
  1.  Q
  1. DIALOG ;Process Dialogs
  1.  ; ========  =====  ===============================  ===================================  =============================================
  1.  ; File      Field  Field Name                       Global Location                      Comments
  1.  ; ========  =====  ===============================  ===================================  =============================================
  1.  ; .84       6      POST MESSAGE ACTION              ^DI(.84,D0,6)
  1.  ; ========  =====  ===============================  ===================================  =============================================
  1.  S INDX=$S($L($G(^DI(.84,B,6))):$G(^DI(.84,B,6)),1:";")
  1.  S INDC=B_" ; "_INDL_" - POST MESSAGE ACTION (#6)"
  1.  D ADD^XINDX11
  1.  Q
  1. HELP ;Process Help Frames
  1.  ; ========  =====  ===============================  ===================================  =============================================
  1.  ; File      Field  Field Name                       Global Location                      Comments
  1.  ; ========  =====  ===============================  ===================================  =============================================
  1.  ; 9.2       10.1   ENTRY EXECUTE STATEMENT          ^DIC(9.2,D0,10.1)
  1.  ; 9.2       10.2   EXIT EXECUTE STATEMENT           ^DIC(9.2,D0,10.2)
  1.  ; ========  =====  ===============================  ===================================  =============================================
  1.  S INDX=$S($L($G(^DIC(9.2,B,10.1))):$G(^DIC(9.2,B,10.1)),1:";")
  1.  S INDC=B_" ; "_INDL_" - ENTRY EXECUTE STATEMENT (#10.1)"
  1.  D ADD^XINDX11
  1.  ;
  1.  S INDX=$S($L($G(^DIC(9.2,B,10.2))):$G(^DIC(9.2,B,10.2)),1:";")
  1.  S INDC=" ; "_INDL_" - EXIT EXECUTE STATEMENT (#10.2)"
  1.  D ADD^XINDX11
  1.  Q
  1. KEY ;Process Security Keys
  1.  ; ========  =====  ===============================  ===================================  =============================================
  1.  ; File      Field  Field Name                       Global Location                      Comments
  1.  ; ========  =====  ===============================  ===================================  =============================================
  1.  ; 19.1      4      GRANTING CONDITION               ^DIC(19.1,D0,4)
  1.  ; ========  =====  ===============================  ===================================  =============================================
  1.  S INDX=$S($L($G(^DIC(19.1,B,4))):$G(^DIC(19.1,B,4)),1:";")
  1.  S INDC=B_" ; "_INDL_" - GRANTING CONDITION (#4)"
  1.  D ADD^XINDX11
  1.  Q
  1. LIST ;Process List Templates
  1.  ; ========  =====  ===============================  ===================================  =============================================
  1.  ; File      Field  Field Name                       Global Location                      Comments
  1.  ; ========  =====  ===============================  ===================================  =============================================
  1.  ; 409.61    100    HEADER CODE                      ^SD(409.61,D0,HDR)
  1.  ; 409.61    102    EXPAND CODE                      ^SD(409.61,D0,EXP)
  1.  ; 409.61    103    HELP CODE                        ^SD(409.61,D0,HLP)
  1.  ; 409.61    105    EXIT CODE                        ^SD(409.61,D0,FNL)
  1.  ; 409.61    106    ENTRY CODE                       ^SD(409.61,D0,INIT)
  1.  ; 409.61    107    ARRAY NAME                       ^SD(409.61,D0,ARRAY)                 Holds a variable name prefaced by a space
  1.  ; ========  =====  ===============================  ===================================  =============================================
  1.  S INDX=$S($L($G(^SD(409.61,B,"HDR"))):$G(^SD(409.61,B,"HDR")),1:";")
  1.  S INDC=B_" ; "_INDL_" - HEADER CODE (#100)"
  1.  D ADD^XINDX11
  1.  ;
  1.  S INDX=$S($L($G(^SD(409.61,B,"EXP"))):$G(^SD(409.61,B,"EXP")),1:";")
  1.  S INDC=" ; "_INDL_" - EXPAND CODE (#102)"
  1.  D ADD^XINDX11
  1.  ;
  1.  S INDX=$S($L($G(^SD(409.61,B,"HLP"))):$G(^SD(409.61,B,"HLP")),1:";")
  1.  S INDC=" ; "_INDL_" - HELP CODE (#103)"
  1.  D ADD^XINDX11
  1.  ;
  1.  S INDX=$S($L($G(^SD(409.61,B,"FNL"))):$G(^SD(409.61,B,"FNL")),1:";")
  1.  S INDC=" ; "_INDL_" - EXIT CODE (#105)"
  1.  D ADD^XINDX11
  1.  ;
  1.  S INDX=$S($L($G(^SD(409.61,B,"INIT"))):$G(^SD(409.61,B,"INIT")),1:";")
  1.  S INDC=" ; "_INDL_" - ENTRY CODE (#106)"
  1.  D ADD^XINDX11
  1.  ;
  1.  N INDX1 ;p147 - remove space preceding ARRAY NAME
  1.  S INDX1=$G(^SD(409.61,B,"ARRAY"))
  1.  S INDX=$S($L(INDX1):"I $L("_$S($E(INDX1)=" ":$E(INDX1,2,50),1:INDX1)_") Q",1:";")
  1.  S INDC=" ; "_INDL_" - ARRAY NAME (#107)"
  1.  D ADD^XINDX11
  1.  Q
  1. PROTOCOL ;Process Protocols
  1.  ; ========  =====  ===============================  ===================================  =============================================
  1.  ; File      Field  Field Name                       Global Location                      Comments
  1.  ; ========  =====  ===============================  ===================================  =============================================
  1.  ; 101       15     EXIT ACTION                      ^ORD(101,D0,15) E1,245
  1.  ; 101       20     ENTRY ACTION                     ^ORD(101,D0,20) E1,245
  1.  ; 101       24     SCREEN                           ^ORD(101,D0,24) E1,245
  1.  ; 101       26     HEADER                           ^ORD(101,D0,26) E1,245
  1.  ; 101       27     MENU HELP                        ^ORD(101,D0,27) E1,245
  1.  ; 101       100    ORDER PRINT ACTION               ^ORD(101,D0,100) E1,245
  1.  ; 101       100.1  ORDER CANCEL ACTION              ^ORD(101,D0,100.1) E1,245
  1.  ; 101       100.2  ORDER PURGE ACTION               ^ORD(101,D0,100.2) E1,245
  1.  ; 101       771    PROCESSING ROUTINE               ^ORD(101,D0,771) E1,245
  1.  ; 101       772    RESPONSE PROCESSING ROUTINE      ^ORD(101,D0,772) E1,245
  1.  ; 101       774    ROUTING LOGIC                    ^ORD(101,D0,774) E1,245
  1.  ; 101       21     REQUIRED VARIABLES               ^ORD(101,D0,21,D1,0)                 Required Variables sub file
  1.  ; 101.05    .02    METHOD ACTION                    ^ORD(101,D0,101.05,D1,1) E1,245      Method sub file
  1.  ; ========  =====  ===============================  ===================================  =============================================
  1.  K INDN
  1.  S INDN=$P($G(^ORD(101,B,0)),U,1)
  1.  S INDX=$S($L($G(^ORD(101,B,15))):$G(^ORD(101,B,15)),1:";")
  1.  S INDC=B_" ; "_INDN_" - EXIT ACTION (#15)"
  1.  D ADD^XINDX11
  1.  ;
  1.  S INDX=$S($L($G(^ORD(101,B,20))):$G(^ORD(101,B,20)),1:";")
  1.  S INDC=" ; "_INDN_" - ENTRY ACTION (#20)"
  1.  D ADD^XINDX11
  1.  ;
  1.  S INDX=$S($L($G(^ORD(101,B,24))):$G(^ORD(101,B,24)),1:";")
  1.  S INDC=" ; "_INDN_" - SCREEN (#24)"
  1.  D ADD^XINDX11
  1.  ;
  1.  S INDX=$S($L($G(^ORD(101,B,26))):$G(^ORD(101,B,26)),1:";")
  1.  S INDC=" ; "_INDN_" - HEADER (#26)"
  1.  D ADD^XINDX11
  1.  ;
  1.  S INDX=$S($L($G(^ORD(101,B,27))):$G(^ORD(101,B,27)),1:";")
  1.  S INDC=" ; "_INDN_" - MENU HELP (#27)"
  1.  D ADD^XINDX11
  1.  ;
  1.  S INDX=$S($L($G(^ORD(101,B,100))):$G(^ORD(101,B,100)),1:";")
  1.  S INDC=" ; "_INDN_" - ORDER PRINT ACTION (#100)"
  1.  D ADD^XINDX11
  1.  ;
  1.  S INDX=$S($L($G(^ORD(101,B,100.1))):$G(^ORD(101,B,100.1)),1:";")
  1.  S INDC=" ; "_INDN_" - ORDER CANCEL ACTION (#100.1)"
  1.  D ADD^XINDX11
  1.  ;
  1.  S INDX=$S($L($G(^ORD(101,B,100.2))):$G(^ORD(101,B,100.2)),1:";")
  1.  S INDC=" ; "_INDN_" - ORDER PURGE ACTION (#100.2)"
  1.  D ADD^XINDX11
  1.  ;
  1.  S INDX=$S($L($G(^ORD(101,B,771))):$G(^ORD(101,B,771)),1:";")
  1.  S INDC=" ; "_INDN_" - PROCESSING ROUTINE (#771)"
  1.  D ADD^XINDX11
  1.  ;
  1.  S INDX=$S($L($G(^ORD(101,B,772))):$G(^ORD(101,B,772)),1:";")
  1.  S INDC=" ; "_INDN_" - ORDER PURGE ACTION (#772)"
  1.  D ADD^XINDX11
  1.  ;
  1.  S INDX=$S($L($G(^ORD(101,B,774))):$G(^ORD(101,B,774)),1:";")
  1.  S INDC=" ; "_INDN_" - ROUTING LOGIC (#774)"
  1.  D ADD^XINDX11
  1.  ;
  1.  N SUB
  1.  S SUB=""
  1.  ;F  S SUB=$O(^ORD(101,B,21,SUB)) Q:SUB=""  Q:SUB'=+SUB  D
  1.  ;why does a list of required variable needs to check the HL7 MESSAGE (#6) field, which is no longer used  rsd
  1.  ;. S INDX=$S($L($E($G(^ORD(101,B,21,SUB,0)),1,17)):"$G("_$E($G(^HL(771,B,"MSG",SUB,"R")),1,17)_")",1:";")
  1.  ;. I INDX="D Q" S INDX=";"
  1.  ;. S INDC=B_"R"_SUB_" ; "_INDN_" - REQUIRED VARIABLES SUB FILE (#101.021) REQUIRED VARIABLES (#1) - "_SUB
  1.  ;. D ADD^XINDX11
  1.  ;
  1.  S SUB=""
  1.  F  S SUB=$O(^ORD(101,B,101.05,SUB)) Q:SUB=""  Q:SUB'=+SUB  D
  1.  . S INDX=$S($L($G(^ORD(101,B,101.05,SUB,1))):$G(^ORD(101,B,101.05,SUB,1)),1:";")
  1.  . I INDX="D Q" S INDX=";"
  1.  . S INDC=B_"M"_SUB_" ; "_INDN_" - METHOD SUB FILE (#101.05) METHOD ACTION (#.02) - "_SUB
  1.  . D ADD^XINDX11
  1.  ;
  1.  Q
  1. HL7AP ; Process HL7 Application Parameters
  1.  ; ========  =====  ===============================  ===================================  =============================================
  1.  ; File      Field  Field Name                       Global Location                      Comments
  1.  ; ========  =====  ===============================  ===================================  =============================================
  1.  ; 771.06    1      PROCESSING ROUTINE               ^HL(771,D0,MSG,D1,R)
  1.  ; ========  =====  ===============================  ===================================  =============================================
  1.  N SUB
  1.  S SUB=""
  1.  F  S SUB=$O(^HL(771,B,"MSG",SUB)) Q:SUB=""  Q:SUB'=+SUB  D
  1.  . S INDX=$S($L($G(^HL(771,B,"MSG",SUB,"R"))):"D "_$G(^HL(771,B,"MSG",SUB,"R")),1:";")
  1.  . I INDX="D Q" S INDX=";"
  1.  . S INDC=B_"P"_SUB_" ; "_INDL_" - HL7 MESSAGE SUB FILE (#771.06) PROCESSING ROUTINE (#1) - "_SUB
  1.  . D ADD^XINDX11
  1.  Q
  1. RPC ; Process Remote Procedures
  1.  ; ========  =====  ===============================  ===================================  =============================================
  1.  ; File      Field  Field Name                       Global Location                      Comments
  1.  ; ========  =====  ===============================  ===================================  =============================================
  1.  ; 8994      .02    TAG                              ^XWB(8994,D0,0) Piece 2              Needs to be concatenated with ROUTINE
  1.  ; 8994      .03    ROUTINE                          ^XWB(8994,D0,0) Piece 3
  1.  ; ========  =====  ===============================  ===================================  =============================================
  1.  S INDX=$S($L($P($G(^XWB(8994,B,0)),U,2))&($L($P($G(^XWB(8994,B,0)),U,3))):"D "_$P($G(^XWB(8994,B,0)),U,2)_"^"_$P($G(^XWB(8994,B,0)),U,3),1:";")
  1.  S INDC=B_" ; "_INDL_" - TAG ROUTINE (#.02 & .03)"
  1.  D ADD^XINDX11
  1.  Q