HDIPSZRT ;DAL/PBB - DOSAGE FORM ENTRY POINTS FOR ZRT SEGMENT MFS UPDATE ; Apr 07, 2018@12:42
;;1.0;HEALTH DATA & INFORMATICS;**21,22**;Feb 22, 2005;Build 26
;
Q
ZRT ;Manipulate update of MFN ZRT segment for MED DOSAGE 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=50.60699
Q
;
XX99 ;1399 ;Manipulate update of MFN ZRT segment for MASTER DOSAGE FORM (#50.60699) File
N X,XX,ERR,IENS,IEN1,IENX,X1,X2,X4,DA,DIK,I,FDAA,VALUE,IFN9
S IFN9=50.60699901
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 50.60699
; IFNM File associated with IFN aka 50.606
;Scan all enries from file 50.606 field 90 and see if some dangling pointers are there, or if entries can be repointed.
Q:$G(ERROR)
;^PS(50.606,"ACMF",2,63)=""
;^PS(50.606,63,0)="TAB"
;^PS(50.606,63,"MASTER")=2
;^PSMDF(50.60699,"AC","Aerosol",2,1)=""
;^PSMDF(50.60699,2,"ASSOC",1,0)="Aerosol"
;X0=2 N13="Aerosol" X1=63
;IFNA1 = ^PSMDF(IFN,"AC",N13,X0)
;IFNA2 = ^PSMDF(IFN,"AC",N13,0)
;IFNA3 = ^PSMDF(IFN,Q2,0)
;IFNA4 = ^PSMDF(IFN,Q3,0)
;IFNA = ^PSMDF(IFN,"AC",N13)
;IFNB1 = ^PS(IFNM,X1)
;IFNB2 = ^PS(IFNM,X1,0)
;IFNB3 = ^PS(IFNM,"ACMF"
;IFNB = ^PS(IFNM,X1,"MASTER")
;Get the pointers from 50.606 to be repointed to 50.60699
;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=50.606,IFNA=^DIC(IFN,0,"GL"),IFNB=^DIC(IFNM,0,"GL")
S IFNC=IFNB_"X0,0)" ;^PS(50.606,X0,0)
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_"X1)",IFNB2=IFNB_"X1,0)",IFNB3=IFNB_"""ACMF"",IENS)",IFNB=IFNB_"X1,""MASTER"")"
S MDF=90
;Check for duplicates in 50.60699,99 ASSOCIATED DOSAGE FORM STATUSES ASSOC;0 Multiple #50.60699901
S N13="" F S N13=$O(@IFNA) Q:'$L(N13) D ;IFNA = ^PSMDF(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(@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 50.60699
.I $D(@IFNA) D Q ;No MASTER pointer into file 50.606 or MASTER needs to be repointed
..N FDA,ERR,ZZZ
..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(50.6069901,"1,17,",.01,"I")=3170915.170227
..;ZZZ(50.6069901,"1,17,",.02,"I")=1
..;ZZZ(50.6069901,"2,17,",.01,"I")=3170915.200528
..;ZZZ(50.6069901,"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: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)=TEXT
.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 50.606 to 50.60699 K ^PS(50.606,"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 50.606
N IFNM,FDA,IDX,IFNB,IFNB3
; START OF HDI*1*22
;S IFNM=IFN\1
S IFNM=50.606
; END OF HDI*1*22
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[HHDIPSZRT 5808 printed Oct 16, 2024@17:57:17 Page 2
HDIPSZRT ;DAL/PBB - DOSAGE FORM ENTRY POINTS FOR ZRT SEGMENT MFS UPDATE ; Apr 07, 2018@12:42
+1 ;;1.0;HEALTH DATA & INFORMATICS;**21,22**;Feb 22, 2005;Build 26
+2 ;
+3 QUIT
ZRT ;Manipulate update of MFN ZRT segment for MED DOSAGE 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=50.60699
GOTO XX99
+4 QUIT
+5 ;
XX99 ;1399 ;Manipulate update of MFN ZRT segment for MASTER DOSAGE FORM (#50.60699) File
+1 NEW X,XX,ERR,IENS,IEN1,IENX,X1,X2,X4,DA,DIK,I,FDAA,VALUE,IFN9
+2 SET IFN9=50.60699901
+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 50.60699
+2 ; IFNM File associated with IFN aka 50.606
+3 ;Scan all enries from file 50.606 field 90 and see if some dangling pointers are there, or if entries can be repointed.
+4 if $GET(ERROR)
QUIT
+5 ;^PS(50.606,"ACMF",2,63)=""
+6 ;^PS(50.606,63,0)="TAB"
+7 ;^PS(50.606,63,"MASTER")=2
+8 ;^PSMDF(50.60699,"AC","Aerosol",2,1)=""
+9 ;^PSMDF(50.60699,2,"ASSOC",1,0)="Aerosol"
+10 ;X0=2 N13="Aerosol" X1=63
+11 ;IFNA1 = ^PSMDF(IFN,"AC",N13,X0)
+12 ;IFNA2 = ^PSMDF(IFN,"AC",N13,0)
+13 ;IFNA3 = ^PSMDF(IFN,Q2,0)
+14 ;IFNA4 = ^PSMDF(IFN,Q3,0)
+15 ;IFNA = ^PSMDF(IFN,"AC",N13)
+16 ;IFNB1 = ^PS(IFNM,X1)
+17 ;IFNB2 = ^PS(IFNM,X1,0)
+18 ;IFNB3 = ^PS(IFNM,"ACMF"
+19 ;IFNB = ^PS(IFNM,X1,"MASTER")
+20 ;Get the pointers from 50.606 to be repointed to 50.60699
+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 SET C=10
SET IFNM=50.606
SET IFNA=^DIC(IFN,0,"GL")
SET IFNB=^DIC(IFNM,0,"GL")
+24 ;^PS(50.606,X0,0)
SET IFNC=IFNB_"X0,0)"
+25 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)"
+26 SET IFNB1=IFNB_"X1)"
SET IFNB2=IFNB_"X1,0)"
SET IFNB3=IFNB_"""ACMF"",IENS)"
SET IFNB=IFNB_"X1,""MASTER"")"
+27 SET MDF=90
+28 ;Check for duplicates in 50.60699,99 ASSOCIATED DOSAGE FORM STATUSES ASSOC;0 Multiple #50.60699901
+29 ;IFNA = ^PSMDF(IFN,"AC",N13)
SET N13=""
FOR
SET N13=$ORDER(@IFNA)
if '$LENGTH(N13)
QUIT
Begin DoDot:1
+30 ;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
+31 FOR
Begin DoDot:2
+32 SET Q3=+$PIECE(Q1,"(",2)
SET Q3=$PIECE(@(IFNA4),U)
+33 SET TEXT=" File: "_IFN_" Local IEN: "_+$PIECE(Q1,"(",2)_" "_Q3_" Associated "_N13_" Is Duplicate to Ass. in IEN: "_Q2_" "_$PIECE(@(IFNA3),U)
+34 SET C=C+1
SET ERR("DIERR",1,"TEXT",C)=TEXT
End DoDot:2
SET Q1=$QUERY(@Q1)
if '$LENGTH(Q1)
QUIT
+35 QUIT
End DoDot:1
+36 IF $DATA(ERR)
Begin DoDot:1
+37 SET ERR("DIERR",1,"TEXT",10)="List of Association duplicates in "_IFN_" Site:"_$$SITE^VASITE()
+38 SET ERROR="1^Records in file "_IFN_" have Association duplictes. Listing of duplicates see in MFS ERROR/WARNING/INFO"
+39 DO EM^XUMF0
+40 KILL ERR
End DoDot:1
QUIT
+41 ;
+42 ;X0=Master pointer to 50.60699
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
+43 ;No MASTER pointer into file 50.606 or MASTER needs to be repointed
IF $DATA(@IFNA)
Begin DoDot:2
+44 NEW FDA,ERR,ZZZ
+45 SET X0=$ORDER(@IFNA2)
+46 DO GETS^DIQ(IFN,X0_",","99.991*","I","ZZZ","ERR")
+47 IF $DATA(ERR)
Begin DoDot:3
+48 SET ERROR="1^Error in Retrievig status of IEN: "_X0_" in file"_IFN
+49 SET ERRCNT=+$GET(ERRCNT)
DO EM^XUMF1H(ERROR,.ERR)
End DoDot:3
QUIT
+50 ;ZZZ(50.6069901,"1,17,",.01,"I")=3170915.170227
+51 ;ZZZ(50.6069901,"1,17,",.02,"I")=1
+52 ;ZZZ(50.6069901,"2,17,",.01,"I")=3170915.200528
+53 ;ZZZ(50.6069901,"2,17,",.02,"I")=0
+54 ; Ignore "Invalid or wrong number of arguments to a function" XINDEX warning.
if '@($QUERY(ZZZ(99999999999),-1))
QUIT
+55 SET FDA(IFNM,X1_",",MDF)=X0
+56 DO FILE^DIE(,"FDA","ERR")
+57 IF $DATA(ERR)
Begin DoDot:3
+58 SET ERROR="1^Repointing entry: "_X1_" in file"_IFNM_" error."
+59 SET ERRCNT=+$GET(ERRCNT)
DO EM^XUMF1H(ERROR,.ERR)
+60 KILL ERR
End DoDot:3
+61 QUIT
End DoDot:2
QUIT
+62 if $GET(ERROR)
QUIT
+63 ; Local entry in master file doesn't exist send e-mail ito XUMF ERROR
+64 if X0
SET Q2=X0
SET Q2=$PIECE($GET(@IFNA3),U)
+65 ;
SET TEXT=" File: "_IFNM_" Local IEN: "_X1_" "_N13_" Is missing in file"_IFN_" and can NOT be "_$SELECT('X0:"SET",1:"RESET From: "_Q2)
+66 SET C=C+1
SET ERR("DIERR",1,"TEXT",C)=TEXT
+67 if X0
SET C=C+1
SET ERR("DIERR",1,"TEXT",C)=" Master IEN before: "_X0_" "_$PIECE($GET(@IFNC),U)
End DoDot:1
+68 if $GET(ERROR)
QUIT
+69 IF $DATA(ERR)
Begin DoDot:1
+70 SET ERR("DIERR",1,"TEXT",10)="List of records from file "_IFNM_" not synchronised with file "_IFN_" Site:"_$$SITE^VASITE()
+71 SET ERROR="0^Records of file "_IFN_" are not synchronised with File "_IFNM_" Listing of records see in MFS ERROR/WARNING/INFO"
+72 DO EM^XUMF0
+73 KILL ERR
End DoDot:1
QUIT
+74 QUIT
+75 ;
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 50.606 to 50.60699 K ^PS(50.606,"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 50.606
+1 NEW IFNM,FDA,IDX,IFNB,IFNB3
+2 ; START OF HDI*1*22
+3 ;S IFNM=IFN\1
+4 SET IFNM=50.606
+5 ; END OF HDI*1*22
+6 SET IFNB=^DIC(IFNM,0,"GL")
SET IFNB3=IFNB_"""ACMF"",IEN,IDX)"
+7 SET IDX=0
FOR
SET IDX=$ORDER(@IFNB3)
if 'IDX
QUIT
SET FDA(IFNM,IDX_",",90)="@"
+8 if '$DATA(FDA)
QUIT
+9 DO FILE^DIE(,"FDA","ERR")
+10 if '$DATA(ERR)
QUIT
+11 SET ERROR="1^Error in update of field 90 in file: "_IFNM
+12 SET ERRCNT=+$GET(ERRCNT)
DO EM^XUMF1H(ERROR,.ERR)
+13 ;K ERR
+14 QUIT
