- DGZRT ;DAL/JCH - DEMOGRAPHICS ENTRY POINTS FOR ZRT SEGMENT MFS UPDATE ;05/18/2017
- ;;5.3;Registration;**933**;Aug 13, 1993;Build 44
- ;
- Q
- ZRT ;Manipulate update of MFN ZRT segment for Demographics 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 XX99:(IFN=10.99!(IFN=11.99)!(IFN=13.99)) ;!(IFN=50.60699))
- Q
- ;
- XX99 ;1399 ;Manipulate update of MFN ZRT segment for RELIGION (#13.99) File
- N X,XX,ERR,IENS,IEN1,IENX,X1,X2,X4,DA,DIK,I,FDAA,VALUE,IFN9
- S IFN9=IFN+.00901
- I IEN,NAME="VistA_Related_Record" D Q ;ZRT^VistA_CodingSystem_Mapping^LOINC:90701,90743
- .S (X,VALUE)=$$UNESC^XUMF0($P(HLNODE,HLFS,3),.HL)
- .I '$L(X)!(X="""""") D DS(IFN9,IEN) S OUT=1 Q ;Q:$G(OUT) ;If there is nothing coming from Push, wipe anything was there before
- .I '$G(XXIEN(IFN9)) D DS(IFN9,IEN) S XXIEN(IFN9)=1 ;CLEAN SUBFILE ENTRY
- .S IENS=IEN_","
- .S IEN1="+1,",FDAA(IFN9,"+1,"_IENS,.01)=X ;NOT RIGHT
- .S VALUE=$$VAL^XUMF0(IFN9,.01,"",VALUE,"?+1,"_IENS)
- .Q:ERROR Q:VALUE="^"
- .D:$D(FDAA) UPDATE^DIE("","FDAA",,"ERR")
- .I $D(ERR) D Q
- ..S ERROR="1^subfile update error SUBFILE#: "_IFN9_" HLNODE:"_HLNODE
- ..D EM^XUMF1H(ERROR,.ERR)
- .Q:$G(ERROR)
- .S OUT=1
- Q
- POST ;Post processing logic
- ; IFN = File # aka 13.99
- ; IFNM File associated with IFN aka 13
- ;Scan all enries from file 13 field 90 and see if some dangling pointers are there, or if entries can be repointed.
- Q:$G(ERROR)
- ;^DIC(13,"ACMF",3,136)=""
- ;^DIC(13,136,0)="SATANISM^^^66"
- ;^DIC(13,136,"MASTER")=3
- ;^DGMR(13.99,"AC","SATANISM",3,1)=""
- ;^DGMR(13.99,3,"ASSOC",1,0)="SATANISM"
- ;X0=3 N13="SATANISM" X1=136
- ;IFNA1 = ^DGMR(IFN,"AC",N13,X0)
- ;IFNA2 = ^DGMR(IFN,"AC",N13,0)
- ;IFNA3 = ^DGMR(IFN,Q2,0)
- ;IFNA4 = ^DGMR(IFN,Q3,0)
- ;IFNA = ^DGMR(IFN,"AC",N13)
- ;IFNB1 = ^DIC(IFNM,X1)
- ;IFNB2 = ^DIC(IFNM,X1,0)
- ;IFNB3 = ^DIC(IFNM,"ACMF"
- ;IFNB = ^DIC(IFNM,X1,"MASTER")
- ;Get the pointers from 13 to be repointed to 13.99
- ;first see if we have some NUUL pointer
- N X0,X1,X2,C,TEXT,N13,IFNM,IFNA,IFNA1,IFNA2,IFNA3,IFNA4,IFNB,IFNB1,IFNB2,IFNB3,IFNC,MDF,DUPL,Q1,Q2,Q3
- ;S C=10,IFNM=IFN\1,IFNA=^DIC(IFN,0,"GL"),IFNB=^DIC(IFNM,0,"GL")
- S C=10,IFNM=IFN\1,IFNA=^DIC(IFN,0,"GL"),IFNB=^DIC(IFNM,0,"GL")
- ;S:IFNM=50 IFNM=50.606
- S IFNC=IFNB_"X0,0)" ;^DIC(13,X0,0)
- ;S IFNA1=IFNA_"""AC"",N13,X0)",IFNA2=IFNA_"IFN,""AC"",N13,0)",IFNA=IFNA_"IFN,""AC"",N13)"
- S IFNA1=IFNA_"""AC"",N13,X0)",IFNA2=IFNA_"""AC"",N13,0)",IFNA3=IFNA_"Q2,0)",IFNA4=IFNA_"Q3,0)",IFNA=IFNA_"""AC"",N13)"
- ;S IFNB1=IFNB_"IFNM,X1)",IFNB2=IFNB_"IFNM,X1,0)",IFNB=IFNB_"IFNM,X1,""MASTER"")"
- S IFNB1=IFNB_"X1)",IFNB2=IFNB_"X1,0)",IFNB3=IFNB_"""ACMF"",IENS)",IFNB=IFNB_"X1,""MASTER"")"
- ;S MDF=$S(IFNM=50.606:12,1:90)
- S MDF=90
- ;Check for duplicates in 11.99,99 ASSOCIATED VA MARITAL STATUSES ASSOC;0 Multiple #11.99901
- S N13="" F S N13=$O(@IFNA) Q:'$L(N13) D ;IFNA = ^DGMR(IFN,"AC",N13)
- .K DUPL M DUPL=@IFNA S Q1="DUPL",Q1=$Q(@Q1),Q2=Q1,Q2=+$P(Q2,"(",2),Q1=$Q(@Q1) Q:'$L(Q1) ;Quit if only one multiple,.. no duplicates.
- .F D S Q1=$Q(@Q1) Q:'$L(Q1)
- ..S Q3=+$P(Q1,"(",2),Q3=$P(@(IFNA4),U)
- ..S TEXT=" File: "_IFN_" Local IEN: "_+$P(Q1,"(",2)_" "_Q3_" Associated "_N13_" Is Duplicate to Ass. in IEN: "_Q2_" "_$P(@(IFNA3),U)
- ..S C=C+1,ERR("DIERR",1,"TEXT",C)=TEXT
- .Q
- I $D(ERR) D Q
- .S ERR("DIERR",1,"TEXT",10)="List of Association duplicates in "_IFN_" Site:"_$$SITE^VASITE()
- .S ERROR="1^Records in file "_IFN_" have Association duplictes. Listing of duplicates see in MFS ERROR/WARNING/INFO"
- .D EM^XUMF0
- .K ERR
- ;
- ;S X1=0 F S X1=$O(^DIC(IFNM,X1)) Q:'X1 S N13=$P($G(^DIC(IFNM,X1,0)),U) Q:'$L(N13) S X0=+$G(^DIC(IFNM,X1,"MASTER")) Q:$D(^DGMR(IFN,"AC",N13,X0)) D
- ;S X1=0 F S X1=$O(^DIC(IFNM,X1)) Q:'X1 S N13=$P($G(^DIC(IFNM,X1,0)),U) Q:'$L(N13) S X0=+$G(^DIC(IFNM,X1,"MASTER")) Q:$D(@IFNA1) D
- ;S X1=0 F S X1=$O(@IFNB1) Q:'X1 S N13=$P($G(@IFNB2),U) Q:'$L(N13) S X0=+$G(@IFNB) Q:$D(@IFNA1) D
- ;S X1=0 F S X1=$O(@IFNB1) Q:'X1 Q:$G(ERROR) S N13=$P($G(@IFNB2),U) I $L(N13) S X0=+$G(@IFNB) D:'$D(@IFNA1) ;X0=Master pointer to 13.99
- S X1=0 F S X1=$O(@IFNB1) Q:'X1 Q:$G(ERROR) S N13=$P($G(@IFNB2),U) I $L(N13) S X0=+$G(@IFNB) D:'$D(@IFNA1) ;X0=Master pointer to 13.99
- .;I $D(^DGMR(IFN,"AC",N13)) D Q ;No MASTER pointer into file 13 or MASTER needs to be repointed
- .I $D(@IFNA) D Q ;No MASTER pointer into file 13 or MASTER needs to be repointed
- ..N FDA,ERR,ZZZ
- ..;S X0=$O(^DGMR(IFN,"AC",N13,0))
- ..S X0=$O(@IFNA2)
- ..D GETS^DIQ(IFN,X0_",","99.991*","I","ZZZ","ERR")
- ..I $D(ERR) D Q
- ...S ERROR="1^Error in Retrievig status of IEN: "_X0_" in file"_IFN
- ...S ERRCNT=+$G(ERRCNT) D EM^XUMF1H(ERROR,.ERR)
- ..;ZZZ(11.9901,"1,17,",.01,"I")=3170915.170227
- ..;ZZZ(11.9901,"1,17,",.02,"I")=1
- ..;ZZZ(11.9901,"2,17,",.01,"I")=3170915.200528
- ..;ZZZ(11.9901,"2,17,",.02,"I")=0
- ..Q:'@($Q(ZZZ(99999999999),-1)) ; Ignore "Invalid or wrong number of arguments to a function" XINDEX warning.
- ..S FDA(IFNM,X1_",",MDF)=X0
- ..D FILE^DIE(,"FDA","ERR")
- ..I $D(ERR) D
- ...S ERROR="1^Repointing entry: "_X1_" in file"_IFNM_" error."
- ...S ERRCNT=+$G(ERRCNT) D EM^XUMF1H(ERROR,.ERR)
- ...K ERR
- ..Q
- .Q:$G(ERROR)
- .; Local entry in master file doesn't exist send e-mail ito XUMF ERROR
- .;S TEXT=" File: "_13_" Local IEN: "_X1_" "_N13_" Is missing in file 13.99 and can NOT be "_$S('X0:"SET",1:"RESET") ;
- .S:X0 Q2=X0,Q2=$P($G(@IFNA3),U)
- .S TEXT=" File: "_IFNM_" Local IEN: "_X1_" "_N13_" Is missing in file"_IFN_" and can NOT be "_$S('X0:"SET",1:"RESET From: "_Q2) ;
- .;S C=C+1,ERR("DIERR",1,"TEXT",C)=X0_TEXT
- .S C=C+1,ERR("DIERR",1,"TEXT",C)=TEXT
- .;S:X0 C=C+1,ERR("DIERR",1,"TEXT",C)=" Master IEN before: "_X0_" "_$P($G(^DIC(13.99,X0,0)),U)
- .S:X0 C=C+1,ERR("DIERR",1,"TEXT",C)=" Master IEN before: "_X0_" "_$P($G(@IFNC),U)
- Q:$G(ERROR)
- I $D(ERR) D Q
- .S ERR("DIERR",1,"TEXT",10)="List of records from file "_IFNM_" not synchronised with file "_IFN_" Site:"_$$SITE^VASITE()
- .S ERROR="0^Records of file "_IFN_" are not synchronised with File "_IFNM_" Listing of records see in MFS ERROR/WARNING/INFO"
- .D EM^XUMF0
- .K ERR
- Q
- ;
- DS(SUBFILE,IENS) ;Delete subfile
- D DS1(IENS)
- Q:$G(ERROR)
- N ROOT,IDX,X
- ;K @(IFNB3) ;Delete field 90 pointers from 11 to 11.99 K ^DIC(11,"ACMF",IENS)
- 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
- DS1(IEN) ; Delete coresponding fields 90 in file 11
- N IFNM,FDA,IDX,IFNB,IFNB3
- S IFNM=IFN\1
- S IFNB=^DIC(IFNM,0,"GL"),IFNB3=IFNB_"""ACMF"",IEN,IDX)"
- S IDX=0 F S IDX=$O(@IFNB3) Q:'IDX S FDA(IFNM,IDX_",",90)="@"
- Q:'$D(FDA)
- D FILE^DIE(,"FDA","ERR")
- Q:'$D(ERR)
- S ERROR="1^Error in update of field 90 in file: "_IFNM
- S ERRCNT=+$G(ERRCNT) D EM^XUMF1H(ERROR,.ERR)
- ;K ERR
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGZRT 6922 printed Mar 13, 2025@22:05:33 Page 2
- DGZRT ;DAL/JCH - DEMOGRAPHICS ENTRY POINTS FOR ZRT SEGMENT MFS UPDATE ;05/18/2017
- +1 ;;5.3;Registration;**933**;Aug 13, 1993;Build 44
- +2 ;
- +3 QUIT
- ZRT ;Manipulate update of MFN ZRT segment for Demographics 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 ;!(IFN=50.60699))
- if (IFN=10.99!(IFN=11.99)!(IFN=13.99))
- GOTO XX99
- +4 QUIT
- +5 ;
- XX99 ;1399 ;Manipulate update of MFN ZRT segment for RELIGION (#13.99) File
- +1 NEW X,XX,ERR,IENS,IEN1,IENX,X1,X2,X4,DA,DIK,I,FDAA,VALUE,IFN9
- +2 SET IFN9=IFN+.00901
- +3 ;ZRT^VistA_CodingSystem_Mapping^LOINC:90701,90743
- IF IEN
- IF NAME="VistA_Related_Record"
- Begin DoDot:1
- +4 SET (X,VALUE)=$$UNESC^XUMF0($PIECE(HLNODE,HLFS,3),.HL)
- +5 ;Q:$G(OUT) ;If there is nothing coming from Push, wipe anything was there before
- IF '$LENGTH(X)!(X="""""")
- DO DS(IFN9,IEN)
- SET OUT=1
- QUIT
- +6 ;CLEAN SUBFILE ENTRY
- IF '$GET(XXIEN(IFN9))
- DO DS(IFN9,IEN)
- SET XXIEN(IFN9)=1
- +7 SET IENS=IEN_","
- +8 ;NOT RIGHT
- SET IEN1="+1,"
- SET FDAA(IFN9,"+1,"_IENS,.01)=X
- +9 SET VALUE=$$VAL^XUMF0(IFN9,.01,"",VALUE,"?+1,"_IENS)
- +10 if ERROR
- QUIT
- if VALUE="^"
- QUIT
- +11 if $DATA(FDAA)
- DO UPDATE^DIE("","FDAA",,"ERR")
- +12 IF $DATA(ERR)
- Begin DoDot:2
- +13 SET ERROR="1^subfile update error SUBFILE#: "_IFN9_" HLNODE:"_HLNODE
- +14 DO EM^XUMF1H(ERROR,.ERR)
- End DoDot:2
- QUIT
- +15 if $GET(ERROR)
- QUIT
- +16 SET OUT=1
- End DoDot:1
- QUIT
- +17 QUIT
- POST ;Post processing logic
- +1 ; IFN = File # aka 13.99
- +2 ; IFNM File associated with IFN aka 13
- +3 ;Scan all enries from file 13 field 90 and see if some dangling pointers are there, or if entries can be repointed.
- +4 if $GET(ERROR)
- QUIT
- +5 ;^DIC(13,"ACMF",3,136)=""
- +6 ;^DIC(13,136,0)="SATANISM^^^66"
- +7 ;^DIC(13,136,"MASTER")=3
- +8 ;^DGMR(13.99,"AC","SATANISM",3,1)=""
- +9 ;^DGMR(13.99,3,"ASSOC",1,0)="SATANISM"
- +10 ;X0=3 N13="SATANISM" X1=136
- +11 ;IFNA1 = ^DGMR(IFN,"AC",N13,X0)
- +12 ;IFNA2 = ^DGMR(IFN,"AC",N13,0)
- +13 ;IFNA3 = ^DGMR(IFN,Q2,0)
- +14 ;IFNA4 = ^DGMR(IFN,Q3,0)
- +15 ;IFNA = ^DGMR(IFN,"AC",N13)
- +16 ;IFNB1 = ^DIC(IFNM,X1)
- +17 ;IFNB2 = ^DIC(IFNM,X1,0)
- +18 ;IFNB3 = ^DIC(IFNM,"ACMF"
- +19 ;IFNB = ^DIC(IFNM,X1,"MASTER")
- +20 ;Get the pointers from 13 to be repointed to 13.99
- +21 ;first see if we have some NUUL pointer
- +22 NEW X0,X1,X2,C,TEXT,N13,IFNM,IFNA,IFNA1,IFNA2,IFNA3,IFNA4,IFNB,IFNB1,IFNB2,IFNB3,IFNC,MDF,DUPL,Q1,Q2,Q3
- +23 ;S C=10,IFNM=IFN\1,IFNA=^DIC(IFN,0,"GL"),IFNB=^DIC(IFNM,0,"GL")
- +24 SET C=10
- SET IFNM=IFN\1
- SET IFNA=^DIC(IFN,0,"GL")
- SET IFNB=^DIC(IFNM,0,"GL")
- +25 ;S:IFNM=50 IFNM=50.606
- +26 ;^DIC(13,X0,0)
- SET IFNC=IFNB_"X0,0)"
- +27 ;S IFNA1=IFNA_"""AC"",N13,X0)",IFNA2=IFNA_"IFN,""AC"",N13,0)",IFNA=IFNA_"IFN,""AC"",N13)"
- +28 SET IFNA1=IFNA_"""AC"",N13,X0)"
- SET IFNA2=IFNA_"""AC"",N13,0)"
- SET IFNA3=IFNA_"Q2,0)"
- SET IFNA4=IFNA_"Q3,0)"
- SET IFNA=IFNA_"""AC"",N13)"
- +29 ;S IFNB1=IFNB_"IFNM,X1)",IFNB2=IFNB_"IFNM,X1,0)",IFNB=IFNB_"IFNM,X1,""MASTER"")"
- +30 SET IFNB1=IFNB_"X1)"
- SET IFNB2=IFNB_"X1,0)"
- SET IFNB3=IFNB_"""ACMF"",IENS)"
- SET IFNB=IFNB_"X1,""MASTER"")"
- +31 ;S MDF=$S(IFNM=50.606:12,1:90)
- +32 SET MDF=90
- +33 ;Check for duplicates in 11.99,99 ASSOCIATED VA MARITAL STATUSES ASSOC;0 Multiple #11.99901
- +34 ;IFNA = ^DGMR(IFN,"AC",N13)
- SET N13=""
- FOR
- SET N13=$ORDER(@IFNA)
- if '$LENGTH(N13)
- QUIT
- Begin DoDot:1
- +35 ;Quit if only one multiple,.. no duplicates.
- KILL DUPL
- MERGE DUPL=@IFNA
- SET Q1="DUPL"
- SET Q1=$QUERY(@Q1)
- SET Q2=Q1
- SET Q2=+$PIECE(Q2,"(",2)
- SET Q1=$QUERY(@Q1)
- if '$LENGTH(Q1)
- QUIT
- +36 FOR
- Begin DoDot:2
- +37 SET Q3=+$PIECE(Q1,"(",2)
- SET Q3=$PIECE(@(IFNA4),U)
- +38 SET TEXT=" File: "_IFN_" Local IEN: "_+$PIECE(Q1,"(",2)_" "_Q3_" Associated "_N13_" Is Duplicate to Ass. in IEN: "_Q2_" "_$PIECE(@(IFNA3),U)
- +39 SET C=C+1
- SET ERR("DIERR",1,"TEXT",C)=TEXT
- End DoDot:2
- SET Q1=$QUERY(@Q1)
- if '$LENGTH(Q1)
- QUIT
- +40 QUIT
- End DoDot:1
- +41 IF $DATA(ERR)
- Begin DoDot:1
- +42 SET ERR("DIERR",1,"TEXT",10)="List of Association duplicates in "_IFN_" Site:"_$$SITE^VASITE()
- +43 SET ERROR="1^Records in file "_IFN_" have Association duplictes. Listing of duplicates see in MFS ERROR/WARNING/INFO"
- +44 DO EM^XUMF0
- +45 KILL ERR
- End DoDot:1
- QUIT
- +46 ;
- +47 ;S X1=0 F S X1=$O(^DIC(IFNM,X1)) Q:'X1 S N13=$P($G(^DIC(IFNM,X1,0)),U) Q:'$L(N13) S X0=+$G(^DIC(IFNM,X1,"MASTER")) Q:$D(^DGMR(IFN,"AC",N13,X0)) D
- +48 ;S X1=0 F S X1=$O(^DIC(IFNM,X1)) Q:'X1 S N13=$P($G(^DIC(IFNM,X1,0)),U) Q:'$L(N13) S X0=+$G(^DIC(IFNM,X1,"MASTER")) Q:$D(@IFNA1) D
- +49 ;S X1=0 F S X1=$O(@IFNB1) Q:'X1 S N13=$P($G(@IFNB2),U) Q:'$L(N13) S X0=+$G(@IFNB) Q:$D(@IFNA1) D
- +50 ;S X1=0 F S X1=$O(@IFNB1) Q:'X1 Q:$G(ERROR) S N13=$P($G(@IFNB2),U) I $L(N13) S X0=+$G(@IFNB) D:'$D(@IFNA1) ;X0=Master pointer to 13.99
- +51 ;X0=Master pointer to 13.99
- SET X1=0
- FOR
- SET X1=$ORDER(@IFNB1)
- if 'X1
- QUIT
- if $GET(ERROR)
- QUIT
- SET N13=$PIECE($GET(@IFNB2),U)
- IF $LENGTH(N13)
- SET X0=+$GET(@IFNB)
- if '$DATA(@IFNA1)
- Begin DoDot:1
- +52 ;I $D(^DGMR(IFN,"AC",N13)) D Q ;No MASTER pointer into file 13 or MASTER needs to be repointed
- +53 ;No MASTER pointer into file 13 or MASTER needs to be repointed
- IF $DATA(@IFNA)
- Begin DoDot:2
- +54 NEW FDA,ERR,ZZZ
- +55 ;S X0=$O(^DGMR(IFN,"AC",N13,0))
- +56 SET X0=$ORDER(@IFNA2)
- +57 DO GETS^DIQ(IFN,X0_",","99.991*","I","ZZZ","ERR")
- +58 IF $DATA(ERR)
- Begin DoDot:3
- +59 SET ERROR="1^Error in Retrievig status of IEN: "_X0_" in file"_IFN
- +60 SET ERRCNT=+$GET(ERRCNT)
- DO EM^XUMF1H(ERROR,.ERR)
- End DoDot:3
- QUIT
- +61 ;ZZZ(11.9901,"1,17,",.01,"I")=3170915.170227
- +62 ;ZZZ(11.9901,"1,17,",.02,"I")=1
- +63 ;ZZZ(11.9901,"2,17,",.01,"I")=3170915.200528
- +64 ;ZZZ(11.9901,"2,17,",.02,"I")=0
- +65 ; Ignore "Invalid or wrong number of arguments to a function" XINDEX warning.
- if '@($QUERY(ZZZ(99999999999),-1))
- QUIT
- +66 SET FDA(IFNM,X1_",",MDF)=X0
- +67 DO FILE^DIE(,"FDA","ERR")
- +68 IF $DATA(ERR)
- Begin DoDot:3
- +69 SET ERROR="1^Repointing entry: "_X1_" in file"_IFNM_" error."
- +70 SET ERRCNT=+$GET(ERRCNT)
- DO EM^XUMF1H(ERROR,.ERR)
- +71 KILL ERR
- End DoDot:3
- +72 QUIT
- End DoDot:2
- QUIT
- +73 if $GET(ERROR)
- QUIT
- +74 ; Local entry in master file doesn't exist send e-mail ito XUMF ERROR
- +75 ;S TEXT=" File: "_13_" Local IEN: "_X1_" "_N13_" Is missing in file 13.99 and can NOT be "_$S('X0:"SET",1:"RESET") ;
- +76 if X0
- SET Q2=X0
- SET Q2=$PIECE($GET(@IFNA3),U)
- +77 ;
- SET TEXT=" File: "_IFNM_" Local IEN: "_X1_" "_N13_" Is missing in file"_IFN_" and can NOT be "_$SELECT('X0:"SET",1:"RESET From: "_Q2)
- +78 ;S C=C+1,ERR("DIERR",1,"TEXT",C)=X0_TEXT
- +79 SET C=C+1
- SET ERR("DIERR",1,"TEXT",C)=TEXT
- +80 ;S:X0 C=C+1,ERR("DIERR",1,"TEXT",C)=" Master IEN before: "_X0_" "_$P($G(^DIC(13.99,X0,0)),U)
- +81 if X0
- SET C=C+1
- SET ERR("DIERR",1,"TEXT",C)=" Master IEN before: "_X0_" "_$PIECE($GET(@IFNC),U)
- End DoDot:1
- +82 if $GET(ERROR)
- QUIT
- +83 IF $DATA(ERR)
- Begin DoDot:1
- +84 SET ERR("DIERR",1,"TEXT",10)="List of records from file "_IFNM_" not synchronised with file "_IFN_" Site:"_$$SITE^VASITE()
- +85 SET ERROR="0^Records of file "_IFN_" are not synchronised with File "_IFNM_" Listing of records see in MFS ERROR/WARNING/INFO"
- +86 DO EM^XUMF0
- +87 KILL ERR
- End DoDot:1
- QUIT
- +88 QUIT
- +89 ;
- DS(SUBFILE,IENS) ;Delete subfile
- +1 DO DS1(IENS)
- +2 if $GET(ERROR)
- QUIT
- +3 NEW ROOT,IDX,X
- +4 ;K @(IFNB3) ;Delete field 90 pointers from 11 to 11.99 K ^DIC(11,"ACMF",IENS)
- +5 SET ROOT=$$ROOT^DILFD(SUBFILE,","_IENS,1)
- +6 SET IDX=0
- FOR
- SET IDX=$ORDER(@ROOT@(IDX))
- if 'IDX
- QUIT
- Begin DoDot:1
- +7 NEW DA,DIK,DIC
- SET DA(1)=+IENS
- SET DA=IDX
- SET DIK=$PIECE(ROOT,")")_","
- DO ^DIK
- End DoDot:1
- +8 QUIT
- DS1(IEN) ; Delete coresponding fields 90 in file 11
- +1 NEW IFNM,FDA,IDX,IFNB,IFNB3
- +2 SET IFNM=IFN\1
- +3 SET IFNB=^DIC(IFNM,0,"GL")
- SET IFNB3=IFNB_"""ACMF"",IEN,IDX)"
- +4 SET IDX=0
- FOR
- SET IDX=$ORDER(@IFNB3)
- if 'IDX
- QUIT
- SET FDA(IFNM,IDX_",",90)="@"
- +5 if '$DATA(FDA)
- QUIT
- +6 DO FILE^DIE(,"FDA","ERR")
- +7 if '$DATA(ERR)
- QUIT
- +8 SET ERROR="1^Error in update of field 90 in file: "_IFNM
- +9 SET ERRCNT=+$GET(ERRCNT)
- DO EM^XUMF1H(ERROR,.ERR)
- +10 ;K ERR
- +11 QUIT
