Routine: TIUZRT

TIUZRT ; DAL/GT-NDS - TIU -CALLABLE ENTRY POINTS FOR ZRT SEGEMENT ;9/6/16

 ;;1.0;TEXT INTEGRATION UTILITIES;**309**;Jun 20, 1997;Build 5

ZRT ;Manipulate update of MFN ZRT segment for 8926.1 file

 I IEN,((NAME="Term")!(NAME="Status")) K XXIEN ;This is the indication that it's first update for any subfile

 S:$D(HLNODE(1)) HLNODE=HLNODE_HLNODE(1)

    G 89261:IFN=8926.1

89261 ;Manipulate update of MFN ZRT segment for 8926.1 File

 N X,XX,ERR,IENS,IEN1,IENX,X1,X2,X4,DA,DIK,I,FDAA

 I IEN,NAME="VistA_Mapping_Target" D  Q  ;ZRT^VistA_CodingSystem_Mapping^LOINC:90701,90743

 .S X=$P(HLNODE,HLFS,3) ;X=LOINC:90701,90743

 .I '$L(X)!(X="""""") D DS(8926.12,IEN) S OUT=1 Q  ;Q:$G(OUT)  ;If there is nothing coming from Push, wipe anything was there before

 .I '$G(XXIEN(8926.12)) D DS(8926.12,IEN)  S XXIEN(8926.12)=1 ;CLEAN SUBFILE ENTRY

 .S X1=$P(X,":"),X2=$P(X,":",2)

 .D DUP(8926.12,X1,X2) ; Checup for duplicate coding system (ICD, 10D, CPT...) and codes

 .Q:$G(ERROR)

 .S IENS=IEN_","

 .S IEN1="+1,",FDAA(8926.12,"+1,"_IENS,.01)=X1

 .F I=2:1 S X4=$P(X2,",",I-1) Q:'$L(X4)   S IENX="+"_I_","_IEN1_IENS,FDAA(8926.121,IENX,.01)=X4

 .D:$D(FDAA) UPDATE^DIE("","FDAA",,"ERR")

 .I $D(ERR) D  Q

 ..S ERROR="1^subfile update error SUBFILE#: 8926.121 HLNODE:"_HLNODE

 ..D EM^XUMF1H(ERROR,.ERR)

 .Q:$G(ERROR)

 .S OUT=1

DS(SUBFILE,IENS) ;Delete subfile

 N ROOT,IDX,X

 S ROOT=$$ROOT^DILFD(SUBFILE,","_IENS,1)

 S IDX=0 F  S IDX=$O(@ROOT@(IDX)) Q:'IDX  D

 .N DA,DIK,DIC S DA(1)=+IENS,DA=IDX,DIK=$P(ROOT,")")_"," D ^DIK

DUP(SUB,X1,X2) ;

 ;Checkup for duplicate coding system (ICD, 10D, CPT...)

 D GETS^DIQ(IFN,IEN_",","**","","TMP") ;TMP(8926.12 - .128,"1,7,",.01)=86485   X1=CPT   X2=1234,4567,7890

 S II="" F  S II=$O(TMP(SUB,II)) Q:'II  S X3=$G(TMP(SUB,II,.01)) I $L(X3),X3=X1 D  Q

 .S ERROR="1^Error - "_II_" Duplicate Coding System"_" File #: "_IFN_" HLNODE="_HLNODE

 Q:$G(ERROR)

 ;Checkup for duplicate codes. (CPT:90701,90743,90701)

 N X6

 F I=1:1 S X5=$P(X2,",",I) Q:'$L(X5)  S X6(X5)=$G(X6(X5))+1 I X6(X5)>1 D  Q

 .S ERROR="1^Error - Duplicate Codes in Coding System"_" File #: "_IFN_" HLNODE="_HLNODE ;D ^%ZTER

M89261 ;Conversion of File: 8926.1 FIELD: 2  CODING SYSTEM  From: CPT to CPT:00001,00002

 ;TMP1(2,"8926.12","1,7,",".01")="CPT"    D GETS^DIQ(X2,IENS,"*","","TMP1(LEV)")

 N TMP,X4,X3,II

 S X4=TMP1(LEV,X2,IENS,I)_":" ;X4=CPT:

 D GETS^DIQ(8926.12,IENS,"**","","TMP") ;TMP(8926.121,"1,1,7,",.01)=86485

 S II="" F  S II=$O(TMP(8926.121,II)) Q:'II  S X3=$G(TMP(8926.121,II,.01)) S:$L(X3) X4=X4_X3_","

 S:$L(X3) X4=$E(X4,1,$L(X4)-1) S TMP1(LEV,X2,IENS,I)=X4

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HTIUZRT   2651     printed  Mar 13, 2025@21:51:33                                                                                                                                                                                                      Page 2

TIUZRT    ; DAL/GT-NDS - TIU -CALLABLE ENTRY POINTS FOR ZRT SEGEMENT ;9/6/16

 +1       ;;1.0;TEXT INTEGRATION UTILITIES;**309**;Jun 20, 1997;Build 5

 +2       ;

 +3       ;

 +4        QUIT

ZRT       ;Manipulate update of MFN ZRT segment for 8926.1 file

 +1       ;This is the indication that it's first update for any subfile

           IF IEN

               IF ((NAME="Term")!(NAME="Status"))

                   KILL XXIEN

 +2        if $DATA(HLNODE(1))

               SET HLNODE=HLNODE_HLNODE(1)

 +3        if IFN=8926.1

               GOTO 89261

 +4        QUIT

 +5       ;

