source: FOIAVistA/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAIPST1.m

Last change on this file was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version
File size: 6.0 KB
Line 
1RAIPST1 ;HISC/SWM - Post-init number one; 12/4/95 ;6/4/97 09:34
2VERSION ;;5.0;Radiology/Nuclear Medicine;;Mar 16, 1998
3 ;
4EN1 ; install signon-alert into XU Menu
5 N DA,DIC,DLAYGO,D0,TXT,X
6 S DA(1)=$O(^DIC(19,"B","XU USER SIGN-ON",0)) G:'DA(1) OUT1B
7 G:$D(^DIC(19,DA(1),"B",$O(^DIC(19,"B","RA SIGN-ON MSG",0)))) OUT1C
8 S DIC="^DIC(19,"_DA(1)_",10,",DIC(0)="L",DLAYGO=19,X="RA SIGN-ON MSG",D0=DA(1) D ^DIC
9 S TXT(1)="Option 'RA SIGN-ON MSG' IS NOW UNDER option 'XU USER SIGN-ON'"
10MES1 D MES^XPDUTL(.TXT)
11 Q
12OUT1B S TXT(1)="Option 'XU USER SIGN-ON' is missing on your system !"
13 S TXT(2)="Option 'RA SIGN-ON MSG' cannot be put under XU USER SIGN-ON'"
14 G MES1
15OUT1C S TXT(1)="You already have 'RA SIGN-ON MSG' put under 'XU USER SIGN-ON'"
16 G MES1
17EN2 ; delete obsolete *CREDIT CLINIC STOP data dictionary & descriptor nodes
18 ; from the Rad/Nuc Med Amis Codes file (71.1)
19 Q:'$D(^DD(71.13,0)) ; already deleted
20 N DIU,TXT
21 S DIU=71.13 ; subfile data dictionary number
22 S DIU(0)="SD" ; S=del dict. of subfile, D=del data also
23 D EN^DIU2
24 S TXT(1)="Deleting obsolete *CREDIT CLINIC STOP data dictionary and"
25 S TXT(2)="Descriptor nodes from Major Rad/Nuc Med AMIS Codes file"
26 D MES^XPDUTL(.TXT)
27 Q
28EN3 ; Convert free-text Device file pointer data to conventional pointer
29 ; data. The following fields are impacted: '^DD(71,3,' '^DD(79.1,3,'
30 ; '^DD(79.1,5,' '^DD(79.1,10,' & '^DD(79.1,16,'
31 Q:'($D(^DD(79,.115,0))#2) ; We've done this code in the past.
32 N RACNVRT,RAERR,RAI,RAII,RALOCK,RAROOT,RATXT
33 S RAI=+$$PARCP^XPDUTL("POST31")
34 S (RAERR,RALOCK)="",RATXT(1)=" "
35 S RATXT(2)="Converting free-text pointer data in the REQUIRED FLASH CARD PRINTER"
36 S RATXT(3)="field of the Rad/Nuc Med Procedures file to regular pointers to the"
37 S RATXT(4)="Device file."
38 D MES^XPDUTL(.RATXT)
39 F S RAI=$O(^RAMIS(71,RAI)) Q:RAI'>0 D
40 . S RAI(0)=$G(^RAMIS(71,RAI,0)) Q:RAI(0)']""
41 . S RAI(3)=$P(RAI(0),"^",3) Q:RAI(3)']""
42 . S RACNVRT=$$CVRT(RAI(3),71,3,RAI) Q:RACNVRT="" ; converted in past
43 . S RAROOT(71,+RAI_",",3)=RACNVRT
44 . D FILE^DIE(RALOCK,"RAROOT",RAERR)
45 . K RAROOT(71,+RAI_",",3)
46 . S RAII=+$$UPCP^XPDUTL("POST31",RAI)
47 . Q
48 K RACNVRT,RAROOT S RAI=+$$PARCP^XPDUTL("POST311")
49 S (RAERR,RALOCK)="",RATXT(1)=" "
50 S RATXT(2)="Converting free-text pointer data for fields:"
51 S RATXT(3)="FLASH CARD PRINTER NAME, JACKET LABEL PRINTER NAME,"
52 S RATXT(4)="REPORT PRINTER NAME and REQUEST PRINTER NAME"
53 S RATXT(5)="in the Imaging Locations file to regular pointers to the Device file."
54 D MES^XPDUTL(.RATXT)
55 F S RAI=$O(^RA(79.1,RAI)) Q:RAI'>0 D
56 . S RAI(0)=$G(^RA(79.1,RAI,0)) Q:RAI(0)']""
57 . S RAI(3)=$P(RAI(0),"^",3),RAI(5)=$P(RAI(0),"^",5)
58 . S RAI(10)=$P(RAI(0),"^",10),RAI(16)=$P(RAI(0),"^",16)
59 . S RACNVRT(3)=$$CVRT(RAI(3),79.1,3,RAI)
60 . S RACNVRT(5)=$$CVRT(RAI(5),79.1,5,RAI)
61 . S RACNVRT(10)=$$CVRT(RAI(10),79.1,10,RAI)
62 . S RACNVRT(16)=$$CVRT(RAI(16),79.1,16,RAI)
63 . S:RACNVRT(3)]"" RAROOT(79.1,+RAI_",",3)=RACNVRT(3)
64 . S:RACNVRT(5)]"" RAROOT(79.1,+RAI_",",5)=RACNVRT(5)
65 . S:RACNVRT(10)]"" RAROOT(79.1,+RAI_",",10)=RACNVRT(10)
66 . S:RACNVRT(16)]"" RAROOT(79.1,+RAI_",",16)=RACNVRT(16)
67 . D FILE^DIE(RALOCK,"RAROOT",RAERR)
68 . K RAROOT(79.1,+RAI_","),RACNVRT
69 . S RAII=+$$UPCP^XPDUTL("POST311",RAI)
70 Q
71CVRT(X,Y,Z,Z1) ; Convert free-text pointer to its corresponding ien in
72 ; the Device file.
73 ;
74 ; INPUT: 'X' is the external value (.01) of the device file
75 ; 'Y' is the Rad/Nuc Med file which has a field to be converted
76 ; 'Z' is the field in file 'Y' being converted
77 ; 'Z1' is the ien on the entry in our file (file #='Y')
78 ;
79 Q:X=""!(Y="")!(Z="") "" ; all needed for the conversion
80 N X1 S X1=$O(^%ZIS(1,"B",X,"")) ; DBIA# 10114 (supported)
81 I 'X1 D
82 . N RATXT S RATXT(1)=" "
83 . S RATXT(2)="'"_X_"' could not be found in the ""B"" cross-reference"
84 . S RATXT(3)="of the Device File (3.5)! Deleting '"_X_"' from the"
85 . S RATXT(4)="'"_$P($G(^DD(Y,Z,0)),"^")_"' field of "_$S(Y=71:"Rad/Nuc Med Procedure",1:"Imaging Location")
86 . S RATXT(5)=$$GET1^DIQ($S(Y=71:71,1:79.1),Z1,.01)
87 . S X1="@" D MES^XPDUTL(.RATXT)
88 . Q
89 Q X1
90EN4 ; Convert the "Allow 'Released/Unverified'" data from the Rad/Nuc Med
91 ; Division '^RA(79,' file to the new field, "Allow 'Released
92 ; /Unverified'" in the Imaging Locations '^RA(79.1,' file. When the
93 ; data conversion is finished, delete the "Allow 'Released/Unverified'"
94 ; field from the Rad/Nuc Med Division '^RA(79,' file.
95 ;
96 Q:'($D(^DD(79,.115,0))#2) ; quit if previously converted.
97 ;
98 ; Convert the data from the old field to the new field.
99 K RATXT S RATXT(1)=" "
100 S RATXT(2)="Converting ALLOW 'RELEASED/UNVERIFIED' data from the Rad/"
101 S RATXT(3)="Nuc Med Division file to the new ALLOW 'RELEASED/UNVERIFIED'."
102 S RATXT(4)="field on the Imaging Locations file. "
103 S RATXT(5)=" " D MES^XPDUTL(.RATXT)
104 N RA79,RADBS,RADFN,RADIV,RAERR,RAILOC,RATXT
105 S (RADIV,RAERR)=0
106 F S RADIV=$O(^RA(79,RADIV)) Q:RADIV'>0 D
107 . S RA79(.1)=$G(^RA(79,RADIV,.1))
108 . S RA79(.115)=$P(RA79(.1),"^",15) Q:RA79(.115)']""
109 . S RAILOC=0
110 . F S RAILOC=$O(^RA(79,RADIV,"L","B",RAILOC)) Q:RAILOC'>0 D
111 .. S RADFN(79.1,RAILOC_",",17)=RA79(.115)
112 .. Q
113 . Q
114 D FILE^DIE("","RADFN","RADBS(""ERROR"")") ; move the data into 79.1!
115 S RAERR=$S($D(RADBS("ERROR","DIERR"))#2:1,1:0)
116 I RAERR D Q:RAERR
117 . K RATXT S RATXT(1)=" "
118 . S RATXT(2)="Data conversion between the Rad/Nuc Med Division file"
119 . S RATXT(3)="and the Imaging Locations file for the ALLOW 'RELEASED/"
120 . S RATXT(3)="UNVERIFIED field has failed. IRM and the Rad/Nuc Med"
121 . S RATXT(4)="ADPAC should investigate!"
122 . S RATXT(5)=" " D MES^XPDUTL(.RATXT)
123 . Q
124 ; Remove data & any crossreferences on field .115 in file 79!
125 ; Delete field .115 (Allow 'Released/Unverified') from ^DD(79.
126 K RA79 S RADIV=0 F S RADIV=$O(^RA(79,RADIV)) Q:RADIV'>0 D
127 . S RA79=$P($G(^RA(79,RADIV,.1)),"^",15) Q:RA79']""
128 . D ENKILL^RAXREF(79,.115,RA79,.RADIV)
129 . S $P(^RA(79,RADIV,.1),"^",15)=""
130 . Q
131 K RATXT S RATXT(1)=" "
132 S RATXT(2)="Deleting obsolete ALLOW 'RELEASED/UNVERIFIED' field from"
133 S RATXT(3)="Rad/Nuc Med Division file.",RATXT(4)=" "
134 D MES^XPDUTL(.RATXT)
135 N DA,DIC,DIK,X,Y
136 S DA(1)=79,DA=.115,DIK="^DD(79," D ^DIK
137 Q
Note: See TracBrowser for help on using the repository browser.