GMRAVZRT.m

GMRAVZRT ;FOBP/CLT - ALLERGIES - CALLABLE ENTRY POINTS FOR ZRT SEGMENT ; 14 Oct 2016  12:56 PM

 ;;4.0;GEN. MED. REC. - ALLERGIES;**55**;Mar 29, 1996;Build 9

 ;

 ;

 Q

ZRT ;Manipulate update of MFN ZRT segment for 120.82,120.83 files

 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 12082:IFN=120.82,12083:IFN=120.83

 Q

 ;

12082 ;Manipulate update of MFN ZRT segment for 120.82 File

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

 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(120.822,IEN) S OUT=1 Q  ;Q:$G(OUT)  ;If there is nothing coming from Push, wipe anything was there before

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

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

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

 .Q:$G(ERROR)

 .S IENS=IEN_","

 .S IEN1="+1,",FDAA(120.822,"+1,"_IENS,.01)=X1 I X1[":"

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

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

 .I $D(ERR) D  Q

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

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

 .Q:$G(ERROR)

 .S OUT=1

 Q

 ;

12083 ;Manipulate update of MFN ZRT segment

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

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

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

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

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

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

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

 .Q:$G(ERROR)

 .S IENS=IEN_","

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

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

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

 .I $D(ERR) D  Q

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

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

 .Q:$G(ERROR)

 .S OUT=1

 ;I IEN,NAME="has_qualifier" D  Q  ;

 ;.I $P(HLNODE,HLFS,3)="""""" D DS(120.831,IEN) S OUT=1 Q

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

 Q

 ;

 ;

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

 Q

 ;

DUP(SUB,X1,X2) ;

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

 D GETS^DIQ(IFN,IEN_",","**","","TMP") ;TMP(120.822 - .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

 Q

M12082 ;Conversion of File: 120.82 FIELD: 8  CODING SYSTEM  From: CPT to CPT:00001,00002

 ;TMP1(2,"120.822","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(120.822,IENS,"**","","TMP") ;TMP(120.8221,"1,1,7,",.01)=86485

 S II="" F  S II=$O(TMP(120.8221,II)) Q:'II  S X3=$G(TMP(120.8221,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

 Q

M12083 ;Conversion of File:120.83 FIELD: 2  CODING SYSTEM  From: CPT to CPT:00001,00002

 ;TMP1(2,"120.833","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(120.833,IENS,"**","","TMP") ;TMP(120.8331"1,1,7,",.01)=86485

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

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

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

 Q

 ;Discovery coding

DFORALL(FILE,SF1,SF2,VMT) ; Discovery coding for all files.

 ;FILE = 120.82

 ;SF1 = 120.822

 ;SF2 = 120.8221

 ;VMT = VistA_Mapping_Target

 S VMT=$G(VMT,"VistA_Mapping_Target")

 N TMP,II,CNT,VAL,VAL1,X1,X2,X3,IEN

 S CNT=0,(VAL,VAL1)=""

 F  S CNT=$O(^TMP("HLA",$J,CNT)) Q:'CNT  S II=$G(^TMP("HLA",$J,CNT)) Q:'$L(II)  Q:$G(ERROR)  D

 .D:$P(II,HLFS)="MFE"

 ..S IEN=$P(II,HLFS,5),IEN=$P(IEN,"@",2),IEN=$O(^GMRD(FILE,"AVUID",IEN,0)) Q:'IEN

 ..K TMP D GETS^DIQ(FILE,IEN_",","**","","TMP","ERR") I $D(ERR) S ERROR="1^Error retrieving "_FILE_" GETS^DIQ data for IEN="_IEN_" "_II Q

 .D:$P(II,HLFS,2)=VMT  ;II=ZRT^VistA_Mapping_Target^CPT

 ..S VAL=$P(II,HLFS,3),X1="",X2="" ;VAL=CPT

 ..F  S X1=$O(TMP(SF1,X1)) Q:'$L(X1)  D:TMP(SF1,X1,.01)=VAL DSF(SF2)

 Q

DSF(SF) ;Discovery Processing Subfile

 S VAL1=VAL F  S X2=$O(TMP(SF,X2)) Q:'$L(X2)  D:$P(X2,",",2,99)=X1

 .S X3=$G(TMP(SF,X2,.01)) Q:'$L(X3)  S:VAL1'[":" VAL1=VAL1_":" S VAL1=VAL1_X3_","

 Q:'$L(VAL1)  Q:(VAL=VAL1)  S VAL1=$E(VAL1,1,$L(VAL1)-1) S $P(II,HLFS,3)=VAL1,^TMP("HLA",$J,CNT)=II

 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---GMRAVZRT   5450     printed  Feb 18, 2025@23:07:09                                                                                                                                                                                                    Page 2

GMRAVZRT  ;FOBP/CLT - ALLERGIES - CALLABLE ENTRY POINTS FOR ZRT SEGMENT ; 14 Oct 2016  12:56 PM

 +1       ;;4.0;GEN. MED. REC. - ALLERGIES;**55**;Mar 29, 1996;Build 9

 +2       ;

 +3       ;

 +4        QUIT 

ZRT       ;Manipulate update of MFN ZRT segment for 120.82,120.83 files

 +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=120.82

               GOTO 12082

           if IFN=120.83

               GOTO 12083

 +4        QUIT 

 +5       ;

12082     ;Manipulate update of MFN ZRT segment for 120.82 File

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

 +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(120.822,IEN)

                           SET OUT=1

                           QUIT 

 +5       ;CLEAN SUBFILE ENTRY

                       IF '$GET(XXIEN(120.822))

                           DO DS(120.822,IEN)

                           SET XXIEN(120.822)=1

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

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

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

                       DO DUP(120.822,X1,X2)

 +8                    if $GET(ERROR)

                           QUIT 

 +9                    SET IENS=IEN_","

 +10                   SET IEN1="+1,"

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

                       IF X1[":"

 +11                   FOR I=2:1

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

                           if '$LENGTH(X4)

                               QUIT 

                           SET IENX="+"_I_","_IEN1_IENS

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

 +12                   if $DATA(FDAA)

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

                       IF $DATA(ERR)

 +13                   IF $DATA(ERR)

                           Begin DoDot:2

 +14                           SET ERROR="1^subfile update error SUBFILE#: 120.8221 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      ;

12083     ;Manipulate update of MFN ZRT segment

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

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

           IF IEN

               IF NAME="VistA_Mapping_Target"

                   Begin DoDot:1

 +3       ;X=SMOMED: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(120.833,IEN)

                           SET OUT=1

                           QUIT 

 +5       ;CLEAN SUBFILE ENTRY

                       IF '$GET(XXIEN(120.833))

                           DO DS(120.833,IEN)

                           SET XXIEN(120.833)=1

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

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

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

                       DO DUP(120.833,X1,X2)

 +8                    if $GET(ERROR)

                           QUIT 

 +9                    SET IENS=IEN_","

 +10                   SET IEN1="+1,"

                       SET FDAA(120.833,"+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(120.8331,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#: 120.8331 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      ;I IEN,NAME="has_qualifier" D  Q  ;

 +19      ;.I $P(HLNODE,HLFS,3)="""""" D DS(120.831,IEN) S OUT=1 Q

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

 +21       QUIT 

 +22      ;

 +23      ;

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(120.822 - .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 

M12082    ;Conversion of File: 120.82 FIELD: 8  CODING SYSTEM  From: CPT to CPT:00001,00002

 +1       ;TMP1(2,"120.822","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(120.8221,"1,1,7,",.01)=86485

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

 +5        SET II=""

           FOR 

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

               if 'II

                   QUIT 

               SET X3=$GET(TMP(120.8221,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 

M12083    ;Conversion of File:120.83 FIELD: 2  CODING SYSTEM  From: CPT to CPT:00001,00002

 +1       ;TMP1(2,"120.833","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(120.8331"1,1,7,",.01)=86485

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

 +5        SET II=""

           FOR 

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

               if 'II

                   QUIT 

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

               if $LENGTH(X3)

                   SET X4=X4_X3_","

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

 +7        if $LENGTH(X3)

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

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

 +8        QUIT 

 +9       ;Discovery coding

DFORALL(FILE,SF1,SF2,VMT) ; Discovery coding for all files.

 +1       ;FILE = 120.82

 +2       ;SF1 = 120.822

 +3       ;SF2 = 120.8221

 +4       ;VMT = VistA_Mapping_Target

 +5        SET VMT=$GET(VMT,"VistA_Mapping_Target")

 +6        NEW TMP,II,CNT,VAL,VAL1,X1,X2,X3,IEN

 +7        SET CNT=0

           SET (VAL,VAL1)=""

 +8        FOR 

               SET CNT=$ORDER(^TMP("HLA",$JOB,CNT))

               if 'CNT

                   QUIT 

               SET II=$GET(^TMP("HLA",$JOB,CNT))

               if '$LENGTH(II)

                   QUIT 

               if $GET(ERROR)

                   QUIT 

               Begin DoDot:1

 +9                if $PIECE(II,HLFS)="MFE"

                       Begin DoDot:2

 +10                       SET IEN=$PIECE(II,HLFS,5)

                           SET IEN=$PIECE(IEN,"@",2)

                           SET IEN=$ORDER(^GMRD(FILE,"AVUID",IEN,0))

                           if 'IEN

                               QUIT 

 +11                       KILL TMP

                           DO GETS^DIQ(FILE,IEN_",","**","","TMP","ERR")

                           IF $DATA(ERR)

                               SET ERROR="1^Error retrieving "_FILE_" GETS^DIQ data for IEN="_IEN_" "_II

                               QUIT 

                       End DoDot:2

 +12      ;II=ZRT^VistA_Mapping_Target^CPT

                   if $PIECE(II,HLFS,2)=VMT

                       Begin DoDot:2

 +13      ;VAL=CPT

                           SET VAL=$PIECE(II,HLFS,3)

                           SET X1=""

                           SET X2=""

 +14                       FOR 

                               SET X1=$ORDER(TMP(SF1,X1))

                               if '$LENGTH(X1)

                                   QUIT 

                               if TMP(SF1,X1,.01)=VAL

                                   DO DSF(SF2)

                       End DoDot:2

               End DoDot:1

 +15       QUIT 

DSF(SF)   ;Discovery Processing Subfile

 +1        SET VAL1=VAL

           FOR 

               SET X2=$ORDER(TMP(SF,X2))

               if '$LENGTH(X2)

                   QUIT 

               if $PIECE(X2,",",2,99)=X1

                   Begin DoDot:1

 +2                    SET X3=$GET(TMP(SF,X2,.01))

                       if '$LENGTH(X3)

                           QUIT 

                       if VAL1'["

                           SET VAL1=VAL1_":"

                       SET VAL1=VAL1_X3_","

                   End DoDot:1

 +3        if '$LENGTH(VAL1)

               QUIT 

           if (VAL=VAL1)

               QUIT 

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

           SET $PIECE(II,HLFS,3)=VAL1

           SET ^TMP("HLA",$JOB,CNT)=II

 +4        QUIT