89261     ;Manipulate update of MFN ZRT segment for 8926.1 File

 +1        NEW X,XX,ERR,IENS,IEN1,IENX,X1,X2,X4,DA,DIK,I,FDAA

 +2       ;ZRT^VistA_CodingSystem_Mapping^LOINC:90701,90743

           IF IEN

               IF NAME="VistA_Mapping_Target"

                   Begin DoDot:1

 +3       ;X=LOINC:90701,90743

                       SET X=$PIECE(HLNODE,HLFS,3)

 +4       ;Q:$G(OUT)  ;If there is nothing coming from Push, wipe anything was there before

                       IF '$LENGTH(X)!(X="""""")

                           DO DS(8926.12,IEN)

                           SET OUT=1

                           QUIT

 +5       ;CLEAN SUBFILE ENTRY

                       IF '$GET(XXIEN(8926.12))

                           DO DS(8926.12,IEN)

                           SET XXIEN(8926.12)=1

 +6                    SET X1=$PIECE(X,":")

                       SET X2=$PIECE(X,":",2)

 +7       ; Checup for duplicate coding system (ICD, 10D, CPT...) and codes

                       DO DUP(8926.12,X1,X2)

 +8                    if $GET(ERROR)

                           QUIT

 +9                    SET IENS=IEN_","

 +10                   SET IEN1="+1,"

                       SET FDAA(8926.12,"+1,"_IENS,.01)=X1

 +11                   FOR I=2:1

                           SET X4=$PIECE(X2,",",I-1)

                           if '$LENGTH(X4)

                               QUIT

                           SET IENX="+"_I_","_IEN1_IENS

                           SET FDAA(8926.121,IENX,.01)=X4

 +12                   if $DATA(FDAA)

                           DO UPDATE^DIE("","FDAA",,"ERR")

 +13                   IF $DATA(ERR)

                           Begin DoDot:2

 +14                           SET ERROR="1^subfile update error SUBFILE#: 8926.121 HLNODE:"_HLNODE

 +15                           DO EM^XUMF1H(ERROR,.ERR)

                           End DoDot:2

                           QUIT

 +16                   if $GET(ERROR)

                           QUIT

 +17                   SET OUT=1

                   End DoDot:1

                   QUIT

 +18       QUIT

 +19      ;

DS(SUBFILE,IENS) ;Delete subfile

 +1        NEW ROOT,IDX,X

 +2        SET ROOT=$$ROOT^DILFD(SUBFILE,","_IENS,1)

 +3        SET IDX=0

FOR

               SET IDX=$ORDER(@ROOT@(IDX))

               if 'IDX

                   QUIT

               Begin DoDot:1

 +4                NEW DA,DIK,DIC

                   SET DA(1)=+IENS

                   SET DA=IDX

                   SET DIK=$PIECE(ROOT,")")_","

                   DO ^DIK

               End DoDot:1

 +5        QUIT

 +6       ;

DUP(SUB,X1,X2) ;

 +1       ;Checkup for duplicate coding system (ICD, 10D, CPT...)

 +2       ;TMP(8926.12 - .128,"1,7,",.01)=86485   X1=CPT   X2=1234,4567,7890

           DO GETS^DIQ(IFN,IEN_",","**","","TMP")

 +3        SET II=""

FOR

               SET II=$ORDER(TMP(SUB,II))

               if 'II

                   QUIT

               SET X3=$GET(TMP(SUB,II,.01))

               IF $LENGTH(X3)

                   IF X3=X1

                       Begin DoDot:1

 +4                        SET ERROR="1^Error - "_II_" Duplicate Coding System"_" File #: "_IFN_" HLNODE="_HLNODE

                       End DoDot:1

                       QUIT

 +5        if $GET(ERROR)

               QUIT

 +6       ;Checkup for duplicate codes. (CPT:90701,90743,90701)

 +7        NEW X6

 +8        FOR I=1:1

               SET X5=$PIECE(X2,",",I)

               if '$LENGTH(X5)

                   QUIT

               SET X6(X5)=$GET(X6(X5))+1

               IF X6(X5)>1

                   Begin DoDot:1

 +9       ;D ^%ZTER

                       SET ERROR="1^Error - Duplicate Codes in Coding System"_" File #: "_IFN_" HLNODE="_HLNODE

                   End DoDot:1

                   QUIT

 +10       QUIT

 +11      ;

M89261    ;Conversion of File: 8926.1 FIELD: 2  CODING SYSTEM  From: CPT to CPT:00001,00002

 +1       ;TMP1(2,"8926.12","1,7,",".01")="CPT"    D GETS^DIQ(X2,IENS,"*","","TMP1(LEV)")

 +2        NEW TMP,X4,X3,II

 +3       ;X4=CPT:

           SET X4=TMP1(LEV,X2,IENS,I)_":"

 +4       ;TMP(8926.121,"1,1,7,",.01)=86485

           DO GETS^DIQ(8926.12,IENS,"**","","TMP")

 +5        SET II=""

FOR

               SET II=$ORDER(TMP(8926.121,II))

               if 'II

                   QUIT

               SET X3=$GET(TMP(8926.121,II,.01))

               if $LENGTH(X3)

                   SET X4=X4_X3_","

 +6        if $LENGTH(X3)

               SET X4=$EXTRACT(X4,1,$LENGTH(X4)-1)

           SET TMP1(LEV,X2,IENS,I)=X4

 +7        QUIT

TIUZRT.m