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 ---[H[J[2J[HGMRAVZRT 5450 printed Dec 13, 2024@01:40:46 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
