- 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 Feb 18, 2025@23:22:49 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