RA84PRE ;Hines OI/GJC - Pre-init Driver, patch 84 ;01/05/06 06:32
;;5.0;Radiology/Nuclear Medicine;**84**;Mar 16, 1998;Build 13
;
EN ; entry point for the pre-install logic
;
;Integration Agreements
;----------------------
;CREIXN^DDMOD(2916); DELIX^DDMOD(2916); $$FIND1^DIC(2051); UPDATE^DIE(2053); ^DIK(10013)
;$$GET1^DIQ(2056); GETS^DIQ(2056); $$FMADD^XLFDT(10103); XMD(10070); BMES^XPDUTL(10141)
;$$KSP^XUPARAM(2541); $$CREATE^XUSAP(4677)
;
;check to see if the following condition: RA*5.0*56 is not installed & BEFORE DELETION REPORT
;STATUS (DD:74.01; Fld: 4) exists is true. If so, delete the BEFORE DELETION REPORT STATUS
;field from the ACTIVITY LOG sub-file (exported accidentally; no data to be concerned with)
I '($$PATCH^XPDUTL("RA*5.0*56")),($D(^DD(74.01,4,0)))#2 D
.N %,DA,DIC,DIK,X,Y
.S DIK="^DD(74.01,",DA(1)=74.01,DA=4
.D ^DIK Q
;
N DIERR,RAAPU,RAERR,RAFAC,RAFDA,RAFLD,RAFLG,RAFMC,RAIEN,RAOPT,RARY,RATXT,RAX,RAY,RAZ
S RAAPU="RADIOLOGY,OUTSIDE SERVICE",RAFMC="",RAOPT="RA OVERALL"
;
;I RAY>0 then the APU record was created; RAY will be the IEN of the new record.
;I RAY=0 then the proxy user record existed prior to calling $$CREATE^XUSAP.
;I RAY=-1 then the function failed to create the proxy user record.
S RAY=+$$CREATE^XUSAP(RAAPU,RAFMC,RAOPT)
;
I RAY>0 S RAIEN=RAY,RATXT(1)="'"_RAAPU_"' has been created as an Application Proxy User."
;
;RAY=-1: The function failed to create the proxy user record; abort the install.
I RAY=-1 S XPDABORT=1 D
.S RATXT(1)="Error: '"_RAAPU_"' has not been created as an Application"
.S RATXT(2)="Proxy User. '"_RAAPU_"' must be unique"
.S RATXT(3)="and used within the scope of the VistA Radiology teleradiology"
.S RATXT(4)="initiative. Installation of RA*5.0*84 has been aborted until this"
.S RATXT(5)="Application Proxy User record can be created."
.Q
;
;RAY=0: The proxy user record existed prior to the function call. Is the proxy record
;secure? If the proxy record is not secure abort the install.
I RAY=0 D
.;determine the IEN of 'RADIOLOGY,OUTSIDE SERVICE' in file 200...
.S RAIEN=$$FIND1^DIC(200,"","X","RADIOLOGY,OUTSIDE SERVICE","B") Q:RAIEN=0
.D GETS^DIQ(200,RAIEN_",","2;3;11;201","I","RARY") S RAFLD=""
.;Are there any NEW PERSON fields defined that jeopardize the security of this record?
.F S RAFLD=$O(RARY(200,RAIEN,RAFLD)) Q:RAFLD="" I $L($G(RARY(200,RAIEN,RAFLD,"I"))) S XPDABORT=1 Q
.I $G(XPDABORT)=1 D
..S RATXT(1)="Error: '"_RAAPU_"' is not a secure application proxy user"
..S RATXT(2)="record. Please revisit the definition of this type of user record."
..S RATXT(3)=""
..S RATXT(4)="Installation of RA*5.0*84 has been aborted until this Application Proxy"
..S RATXT(5)="User record can be created."
..Q
.Q
D BMES^XPDUTL(.RATXT)
Q:$G(XPDABORT)=1 K RATXT
;
;Add 'S' as a RAD/NUC MED CLASSIFICATION to the 'RADIOLOGY,OUTSIDE SERVICE' NEW PERSON file
;record. Assign 'RADIOLOGY,OUTSIDE SERVICE' a PERSON CLASS.
;permitted by IA 5077
I RAY'<0,(RAIEN>0) D
.K RARY S RAZ=RAIEN
.D GETS^DIQ(200,RAIEN_",","72*","I","RARY")
.I ($D(RARY)\10)=0 D ;'S' not added in the past; add now (missing "B" xref makes this tricky)
..K DIERR,RAERR,RAFDA,RARY
..S RAIEN="?+1,"_RAIEN_","
..S RAFDA(200.072,RAIEN,.01)="S"
..D UPDATE^DIE("","RAFDA","","RAERR")
..;
..;if error inform the user, proceed with filing PERSON CLASS
..I ($D(RAERR("DIERR"))#2) S RAX="RAD/NUC MED CLASSIFICATION" D ERR
..Q
.;
.;find the DIAGNOSTIC RADIOLOGY record in the PERSON CLASS (#8932.1) file.
.K DIERR,RAERR,RAFDA
.S RAPCLASS=$$PCLKUP() ;note workload encounter errors if the lookup fails
.I +RAPCLASS'>0 D Q
..;cannot find desired record; inform the user & do not execute the PERSON CLASS update
..S:+RAPCLASS=0 RATXT(1)="PERSON CLASS value DIAGNOSTIC RADIOLOGY' not found."
..S:+RAPCLASS=-1 RATXT(1)="PERSON CLASS lookup error: "_$P(RAPCLASS,U,2)
..S RATXT(2)="Encounter based workload calculations will fail until a PERSON CLASS is assigned."
..D BMES^XPDUTL(.RATXT) K RATXT
..Q
.;
.;file the PERSON CLASS value into PERSON CLASS sub-file: 200.05 IA 5077
.K DIERR,RAERR,RAFDA,RAY S RAIEN=RAZ
.S RAIEN="?+1,"_RAIEN_","
.S RAFDA(200.05,RAIEN,.01)=RAPCLASS
.S RAFDA(200.05,RAIEN,2)=$$FMADD^XLFDT(DT,-1,0,0,0) ;T-1 to make sure we work today!
.D UPDATE^DIE("","RAFDA","","RAERR")
.;
.;if error inform the user, proceed with install
.I ($D(RAERR("DIERR"))#2) S RAX="PERSON CLASS" D ERR
.Q
K DIERR,RAERR,RAFDA,RAY
;
;check to see if the facility has records within the 999-1003 IEN range within the
;DIAGNOSTIC CODES (#78.3) file. If there are records with these IENs proceed with
;the install but:
;1) DO NOT alter (change pointers) the data in the DIAGNOSTIC CODES file at the facility
;2) Send an email to an Outlook mail group identifying the facility where the
; conflict occur.
;If the IENs in this range are record free add them to the facilities' local DIAGNOSTIC CODES
;file. RAFLG=1 when there is an existing record in the the IEN range of 999-1003
S RAFLG=0 F RAIEN=999:1:1003 I ($D(^RA(78.3,RAIEN,0))#2) S RAFLG=1 Q
;
;if RAFLG=1 send the email to the Outlook mail group
I RAFLG=1 D
.S RAFAC=$$GET1^DIQ(4,+$$KSP^XUPARAM("INST"),.01)
.N XMDUN,XMDUZ,XMSUB,XMTEXT,XMY,XMZ S XMDUZ=.5
.S RATXT(1)=RAFAC_" has a conflict with national teleradiology codes"
.S RATXT(2)="diagnostic codes occupying IENS: 999-1003 in file 78.3."
.S XMSUB="DIAGNOSTIC CODES file IEN issue @ "_RAFAC,XMTEXT="RATXT("
.S XMY("VAOITVHITRadiologyFacilityLevelApplicationIssues@domain.ext")=""
.NEW DIFROM
.D ^XMD,BMES^XPDUTL(.RATXT)
.Q
;If no IEN conflict, add the nationally defined teleradiology diagnostic codes...
E D ;do-if RAFLG=0
.K RARY S RARY(999)="TELERADIOLOGY, NOT YET DICTATED^^N^n"
.S RARY(1000)="NO ALERT REQUIRED^^N^n"
.S RARY(1001)="SIGNIFICANT ABNORMALITY, ATTN NEEDED^^Y^y"
.S RARY(1002)="CRITICAL ABNORMALITY^^Y^y"
.S RARY(1003)="POSSIBLE MALIGNANCY^^Y^y",RAIEN=""
.F S RAIEN=$O(RARY(RAIEN)) Q:RAIEN="" D
..S RAFDA(78.3,"+1,",.01)=$P(RARY(RAIEN),U,1)
..S RAFDA(78.3,"+1,",3)=$P(RARY(RAIEN),U,3)
..S RAFDA(78.3,"+1,",4)=$P(RARY(RAIEN),U,4)
..S RAIEN(1)=RAIEN D UPDATE^DIE("","RAFDA","RAIEN","RAERR")
..I $D(RAERR)#2 D
...S RATXT(1)="",RATXT(2)="Error adding "_$P(RARY(RAIEN),U,1)_" to the"
...S RATXT(3)="local DIAGNOSTIC CODES file #78.3." D BMES^XPDUTL(.RATXT)
...Q
..Q
.Q
;
D XREF
Q
;
XREF ;REGARDLESS OF WHETHER FILE 78.3 HAS BEEN UPDATED, delete the traditional cross-reference
;definition on the PRIMARY DIAGNOSTIC CODE (70.03,13) field. Params: sub-DD, field #,
;cross-reference number, flag ('K' kills "AD"), array containing information about recompiled
;templates &/or xrefs, error array dialog (if any)
;
;First check if the 'New Style' cross-reference is in place. If it is, quit this function now!
;If in error, make sure the error is documented and proceed with the install of RA*5.0*84.
;
N RAERR,RAVALUE,RAY S RAVALUE(1)=70,RAVALUE(2)="AD"
;Note: "BB" (5th subscript) is the FILE & NAME cross-reference index in the INDEX (#.11) file.
S RAY=$$FIND1^DIC(.11,"","O",.RAVALUE,"BB","","RAERR")
I ($D(RAERR("DIERR")))#2 K RATXT D Q
.S RATXT(1)=$G(RAERR("DIERR",1,"TEXT",1),"Error finding the 'New Style' ""AD"" cross-reference.")
.D BMES^XPDUTL(.RATXT) K RATXT Q
;
I RAY K RATXT D Q
.S RATXT(1)="The 'New Style' PRIMARY DIAGNOSTIC CODE (70.03, #13) ""AD"" cross-reference"
.S RATXT(2)="is currently in existence." D BMES^XPDUTL(.RATXT) K RATXT Q
;
K DIERR,RAERR,RAFDA,RAIEN,RATXT
N I,RAI,RAMOWIC,RAX S RAY=0
;find the old cross-reference to delete; set RAY to the record number of the cross-reference
F S RAY=$O(^DD(70.03,13,1,RAY)) Q:'RAY Q:$G(^DD(70.03,13,1,RAY,0))="70^AD^MUMPS"
;RAY="" if there is no traditional "AD" cross-reference to delete, BUT make sure the
;new style "AD" cross-reference is created ('D NS').
I RAY="" D NS Q
D DELIX^DDMOD(70.03,13,RAY,"K","RAMOWIC","RAERR")
S I=0 F RAX="DDAUD","DIEZ","DIKZ" D
.I ($D(RAMOWIC(RAX)))#2 D
..S I=I+1,RATXT(I)=""
..S:RAX="DDAUD" RATXT(I)="DD AUDIT (#.6) updated"
..S:RAX="DIKZ" RATXT(I)="Cross-references re-compiled in namespace: "_$G(RAMOWIC(RAX)) QUIT
..I RAX="DIEZ" S RAI=0 F S RAI=$O(RAMOWIC(RAX,RAI)) Q:'RAI D
...S I=I+1,RATXT(I)="Input Template re-compiled: "_$G(RAMOWIC(RAX,RAI))
...Q
..Q
.Q
;
;Note: RAERR("DIERR") will only be defined if an error occurred...
I ($D(RAERR("DIERR")))#2 D S XPDABORT=1
.S I=I+1,RATXT(I)="",I=I+1
.S RATXT(I)="Error deleting the PRIMARY DIAGNOSTIC CODE (70.03,13) cross-reference."
.S I=I+1,RATXT(I)="Contact the national VistA Radiology development team."
.Q
D:$O(RATXT(0)) BMES^XPDUTL(.RATXT)
;
;if there is an error in deleting the old cross-reference stop the install of the patch.
Q:$G(XPDABORT)=1
;
NS ;Create the new-style cross-reference on the PRIMARY DIAGNOSTIC CODE (70.03,13) field.
;This cross-reference will be named the same as the prior cross-reference, "AD", but
;the SET & KILL logic will change. This new style cross-reference will be stored in the
;INDEX (#.11) file.
N I,J,RAMOWIC,RARSLT,RAXREF K DIERR,RAERR,RATXT
S RAXREF("FILE")=70,RAXREF("TYPE")="MU",RAXREF("NAME")="AD"
S RAXREF("EXECUTION")="F",RAXREF("ROOT FILE")=70.03,RAXREF("USE")="S"
S RAXREF("ACTIVITY")="IR"
S RAXREF("SHORT DESCR")="The 'AD' is used to mark cases eligible for the Abnormal Report option."
S RAXREF("DESCR",1)="If the diagnostic code record in the radiology DIAGNOSTIC CODES (#78.3)"
S RAXREF("DESCR",2)="has the data attribute for field: PRINT ON ABNORMAL REPORT (#3) set to"
S RAXREF("DESCR",3)="'Y' (yes) then the ""AD"" cross-reference will be set for this exam record"
S RAXREF("DESCR",4)="to indicate that this case should be identified on the Abnormal Report."
S RAXREF("DESCR",5)=""
S RAXREF("DESCR",6)="NOTE: When this field is edited the DIAGNOSTIC PRINT DATE (#20) field is"
S RAXREF("DESCR",7)="deleted!",RAXREF("VAL",1)=13
S RAXREF("KILL CONDITION")="S:X1(1)'="""" X=1"
S RAXREF("KILL")="D:($D(X1(1))#2) PRIDXIXK^RADD2(.DA,X1(1))"
S RAXREF("SET CONDITION")="S:X2(1)'="""" X=1"
S RAXREF("SET")="S:$P($G(^RA(78.3,X2(1),0)),U,3)=""Y"" ^RADPT(""AD"",X2(1),DA(2),DA(1),DA)="""""
S RAXREF("WHOLE KILL")="K ^RADPT(""AD"")"
;
D CREIXN^DDMOD(.RAXREF,"",.RARSLT,"RAMOWIC","RAERR") S I=1,RATXT(I)="",I=I+1
;
S RATXT(I)="The '"_$P(RARSLT,U,2)_"' cross-reference was"_$S(RARSLT="":" not",1:"")_" successfully created."
;
F J="DIEZ","DIKZ" D
.I J="DIEZ",($O(RAMOWIC("DIEZ",0))) D
..N J1 S J1=0
..F S J1=$O(RAMOWIC("DIEZ",J1)) Q:'J1 D
...S I=I+1,RATXT(I)="Input template: "_$P($G(RAMOWIC("DIEZ",J1)),U)_" was re-compiled."
...Q
..Q
.;
.I J="DIKZ",$G(RAMOWIC("DIKZ"))'="" D
..S I=I+1,RATXT(I)="Cross-reference re-compiled in namespace: "_$G(RAMOWIC("DIKZ"))
..Q
.Q
;
I ($D(RAERR("DIERR")))#2 D S XPDABORT=1
.S I=I+1,RATXT(I)="",I=I+1
.S RATXT(I)="Error deleting the PRIMARY DIAGNOSTIC CODE (70.03,13) cross-reference."
.S I=I+1,RATXT(I)="Contact the national VistA Radiology development team."
.Q
D:$O(RATXT(0)) BMES^XPDUTL(.RATXT)
Q
;
PCLKUP() ;PERSON CLASS lookup screened by INACTIVATED field on file 8932.1
;If successful return the IEN.
;If the lookup fails (without error) the function returns 0
;If the lookup fails (with error) the function returns null w/error dialog
; Ex: RAERR("DIERR","1","TEXT",1)="The input value contains control characters."
; If error I'll return: -1^error dialog
N RAXEC S RAXEC="N RADT S RADT=$P(^(0),U,5) I $S('RADT:1,RADT>DT:1,1:0)"
S RASULT=$$FIND1^DIC(8932.1,"","X","V183002","F","X RAXEC","RAERR") ;"V183002"
Q $S(($D(RAERR("DIERR"))#2):"-1^"_$G(RAERR("DIERR","1","TEXT",1)),1:RASULT)
;
ERR ;display the error text associated with our failed event
;input: RAX exists globally the attribute that was not filed Ex: RAD/NUC MED CLASSIFICATION
; RAERR("DIERR") exists globally
K RATXT N RACNT,RAI,RAJ S RATXT(1)="APU record error when filing "_RAX_" data"
S RAI=0,RACNT=1
F S RAI=$O(RAERR("DIERR",RAI)) Q:RAI'>0 S RACNT=RACNT+1,RATXT(RACNT)="" D
.S RAJ=0 F S RAJ=$O(RAERR("DIERR",RAI,"TEXT",RAJ)) Q:RAJ'>0 D
..Q:$G(RAERR("DIERR",RAI,"TEXT",RAJ))=""
..S RACNT=RACNT+1,RATXT(RACNT)=$G(RAERR("DIERR",RAI,"TEXT",RAJ))
..Q
.Q
D BMES^XPDUTL(.RATXT) K RATXT
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRA84PRE 12474 printed Sep 23, 2025@20:09:33 Page 2
RA84PRE ;Hines OI/GJC - Pre-init Driver, patch 84 ;01/05/06 06:32
+1 ;;5.0;Radiology/Nuclear Medicine;**84**;Mar 16, 1998;Build 13
+2 ;
EN ; entry point for the pre-install logic
+1 ;
+2 ;Integration Agreements
+3 ;----------------------
+4 ;CREIXN^DDMOD(2916); DELIX^DDMOD(2916); $$FIND1^DIC(2051); UPDATE^DIE(2053); ^DIK(10013)
+5 ;$$GET1^DIQ(2056); GETS^DIQ(2056); $$FMADD^XLFDT(10103); XMD(10070); BMES^XPDUTL(10141)
+6 ;$$KSP^XUPARAM(2541); $$CREATE^XUSAP(4677)
+7 ;
+8 ;check to see if the following condition: RA*5.0*56 is not installed & BEFORE DELETION REPORT
+9 ;STATUS (DD:74.01; Fld: 4) exists is true. If so, delete the BEFORE DELETION REPORT STATUS
+10 ;field from the ACTIVITY LOG sub-file (exported accidentally; no data to be concerned with)
+11 IF '($$PATCH^XPDUTL("RA*5.0*56"))
IF ($DATA(^DD(74.01,4,0)))#2
Begin DoDot:1
+12 NEW %,DA,DIC,DIK,X,Y
+13 SET DIK="^DD(74.01,"
SET DA(1)=74.01
SET DA=4
+14 DO ^DIK
QUIT
End DoDot:1
+15 ;
+16 NEW DIERR,RAAPU,RAERR,RAFAC,RAFDA,RAFLD,RAFLG,RAFMC,RAIEN,RAOPT,RARY,RATXT,RAX,RAY,RAZ
+17 SET RAAPU="RADIOLOGY,OUTSIDE SERVICE"
SET RAFMC=""
SET RAOPT="RA OVERALL"
+18 ;
+19 ;I RAY>0 then the APU record was created; RAY will be the IEN of the new record.
+20 ;I RAY=0 then the proxy user record existed prior to calling $$CREATE^XUSAP.
+21 ;I RAY=-1 then the function failed to create the proxy user record.
+22 SET RAY=+$$CREATE^XUSAP(RAAPU,RAFMC,RAOPT)
+23 ;
+24 IF RAY>0
SET RAIEN=RAY
SET RATXT(1)="'"_RAAPU_"' has been created as an Application Proxy User."
+25 ;
+26 ;RAY=-1: The function failed to create the proxy user record; abort the install.
+27 IF RAY=-1
SET XPDABORT=1
Begin DoDot:1
+28 SET RATXT(1)="Error: '"_RAAPU_"' has not been created as an Application"
+29 SET RATXT(2)="Proxy User. '"_RAAPU_"' must be unique"
+30 SET RATXT(3)="and used within the scope of the VistA Radiology teleradiology"
+31 SET RATXT(4)="initiative. Installation of RA*5.0*84 has been aborted until this"
+32 SET RATXT(5)="Application Proxy User record can be created."
+33 QUIT
End DoDot:1
+34 ;
+35 ;RAY=0: The proxy user record existed prior to the function call. Is the proxy record
+36 ;secure? If the proxy record is not secure abort the install.
+37 IF RAY=0
Begin DoDot:1
+38 ;determine the IEN of 'RADIOLOGY,OUTSIDE SERVICE' in file 200...
+39 SET RAIEN=$$FIND1^DIC(200,"","X","RADIOLOGY,OUTSIDE SERVICE","B")
if RAIEN=0
QUIT
+40 DO GETS^DIQ(200,RAIEN_",","2;3;11;201","I","RARY")
SET RAFLD=""
+41 ;Are there any NEW PERSON fields defined that jeopardize the security of this record?
+42 FOR
SET RAFLD=$ORDER(RARY(200,RAIEN,RAFLD))
if RAFLD=""
QUIT
IF $LENGTH($GET(RARY(200,RAIEN,RAFLD,"I")))
SET XPDABORT=1
QUIT
+43 IF $GET(XPDABORT)=1
Begin DoDot:2
+44 SET RATXT(1)="Error: '"_RAAPU_"' is not a secure application proxy user"
+45 SET RATXT(2)="record. Please revisit the definition of this type of user record."
+46 SET RATXT(3)=""
+47 SET RATXT(4)="Installation of RA*5.0*84 has been aborted until this Application Proxy"
+48 SET RATXT(5)="User record can be created."
+49 QUIT
End DoDot:2
+50 QUIT
End DoDot:1
+51 DO BMES^XPDUTL(.RATXT)
+52 if $GET(XPDABORT)=1
QUIT
KILL RATXT
+53 ;
+54 ;Add 'S' as a RAD/NUC MED CLASSIFICATION to the 'RADIOLOGY,OUTSIDE SERVICE' NEW PERSON file
+55 ;record. Assign 'RADIOLOGY,OUTSIDE SERVICE' a PERSON CLASS.
+56 ;permitted by IA 5077
+57 IF RAY'<0
IF (RAIEN>0)
Begin DoDot:1
+58 KILL RARY
SET RAZ=RAIEN
+59 DO GETS^DIQ(200,RAIEN_",","72*","I","RARY")
+60 ;'S' not added in the past; add now (missing "B" xref makes this tricky)
IF ($DATA(RARY)\10)=0
Begin DoDot:2
+61 KILL DIERR,RAERR,RAFDA,RARY
+62 SET RAIEN="?+1,"_RAIEN_","
+63 SET RAFDA(200.072,RAIEN,.01)="S"
+64 DO UPDATE^DIE("","RAFDA","","RAERR")
+65 ;
+66 ;if error inform the user, proceed with filing PERSON CLASS
+67 IF ($DATA(RAERR("DIERR"))#2)
SET RAX="RAD/NUC MED CLASSIFICATION"
DO ERR
+68 QUIT
End DoDot:2
+69 ;
+70 ;find the DIAGNOSTIC RADIOLOGY record in the PERSON CLASS (#8932.1) file.
+71 KILL DIERR,RAERR,RAFDA
+72 ;note workload encounter errors if the lookup fails
SET RAPCLASS=$$PCLKUP()
+73 IF +RAPCLASS'>0
Begin DoDot:2
+74 ;cannot find desired record; inform the user & do not execute the PERSON CLASS update
+75 if +RAPCLASS=0
SET RATXT(1)="PERSON CLASS value DIAGNOSTIC RADIOLOGY' not found."
+76 if +RAPCLASS=-1
SET RATXT(1)="PERSON CLASS lookup error: "_$PIECE(RAPCLASS,U,2)
+77 SET RATXT(2)="Encounter based workload calculations will fail until a PERSON CLASS is assigned."
+78 DO BMES^XPDUTL(.RATXT)
KILL RATXT
+79 QUIT
End DoDot:2
QUIT
+80 ;
+81 ;file the PERSON CLASS value into PERSON CLASS sub-file: 200.05 IA 5077
+82 KILL DIERR,RAERR,RAFDA,RAY
SET RAIEN=RAZ
+83 SET RAIEN="?+1,"_RAIEN_","
+84 SET RAFDA(200.05,RAIEN,.01)=RAPCLASS
+85 ;T-1 to make sure we work today!
SET RAFDA(200.05,RAIEN,2)=$$FMADD^XLFDT(DT,-1,0,0,0)
+86 DO UPDATE^DIE("","RAFDA","","RAERR")
+87 ;
+88 ;if error inform the user, proceed with install
+89 IF ($DATA(RAERR("DIERR"))#2)
SET RAX="PERSON CLASS"
DO ERR
+90 QUIT
End DoDot:1
+91 KILL DIERR,RAERR,RAFDA,RAY
+92 ;
+93 ;check to see if the facility has records within the 999-1003 IEN range within the
+94 ;DIAGNOSTIC CODES (#78.3) file. If there are records with these IENs proceed with
+95 ;the install but:
+96 ;1) DO NOT alter (change pointers) the data in the DIAGNOSTIC CODES file at the facility
+97 ;2) Send an email to an Outlook mail group identifying the facility where the
+98 ; conflict occur.
+99 ;If the IENs in this range are record free add them to the facilities' local DIAGNOSTIC CODES
+100 ;file. RAFLG=1 when there is an existing record in the the IEN range of 999-1003
+101 SET RAFLG=0
FOR RAIEN=999:1:1003
IF ($DATA(^RA(78.3,RAIEN,0))#2)
SET RAFLG=1
QUIT
+102 ;
+103 ;if RAFLG=1 send the email to the Outlook mail group
+104 IF RAFLG=1
Begin DoDot:1
+105 SET RAFAC=$$GET1^DIQ(4,+$$KSP^XUPARAM("INST"),.01)
+106 NEW XMDUN,XMDUZ,XMSUB,XMTEXT,XMY,XMZ
SET XMDUZ=.5
+107 SET RATXT(1)=RAFAC_" has a conflict with national teleradiology codes"
+108 SET RATXT(2)="diagnostic codes occupying IENS: 999-1003 in file 78.3."
+109 SET XMSUB="DIAGNOSTIC CODES file IEN issue @ "_RAFAC
SET XMTEXT="RATXT("
+110 SET XMY("VAOITVHITRadiologyFacilityLevelApplicationIssues@domain.ext")=""
+111 NEW DIFROM
+112 DO ^XMD
DO BMES^XPDUTL(.RATXT)
+113 QUIT
End DoDot:1
+114 ;If no IEN conflict, add the nationally defined teleradiology diagnostic codes...
+115 ;do-if RAFLG=0
IF '$TEST
Begin DoDot:1
+116 KILL RARY
SET RARY(999)="TELERADIOLOGY, NOT YET DICTATED^^N^n"
+117 SET RARY(1000)="NO ALERT REQUIRED^^N^n"
+118 SET RARY(1001)="SIGNIFICANT ABNORMALITY, ATTN NEEDED^^Y^y"
+119 SET RARY(1002)="CRITICAL ABNORMALITY^^Y^y"
+120 SET RARY(1003)="POSSIBLE MALIGNANCY^^Y^y"
SET RAIEN=""
+121 FOR
SET RAIEN=$ORDER(RARY(RAIEN))
if RAIEN=""
QUIT
Begin DoDot:2
+122 SET RAFDA(78.3,"+1,",.01)=$PIECE(RARY(RAIEN),U,1)
+123 SET RAFDA(78.3,"+1,",3)=$PIECE(RARY(RAIEN),U,3)
+124 SET RAFDA(78.3,"+1,",4)=$PIECE(RARY(RAIEN),U,4)
+125 SET RAIEN(1)=RAIEN
DO UPDATE^DIE("","RAFDA","RAIEN","RAERR")
+126 IF $DATA(RAERR)#2
Begin DoDot:3
+127 SET RATXT(1)=""
SET RATXT(2)="Error adding "_$PIECE(RARY(RAIEN),U,1)_" to the"
+128 SET RATXT(3)="local DIAGNOSTIC CODES file #78.3."
DO BMES^XPDUTL(.RATXT)
+129 QUIT
End DoDot:3
+130 QUIT
End DoDot:2
+131 QUIT
End DoDot:1
+132 ;
+133 DO XREF
+134 QUIT
+135 ;
XREF ;REGARDLESS OF WHETHER FILE 78.3 HAS BEEN UPDATED, delete the traditional cross-reference
+1 ;definition on the PRIMARY DIAGNOSTIC CODE (70.03,13) field. Params: sub-DD, field #,
+2 ;cross-reference number, flag ('K' kills "AD"), array containing information about recompiled
+3 ;templates &/or xrefs, error array dialog (if any)
+4 ;
+5 ;First check if the 'New Style' cross-reference is in place. If it is, quit this function now!
+6 ;If in error, make sure the error is documented and proceed with the install of RA*5.0*84.
+7 ;
+8 NEW RAERR,RAVALUE,RAY
SET RAVALUE(1)=70
SET RAVALUE(2)="AD"
+9 ;Note: "BB" (5th subscript) is the FILE & NAME cross-reference index in the INDEX (#.11) file.
+10 SET RAY=$$FIND1^DIC(.11,"","O",.RAVALUE,"BB","","RAERR")
+11 IF ($DATA(RAERR("DIERR")))#2
KILL RATXT
Begin DoDot:1
+12 SET RATXT(1)=$GET(RAERR("DIERR",1,"TEXT",1),"Error finding the 'New Style' ""AD"" cross-reference.")
+13 DO BMES^XPDUTL(.RATXT)
KILL RATXT
QUIT
End DoDot:1
QUIT
+14 ;
+15 IF RAY
KILL RATXT
Begin DoDot:1
+16 SET RATXT(1)="The 'New Style' PRIMARY DIAGNOSTIC CODE (70.03, #13) ""AD"" cross-reference"
+17 SET RATXT(2)="is currently in existence."
DO BMES^XPDUTL(.RATXT)
KILL RATXT
QUIT
End DoDot:1
QUIT
+18 ;
+19 KILL DIERR,RAERR,RAFDA,RAIEN,RATXT
+20 NEW I,RAI,RAMOWIC,RAX
SET RAY=0
+21 ;find the old cross-reference to delete; set RAY to the record number of the cross-reference
+22 FOR
SET RAY=$ORDER(^DD(70.03,13,1,RAY))
if 'RAY
QUIT
if $GET(^DD(70.03,13,1,RAY,0))="70^AD^MUMPS"
QUIT
+23 ;RAY="" if there is no traditional "AD" cross-reference to delete, BUT make sure the
+24 ;new style "AD" cross-reference is created ('D NS').
+25 IF RAY=""
DO NS
QUIT
+26 DO DELIX^DDMOD(70.03,13,RAY,"K","RAMOWIC","RAERR")
+27 SET I=0
FOR RAX="DDAUD","DIEZ","DIKZ"
Begin DoDot:1
+28 IF ($DATA(RAMOWIC(RAX)))#2
Begin DoDot:2
+29 SET I=I+1
SET RATXT(I)=""
+30 if RAX="DDAUD"
SET RATXT(I)="DD AUDIT (#.6) updated"
+31 if RAX="DIKZ"
SET RATXT(I)="Cross-references re-compiled in namespace: "_$GET(RAMOWIC(RAX))
QUIT
+32 IF RAX="DIEZ"
SET RAI=0
FOR
SET RAI=$ORDER(RAMOWIC(RAX,RAI))
if 'RAI
QUIT
Begin DoDot:3
+33 SET I=I+1
SET RATXT(I)="Input Template re-compiled: "_$GET(RAMOWIC(RAX,RAI))
+34 QUIT
End DoDot:3
+35 QUIT
End DoDot:2
+36 QUIT
End DoDot:1
+37 ;
+38 ;Note: RAERR("DIERR") will only be defined if an error occurred...
+39 IF ($DATA(RAERR("DIERR")))#2
Begin DoDot:1
+40 SET I=I+1
SET RATXT(I)=""
SET I=I+1
+41 SET RATXT(I)="Error deleting the PRIMARY DIAGNOSTIC CODE (70.03,13) cross-reference."
+42 SET I=I+1
SET RATXT(I)="Contact the national VistA Radiology development team."
+43 QUIT
End DoDot:1
SET XPDABORT=1
+44 if $ORDER(RATXT(0))
DO BMES^XPDUTL(.RATXT)
+45 ;
+46 ;if there is an error in deleting the old cross-reference stop the install of the patch.
+47 if $GET(XPDABORT)=1
QUIT
+48 ;
NS ;Create the new-style cross-reference on the PRIMARY DIAGNOSTIC CODE (70.03,13) field.
+1 ;This cross-reference will be named the same as the prior cross-reference, "AD", but
+2 ;the SET & KILL logic will change. This new style cross-reference will be stored in the
+3 ;INDEX (#.11) file.
+4 NEW I,J,RAMOWIC,RARSLT,RAXREF
KILL DIERR,RAERR,RATXT
+5 SET RAXREF("FILE")=70
SET RAXREF("TYPE")="MU"
SET RAXREF("NAME")="AD"
+6 SET RAXREF("EXECUTION")="F"
SET RAXREF("ROOT FILE")=70.03
SET RAXREF("USE")="S"
+7 SET RAXREF("ACTIVITY")="IR"
+8 SET RAXREF("SHORT DESCR")="The 'AD' is used to mark cases eligible for the Abnormal Report option."
+9 SET RAXREF("DESCR",1)="If the diagnostic code record in the radiology DIAGNOSTIC CODES (#78.3)"
+10 SET RAXREF("DESCR",2)="has the data attribute for field: PRINT ON ABNORMAL REPORT (#3) set to"
+11 SET RAXREF("DESCR",3)="'Y' (yes) then the ""AD"" cross-reference will be set for this exam record"
+12 SET RAXREF("DESCR",4)="to indicate that this case should be identified on the Abnormal Report."
+13 SET RAXREF("DESCR",5)=""
+14 SET RAXREF("DESCR",6)="NOTE: When this field is edited the DIAGNOSTIC PRINT DATE (#20) field is"
+15 SET RAXREF("DESCR",7)="deleted!"
SET RAXREF("VAL",1)=13
+16 SET RAXREF("KILL CONDITION")="S:X1(1)'="""" X=1"
+17 SET RAXREF("KILL")="D:($D(X1(1))#2) PRIDXIXK^RADD2(.DA,X1(1))"
+18 SET RAXREF("SET CONDITION")="S:X2(1)'="""" X=1"
+19 SET RAXREF("SET")="S:$P($G(^RA(78.3,X2(1),0)),U,3)=""Y"" ^RADPT(""AD"",X2(1),DA(2),DA(1),DA)="""""
+20 SET RAXREF("WHOLE KILL")="K ^RADPT(""AD"")"
+21 ;
+22 DO CREIXN^DDMOD(.RAXREF,"",.RARSLT,"RAMOWIC","RAERR")
SET I=1
SET RATXT(I)=""
SET I=I+1
+23 ;
+24 SET RATXT(I)="The '"_$PIECE(RARSLT,U,2)_"' cross-reference was"_$SELECT(RARSLT="":" not",1:"")_" successfully created."
+25 ;
+26 FOR J="DIEZ","DIKZ"
Begin DoDot:1
+27 IF J="DIEZ"
IF ($ORDER(RAMOWIC("DIEZ",0)))
Begin DoDot:2
+28 NEW J1
SET J1=0
+29 FOR
SET J1=$ORDER(RAMOWIC("DIEZ",J1))
if 'J1
QUIT
Begin DoDot:3
+30 SET I=I+1
SET RATXT(I)="Input template: "_$PIECE($GET(RAMOWIC("DIEZ",J1)),U)_" was re-compiled."
+31 QUIT
End DoDot:3
+32 QUIT
End DoDot:2
+33 ;
+34 IF J="DIKZ"
IF $GET(RAMOWIC("DIKZ"))'=""
Begin DoDot:2
+35 SET I=I+1
SET RATXT(I)="Cross-reference re-compiled in namespace: "_$GET(RAMOWIC("DIKZ"))
+36 QUIT
End DoDot:2
+37 QUIT
End DoDot:1
+38 ;
+39 IF ($DATA(RAERR("DIERR")))#2
Begin DoDot:1
+40 SET I=I+1
SET RATXT(I)=""
SET I=I+1
+41 SET RATXT(I)="Error deleting the PRIMARY DIAGNOSTIC CODE (70.03,13) cross-reference."
+42 SET I=I+1
SET RATXT(I)="Contact the national VistA Radiology development team."
+43 QUIT
End DoDot:1
SET XPDABORT=1
+44 if $ORDER(RATXT(0))
DO BMES^XPDUTL(.RATXT)
+45 QUIT
+46 ;
PCLKUP() ;PERSON CLASS lookup screened by INACTIVATED field on file 8932.1
+1 ;If successful return the IEN.
+2 ;If the lookup fails (without error) the function returns 0
+3 ;If the lookup fails (with error) the function returns null w/error dialog
+4 ; Ex: RAERR("DIERR","1","TEXT",1)="The input value contains control characters."
+5 ; If error I'll return: -1^error dialog
+6 NEW RAXEC
SET RAXEC="N RADT S RADT=$P(^(0),U,5) I $S('RADT:1,RADT>DT:1,1:0)"
+7 ;"V183002"
SET RASULT=$$FIND1^DIC(8932.1,"","X","V183002","F","X RAXEC","RAERR")
+8 QUIT $SELECT(($DATA(RAERR("DIERR"))#2):"-1^"_$GET(RAERR("DIERR","1","TEXT",1)),1:RASULT)
+9 ;
ERR ;display the error text associated with our failed event
+1 ;input: RAX exists globally the attribute that was not filed Ex: RAD/NUC MED CLASSIFICATION
+2 ; RAERR("DIERR") exists globally
+3 KILL RATXT
NEW RACNT,RAI,RAJ
SET RATXT(1)="APU record error when filing "_RAX_" data"
+4 SET RAI=0
SET RACNT=1
+5 FOR
SET RAI=$ORDER(RAERR("DIERR",RAI))
if RAI'>0
QUIT
SET RACNT=RACNT+1
SET RATXT(RACNT)=""
Begin DoDot:1
+6 SET RAJ=0
FOR
SET RAJ=$ORDER(RAERR("DIERR",RAI,"TEXT",RAJ))
if RAJ'>0
QUIT
Begin DoDot:2
+7 if $GET(RAERR("DIERR",RAI,"TEXT",RAJ))=""
QUIT
+8 SET RACNT=RACNT+1
SET RATXT(RACNT)=$GET(RAERR("DIERR",RAI,"TEXT",RAJ))
+9 QUIT
End DoDot:2
+10 QUIT
End DoDot:1
+11 DO BMES^XPDUTL(.RATXT)
KILL RATXT
+12 QUIT
+13 ;
