BRAPCC ; IHS/ITSC/PDW,CLS - RADIOLOGY PCC LINK ; 17 Aug 2011 2:05 PM
;;5.0;Radiology/Nuclear Medicine;**1001,1003**;Nov 01, 2010;Build 3
; RA*4*2 IHS/ADC/GTH 01/21/98 If the conversion has not been done, walk back to file 6.
;
;
CREATE ;EP---> CREATE OR MODIFY A VISIT FILE ENTRY, CREATE A NEW V RAD ENTRY.
;S DUZ(0)="@" MWR >>No longer needed IHS/ISD/EDE 1/6/97
K APCDALVR N I,N,X
;---> QUIT IF PCC IS NOT PRESENT AT THIS SITE (RPMS SITE FILE).
Q:$P(^AUTTSITE(1,0),U,8)'="Y"
;---> QUIT IF NO PCC MASTER CONTROL FILE FOR THIS SITE.
Q:'$D(^APCCCTRL(DUZ(2)))
;---> QUIT IF RADIOLOGY IS NOT IN THE PACKAGE FILE.
S DIC=9.4,DIC(0)="",X="RADIOLOGY/NUCLEAR MEDICINE" D ^DIC
Q:Y<0
;---> QUIT IF RADIOLOGY IS NOT IN PCC MASTER CONTROL FILE OR IF
;---> "PASS DATA TO PCC" IS "NO".
Q:'$D(^APCCCTRL(DUZ(2),11,+Y,0))
Q:'$P(^APCCCTRL(DUZ(2),11,+Y,0),U,2)
;---> QUIT IF VISIT TYPE ISN'T DEFINED IN PCC MASTER CONTROL FILE.
Q:$P(^APCCCTRL(DUZ(2),0),U,4)']""
;---> QUIT IF NECESSARY RAD VARIABLES ARE NOT PRESENT.
Q:'$D(RADFN) Q:'$D(RADTI) Q:'$D(RACNI) Q:'$D(RADTE)
;---> QUIT IF PCC DATE/TIME NODE DOES NOT EXIST.
Q:'$D(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"PCC"))
;IHS/BJI/DAY - Patch 1003 - Block Future Exam Dates
D NOW^%DTC
S Y=$P(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"PCC"),U)
I Y>% Q
;End Patch
;
;I interactive S variable D EN^BSDAPI3 I IEN S APCDVSIT=IEN D VRAD Q ;IHS/ITSC/CLS 05/11/2004
;
VISIT ;---> CREATE OR MODIFY VISIT IN VISIT FILE.
;---> SET BRATEST=1 TO DISPLAY VISIT AND V RAD PTRS AFTER SET.
S BRATEST=0
;
;---> PATIENT
S APCDALVR("APCDPAT")=RADFN
;
;---> PCC DATE/TIME; IF NO TIME, ATTACH 12 NOON.
S APCDALVR("APCDDATE")=$P(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"PCC"),U)
I '$P(APCDALVR("APCDDATE"),".",2) S APCDALVR("APCDDATE")=APCDALVR("APCDDATE")_".12"
;
;---> LOCATION
S APCDALVR("APCDLOC")=DUZ(2)
;IHS/BJI/DAY - Patch 1003 - Can't use DUZ(2) in a multi-div site
;Get Pointer to Imaging Location
S BRAZZ=$P($G(^RADPT(RADFN,"DT",RADTI,0)),U,4)
;Check Pointer to Radiology Division
I BRAZZ,+$G(^RA(79.1,BRAZZ,"DIV")) S APCDALVR("APCDLOC")=$G(^RA(79.1,BRAZZ,"DIV"))
K BRAZZ
;End Patch
;
;---> VISIT TYPE FROM PCC MASTER CONTROL FILE. (I,C,T,6,V)
S APCDALVR("APCDTYPE")=$P(^APCCCTRL(DUZ(2),0),U,4)
;
;---> TYPE OF LINK FROM PCC MASTER CTRL FILE; IF TIME REQ SET APCDAUTO.
;I $P(^APCCCTRL(DUZ(2),0),U,2) S APCDALVR("APCDAUTO")=""
;---> RADIOLOGY SOFTWARE WILL APPEND 12 NOON TO ANY VISIT WITHOUT TIME.
S APCDALVR("APCDAUTO")=""
;
;---> CATEGORY
S X=$S($P(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0),U,4)="I":"I",1:"A")
;
;IHS/ANMC/LJF 11/28/2001 if observation patient use A (PIMS v5.3)
I X="I" D
.NEW DAT,CA S DAT=9999999.9999-RADTI ;convert date
.S CA=$$INPT1^BDGF1(RADFN,DAT) ;admission ien
.I CA,$$GET1^DIQ(405,+$$PRIORTXN^BDGF1(DAT,CA,RADFN),.09)["OBSERVATION" S X="A"
.;IHS/ANMC/LJF 11/28/2001 end of new code
S APCDALVR("APCDCAT")=X K X
;
;---> CLINIC
;modified for correct clinic identification IHS/HQW/PMF-4/25/01**8**
;S X=$P(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0),U,8)
;S X=$P($G(^SC(+X,0)),U,7)
;S X=$S(X:X,APCDALVR("APCDCAT")="A":57,1:0)
;
D CLINIC ;IHS/HQW/PMF - 4/25/01 **8**
;
;---> REQUESTING PROVIDER/ORDERING PROVIDER
;---> I $P(^AUTTSITE(1,0),U,22)) SEND 200 PTR.
S X=$P(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0),U,14)
;S:$P(^AUTTSITE(1,0),U,22) X=^DIC(16,X,"A3") ;IHS/ISD/EDE 02/16/97
; no longer necessary, converted to file 200 IHS/ISD/EDE 02/16/97
;S:$P(^AUTTSITE(1,0),U,22) X=^DIC(16,X,"A3") ; RA*4*2 IHS/ADC/GTH 01/21/98 If the conversion has not been done, walk back to file 6.
; check the DD of the VRAD file vs the PCC converted field is the site global $P(^AUTTSITE(1,0),U,22) due to users have errored the process by changing the flag.
D:$P(^DD(9000010.22,1202,0),U,3)="DIC(6," ; RA*4*5 IHS/HQW/JDH If no PCC conversion to file 200, convert to file 6
.N Y
.S Y=^VA(200,X,0)
.S X=$P($G(^DIC(16,+$P(Y,U,16),0)),U)=$P(Y,U)
.S:X X=$P(Y,U,16)
S:X APCDALVR("APCDTPRV")="`"_X K X
;
;---> NO INTERACTION, NO FILEMAN ECHOING
S APCDALVR("AUPNTALK")="",APCDALVR("APCDANE")=""
;
D ^APCDALV
D:BRATEST DISPLAY1
;
G:'$$STORE(197,$G(APCDALVR("APCDVSIT"))) EXIT ; store the ptr in the PCC node of ^RADPT IHS/HQW/JDH
;
;---> QUIT IF VISIT WAS NOT CREATED.
;G:'$D(APCDALVR("APCDVSIT")) EXIT ; IHS/HQW/JDH replaced by the call to STORE
G:$D(APCDALVR("APCDAFLG")) EXIT
;
;RETURNS APCDVSIT - PTR TO VISIT JUST SELECTED OR CREATED
; APCDVSIT("NEW") - IF ^APCDALVR CREATED A NEW VISIT
; APCDAFLG - =2 IF FAILED TO CREATE VISIT
;
VRAD ;---> CREATE (ADD) VISIT TO V RADIOLOGY FILE.
;
I $P($G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"PCC")),"^",2) D UPDTIMP(RADFN,RADTI) Q ;IHS/ITSC/CLS 01/09/2004
;
;V RADIOLOGY FILE#=9000010.22
S DLAYGO=9000010.22
;
;---> RADIOLOGY PROCEDURE
S APCDALVR("APCDTRAD")="`"_$P(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0),U,2)
;
;IHS/BJI/DAY - Patch 1003 - Add Encounter Provider to V Rad
S X=$P(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0),U,15)
I +X S APCDALVR("APCDTEPR")="`"_X
;End patch
;
;---> RADIOLOGY PROCEDURE EVENT DATE/TIME
S APCDALVR("APCDTCDT")=$P(^RADPT(RADFN,"DT",RADTI,0),U)
;
;---> ABNORMAL ; V RAD ^DD SHOULD BE MODIFIED TO TAKE DIAG CODES!
;---> 4/6/95:
;---> LORI WILL BE CHANGING THE .05 FIELD OF V RADIOLOGY TO POINT
;---> THE THE DIAGNOSTIC CODES FILE #78.3 SOMETIME SOON. FOR NOW
;---> FIELD #.05 IS STILL A SET OF CODES: NORMAL/ABNORMAL.
;S APCDALVR("APCDTABN")=0
;
;---> 3/17/97 WE DECIDED TO LEAVE .05 FIELD AS IS FOR DIRECT DATA
;---> ENTRY AND ADDED A .06 FIELD FOR DIAGNOSTIC CODE IHS/ISD/EDE
;S APCDALVR("APCDTDC")="`"_$P(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0),U,13)
I +$P($G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)),U,13) D
.S APCDALVR("APCDTDC")="`"_$P(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0),U,13)
;---> REMOVE THE ; FROM ABOVE LINE WHEN PCC READY TO TAKE DIAGNOSTIC
;---> CODES ::IHS/ISD/EDE 03/17/97
;---> ;IHS/ITSC/CLS 01/08/2004 don't send just an "`"
;
;---> IMPRESSION
S APCDALVR("APCDTIMP")="NO IMPRESSION."
I $G(RARPT),$D(^RARPT(RARPT,"I")) D ;IHS/PLS 12/26/2001 - $G added
.S I=$$SETIMP ;IHS/ITSC/CLS 01/08/2004
.I $L(I) S APCDALVR("APCDTIMP")=I
;
;---> TEMPLATE TO ADD VISIT TO V RADIOLOGY FILE.
S APCDALVR("APCDATMP")="[APCDALVR 9000010.22 (ADD)]"
D ^APCDALVR
D:BRATEST DISPLAY2
;
G:'$$STORE(196,$G(APCDALVR("APCDADFN"))) EXIT ; store the pointer in PCC node of ^RADPT IHS/HQW/JDH
;
;G:'$D(APCDALVR("APCDADFN")) EXIT ; IHS/HQW/JDH replaced by the call to STORE
G:$D(APCDALVR("APCDAFLG")) EXIT
D:BRATEST DISPLAY3
; replaced by STORE
;S X=APCDALVR("APCDADFN")_"^"_APCDALVR("APCDVSIT")
;S $P(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"PCC"),U,2,3)=X
;D:BRATEST DISPLAY3
;
EXIT ;
K I,N,BRATEST,X
Q
;
CLINIC ;
; Identify radiology clinic rather than stuff a value
;IHS/HQW/PMF - 05/30/01 **8**
;
;retrieve the clinic number
N RACLINIC
;first get the hospital location pointer from the rad patient file
S RACLINIC=$P(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0),U,8)
;if that pointer is not null, get the stop code number from the
;hospital location file, if it's there.
;if not there, clinic will be null
I RACLINIC'="" S RACLINIC=$P($G(^SC(+RACLINIC,0)),U,7)
;
;if we got one, set the arrays and stop.
;
I RACLINIC S (APCDALVR("APCDTCLN"),APCDALVR("APCDCLN"))="`"_RACLINIC Q
;
;if that didn't work, and this is NOT a category A, stop
;
I APCDALVR("APCDCAT")'="A" Q
;if we got this far, use the ein of the Radiology clinic stop
S RACLINIC=$O(^DIC(40.7,"B","RADIOLOGY",""))
I RACLINIC S (APCDALVR("APCDTCLN"),APCDALVR("APCDCLN"))="`"_RACLINIC
Q
;End changes to identify correct clinic -IHS/HWQ/PWF -05/30/01 **8**
;
STORE(RAFLD,RAVALUE) ;---> STORE VISIT AND V RAD IEN'S IN RADIOLOGY EXAMS FILE #70
N RAFDA,RAOK
S RAOK=1
S:'RAVALUE RAOK=0 ; If pointer fields were defined for the PCC node, this kludge would not be needed.
D:RAOK
.S RAFDA($J,70.03,""_RACNI_","_RADTI_","_RADFN_",",RAFLD)=RAVALUE
.D FILE^DIE("E","RAFDA($J)","RAFDA($J,""ERR"")")
I $G(DIERR)!'RAOK D
.W !!,*7,"The Radiology to PCC interface has encountered an error. Please call the HQW help desk at 248-4371"
.W !!,$G(RAFDA($J,"ERR","DIERR",1,"TEXT",1)),!!
.D ^%ZTER S RAOK=0 ; trap an error
Q RAOK
;
;
DELETE ;EP---> DELETE PCC V RAD ENTRY. (REQUIRES RADFN, RADTI, & RACNI)
;---> CALLED FROM CIAZPRAD (DELETE OR CANCEL AN EXAM). ;IHS/ITSC/CLS 01/08/2004
;---> QUIT IF NECESSARY RAD VARIABLES ARE NOT PRESENT.
Q:'$D(RADFN) Q:'$D(RADTI) Q:'$D(RACNI) Q:'$D(RADTE) ;IHS/ITSC/CLS 12/31/2003
I $D(^RADPT(RADFN,"DT",RADTI,"P",+RACNI,"PCC")) D
.S DA=$P(^RADPT(RADFN,"DT",RADTI,"P",+RACNI,"PCC"),U,2)
.;---> QUIT IF POINTER TO VRAD FILE IS NULL.
.Q:'+DA
.Q:'$D(^AUPNVRAD(DA,0))
.S APCDVDLT=$P(^AUPNVRAD(DA,0),U,3)
.S DIK="^AUPNVRAD(" D ^DIK
.Q:APCDVDLT'=$P(^RADPT(RADFN,"DT",RADTI,"P",+RACNI,"PCC"),U,3)
.D:'$P(^AUPNVSIT(APCDVDLT,0),U,9) ^APCDVDLT
.;---> SET PCC VISIT POINTERS FOR THIS EXAM = NULL.
.S $P(^RADPT(RADFN,"DT",RADTI,"P",+RACNI,"PCC"),U,2,3)=""
Q
;
;
DISPLAY1 ;---> DISPLAY VISIT IEN.
I $D(APCDALVR("APCDVSIT")) D
.W !,"APCDVSIT DEFINED: ",APCDALVR("APCDVSIT")
I $D(APCDALVR("APCDVSIT","NEW")) D
.W !,"NEW VISIT: ",APCDALVR("APCDVSIT","NEW")
;---> SHOW FLAG IF VISIT WAS NOT CREATED.
I $D(APCDALVR("APCDAFLG")) D
.W !,"APCDAFLG DEFINED, FAILED: ",APCDALVR("APCDAFLG")
Q
DISPLAY2 ;---> DISPLAY V RAD IEN.
I $D(APCDALVR("APCDADFN")) D
.W !,"APCDADFN DEFINED: ",APCDALVR("APCDADFN")
;> SHOW FLAG IF VISIT WAS NOT CREATED.
I $D(APCDALVR("APCDAFLG")) D
.W !,"APCDAFLG DEFINED, FAILED: ",APCDALVR("APCDAFLG")
Q
DISPLAY3 ;---> DISPLAY VISIT AND V RAD GLOBAL NODES AND FILE#70 IENS.
W !!,"VISIT FILE: "
S N=APCDALVR("APCDVSIT")-3
F S N=$O(^AUPNVSIT(N)) Q:'N D
.W !,N,": ",^AUPNVSIT(N,0)
;
W !!,"V RAD FILE: "
S N=APCDALVR("APCDADFN")-3,M=N+10
F S N=$O(^AUPNVRAD(N)) Q:'N Q:N>M D
.W !,N,": ",^AUPNVRAD(N,0)
W !,"EXAM IENS: ",RADFN," ",RADTI," ",RACNI
Q
;
UPDTIMP(RADFN,RADTI) ;EP ---> Called from BRAPRAD and VRAD above
;Updates V RAD file with impression after a visit has been sent to PCC
;at EXAMINED with "NO IMPRESSION." in V RAD file
;IHS/HQW/SCR - 07/20/01 **8**
;
;IHS/CMI/DAY - We sometimes get calls with RACNE instead of RACN
I $G(RACN)="",$G(RACNE)]"" S RACN=RACNE
;
S RAXM=0,RACNUM="" ;IHS/HQW/SCR - 07/20/01 **8**
;
;If the exam has been VERIFIED locate the CaseNumber of the EXam since
;multiple EXams can be part of the same visit-IHS/HQW/SCR-07/20/01**8**
;
F D Q:RAXM="" S RAXM=$O(^RADPT(RADFN,"DT",RADTI,"P",RAXM)),RACNUM=$P(^(RAXM,0),U) Q:RACNUM=RACN ;IHS/HQW/SCR - 07/20/01 **8**
;
;Use the RAXM to identify the IEN of the V RAD file for this visit
;IHS/HQW/SCR - 7/20/01 **8**
S PCCVRAD=$P(^RADPT(RADFN,"DT",RADTI,"P",RAXM,"PCC"),U,2) ;IHS/HQW/SCR - 07/20/01 **8**
I $G(PCCVRAD)="" W !,"NO PCC data available for this exam." D CLN Q ;IHS/HQW/SCR - 8/15/01 **8**
;
;If report is Unverified (ORDSTS="ZU"), revert back to "NO IMPRESSION."
;If report has been deleted, report pointer is null.
;
I ORDSTS="ZU" S I="NO IMPRESSION." D CDIE Q ;IHS/ITSC/CLS 01/08/2004 if report unverified, reset impression
;
;If the impression field of the VRAD file holds "NO IMPRESSION.", update the
;field with the impression that is now stored in the Radiology Reports file.
; -- IHS/HQW/SCR - 07/20/01 **8**
;
;If report is Re-verified (ACTION="ZE"), update impression.
;
;I $G(^AUPNVRAD(PCCVRAD,11))="NO IMPRESSION." D ;IHS/HQW/SCR-7/20/01
I $G(^AUPNVRAD(PCCVRAD,11))="NO IMPRESSION."!(ACTION="RE") D ;IHS/ITSC/CLS 01/08/2004
.N DIE,DA,DR ;IHS/HQW/SCR - 07/20/01 **8**
.;S DIE="^AUPNVRAD(",DA=PCCVRAD,DR="1101///"_$G(^RARPT(RARPT,"I",1,0)) ;IHS/HQW/SCR - 07/20/01 **8**
.;N RARPT S RARPT=$P(^RADPT(RADFN,"DT",RADTI,"P",RAXM,0),U,17) Q:'$D(^RARPT(RARPT,"I")) ;IHS/ITSC/CLS 07/15/2004
.I '$G(RARPT) N RARPT S RARPT=$P(^RADPT(RADFN,"DT",RADTI,"P",RAXM,0),U,17) G CLN:RARPT="" G CLN:'$D(^RARPT(RARPT,"I")) ;IHS/ITSC/CLS 07/15/2004 09/28/2004
.S I=$$SETIMP ;IHS/ITSC/CLS 01/08/2004
.I +$P($G(^RADPT(RADFN,"DT",RADTI,"P",RAXM,0)),U,13) D
..S DC="`"_$P(^RADPT(RADFN,"DT",RADTI,"P",RAXM,0),U,13) ;IHS/ITSC/CLS 01/09/2004 added diagnostic code
.D CDIE
Q
;
CDIE ;CALL DIE
;S DIE="^AUPNVRAD(",DA=PCCVRAD,DR="1101///"_I
S DIE="^AUPNVRAD(",DA=PCCVRAD,DR="1101///"_I_";.06///"_$G(DC) ;IHS/ITSC/CLS 01/09/2004
L +^AUPNVRAD(PCCVRAD):0 I '$T W !,"Can not update IMPRESSION in V RAD file. File being edit by another user." Q ;IHS/HQW/SCR - 07/20/01 **8**
D ^DIE ;IHS/HQW/SCR - 07/20/01 **8**
L -^AUPNVRAD(PCCVRAD) ;IHS/HQW/SCR - 07/20/01 **8**
W !,"IMPRESSION has been updated in the V RAD file." ;IHS/HQW/SCR - 07/20/01 **8**
;
;The following two lines tell the VISIT file when this visit was
;last modified and is needed whenever PCC is not updated through
; ^APCDALVR per Lori Butcher - IHS/HQW/SCR - 07/24/01 **8**
;
S AUPNVSIT=""
I $G(PCCVRAD)]"" S AUPNVSIT=$P($G(^AUPNVRAD(PCCVRAD,0)),U,3) ;IHS/HQW/SCR - 7/24/01 **8**
I $G(AUPNVSIT)]"" D MOD^AUPNVSIT ;IHS/HQW/SCR - 07/24/01 **8**
K DIE,DA,DR,AUPNVSIT ;IHS/HQW/SCR - 07/20/01 **8**
CLN ;
K DC,I,RAFN,RATI,XM,CN,PCCVRAD ;IHS/HQW/SCR - 07/20/01 **8**
Q ;IHS/HQW/SCR - 07/20/01 **8**
;
Q ;
K RADA,RADFNZ,RADTIZ,RACNIZ Q
;
SETIMP() ;moved set impression string to function call ;IHS/ITSC/CLS 01/08/2004
S I="",N=0 F S N=$O(^RARPT(RARPT,"I",N)) Q:'N D
.I $L(I)+$L(^RARPT(RARPT,"I",N,0))<220 S I=I_" "_^(0) Q
.S I=I_"...*MORE* (SEE EXAM).",N=-1
;IHS/BJI/DAY - Patch 1003 - Cleanup needed for Fileman
I $E(I)=" " S I=$E(I,2,999)
I $E(I)=" " S I=$E(I,2,999)
I $E(I)=" " S I=$E(I,2,999)
S I=$TR(I,";",",")
Q I
BRAPCC ; IHS/ITSC/PDW,CLS - RADIOLOGY PCC LINK ; 17 Aug 2011 2:05 PM
+1 ;;5.0;Radiology/Nuclear Medicine;**1001,1003**;Nov 01, 2010;Build 3
+2 ; RA*4*2 IHS/ADC/GTH 01/21/98 If the conversion has not been done, walk back to file 6.
+3 ;
+4 ;
CREATE ;EP---> CREATE OR MODIFY A VISIT FILE ENTRY, CREATE A NEW V RAD ENTRY.
+1 ;S DUZ(0)="@" MWR >>No longer needed IHS/ISD/EDE 1/6/97
+2 KILL APCDALVR
NEW I,N,X
+3 ;---> QUIT IF PCC IS NOT PRESENT AT THIS SITE (RPMS SITE FILE).
+4 IF $PIECE(^AUTTSITE(1,0),U,8)'="Y"
QUIT
+5 ;---> QUIT IF NO PCC MASTER CONTROL FILE FOR THIS SITE.
+6 IF '$DATA(^APCCCTRL(DUZ(2)))
QUIT
+7 ;---> QUIT IF RADIOLOGY IS NOT IN THE PACKAGE FILE.
+8 SET DIC=9.4
SET DIC(0)=""
SET X="RADIOLOGY/NUCLEAR MEDICINE"
DO ^DIC
+9 IF Y<0
QUIT
+10 ;---> QUIT IF RADIOLOGY IS NOT IN PCC MASTER CONTROL FILE OR IF
+11 ;---> "PASS DATA TO PCC" IS "NO".
+12 IF '$DATA(^APCCCTRL(DUZ(2),11,+Y,0))
QUIT
+13 IF '$PIECE(^APCCCTRL(DUZ(2),11,+Y,0),U,2)
QUIT
+14 ;---> QUIT IF VISIT TYPE ISN'T DEFINED IN PCC MASTER CONTROL FILE.
+15 IF $PIECE(^APCCCTRL(DUZ(2),0),U,4)']""
QUIT
+16 ;---> QUIT IF NECESSARY RAD VARIABLES ARE NOT PRESENT.
+17 IF '$DATA(RADFN)
QUIT
IF '$DATA(RADTI)
QUIT
IF '$DATA(RACNI)
QUIT
IF '$DATA(RADTE)
QUIT
+18 ;---> QUIT IF PCC DATE/TIME NODE DOES NOT EXIST.
+19 IF '$DATA(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"PCC"))
QUIT
+20 ;IHS/BJI/DAY - Patch 1003 - Block Future Exam Dates
+21 DO NOW^%DTC
+22 SET Y=$PIECE(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"PCC"),U)
+23 IF Y>%
QUIT
+24 ;End Patch
+25 ;
+26 ;I interactive S variable D EN^BSDAPI3 I IEN S APCDVSIT=IEN D VRAD Q ;IHS/ITSC/CLS 05/11/2004
+27 ;
VISIT ;---> CREATE OR MODIFY VISIT IN VISIT FILE.
+1 ;---> SET BRATEST=1 TO DISPLAY VISIT AND V RAD PTRS AFTER SET.
+2 SET BRATEST=0
+3 ;
+4 ;---> PATIENT
+5 SET APCDALVR("APCDPAT")=RADFN
+6 ;
+7 ;---> PCC DATE/TIME; IF NO TIME, ATTACH 12 NOON.
+8 SET APCDALVR("APCDDATE")=$PIECE(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"PCC"),U)
+9 IF '$PIECE(APCDALVR("APCDDATE"),".",2)
SET APCDALVR("APCDDATE")=APCDALVR("APCDDATE")_".12"
+10 ;
+11 ;---> LOCATION
+12 SET APCDALVR("APCDLOC")=DUZ(2)
+13 ;IHS/BJI/DAY - Patch 1003 - Can't use DUZ(2) in a multi-div site
+14 ;Get Pointer to Imaging Location
+15 SET BRAZZ=$PIECE($GET(^RADPT(RADFN,"DT",RADTI,0)),U,4)
+16 ;Check Pointer to Radiology Division
+17 IF BRAZZ
IF +$GET(^RA(79.1,BRAZZ,"DIV"))
SET APCDALVR("APCDLOC")=$GET(^RA(79.1,BRAZZ,"DIV"))
+18 KILL BRAZZ
+19 ;End Patch
+20 ;
+21 ;---> VISIT TYPE FROM PCC MASTER CONTROL FILE. (I,C,T,6,V)
+22 SET APCDALVR("APCDTYPE")=$PIECE(^APCCCTRL(DUZ(2),0),U,4)
+23 ;
+24 ;---> TYPE OF LINK FROM PCC MASTER CTRL FILE; IF TIME REQ SET APCDAUTO.
+25 ;I $P(^APCCCTRL(DUZ(2),0),U,2) S APCDALVR("APCDAUTO")=""
+26 ;---> RADIOLOGY SOFTWARE WILL APPEND 12 NOON TO ANY VISIT WITHOUT TIME.
+27 SET APCDALVR("APCDAUTO")=""
+28 ;
+29 ;---> CATEGORY
+30 SET X=$SELECT($PIECE(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0),U,4)="I":"I",1:"A")
+31 ;
+32 ;IHS/ANMC/LJF 11/28/2001 if observation patient use A (PIMS v5.3)
+33 IF X="I"
Begin DoDot:1
+34 ;convert date
NEW DAT,CA
SET DAT=9999999.9999-RADTI
+35 ;admission ien
SET CA=$$INPT1^BDGF1(RADFN,DAT)
+36 IF CA
IF $$GET1^DIQ(405,+$$PRIORTXN^BDGF1(DAT,CA,RADFN),.09)["OBSERVATION"
SET X="A"
+37 ;IHS/ANMC/LJF 11/28/2001 end of new code
End DoDot:1
+38 SET APCDALVR("APCDCAT")=X
KILL X
+39 ;
+40 ;---> CLINIC
+41 ;modified for correct clinic identification IHS/HQW/PMF-4/25/01**8**
+42 ;S X=$P(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0),U,8)
+43 ;S X=$P($G(^SC(+X,0)),U,7)
+44 ;S X=$S(X:X,APCDALVR("APCDCAT")="A":57,1:0)
+45 ;
+46 ;IHS/HQW/PMF - 4/25/01 **8**
DO CLINIC
+47 ;
+48 ;---> REQUESTING PROVIDER/ORDERING PROVIDER
+49 ;---> I $P(^AUTTSITE(1,0),U,22)) SEND 200 PTR.
+50 SET X=$PIECE(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0),U,14)
+51 ;S:$P(^AUTTSITE(1,0),U,22) X=^DIC(16,X,"A3") ;IHS/ISD/EDE 02/16/97
+52 ; no longer necessary, converted to file 200 IHS/ISD/EDE 02/16/97
+53 ;S:$P(^AUTTSITE(1,0),U,22) X=^DIC(16,X,"A3") ; RA*4*2 IHS/ADC/GTH 01/21/98 If the conversion has not been done, walk back to file 6.
+54 ; check the DD of the VRAD file vs the PCC converted field is the site global $P(^AUTTSITE(1,0),U,22) due to users have errored the process by changing the flag.
+55 ; RA*4*5 IHS/HQW/JDH If no PCC conversion to file 200, convert to file 6
IF $PIECE(^DD(9000010.22,1202,0),U,3)="DIC(6,"
Begin DoDot:1
+56 NEW Y
+57 SET Y=^VA(200,X,0)
+58 SET X=$PIECE($GET(^DIC(16,+$PIECE(Y,U,16),0)),U)=$PIECE(Y,U)
+59 IF X
SET X=$PIECE(Y,U,16)
End DoDot:1
+60 IF X
SET APCDALVR("APCDTPRV")="`"_X
KILL X
+61 ;
+62 ;---> NO INTERACTION, NO FILEMAN ECHOING
+63 SET APCDALVR("AUPNTALK")=""
SET APCDALVR("APCDANE")=""
+64 ;
+65 DO ^APCDALV
+66 IF BRATEST
DO DISPLAY1
+67 ;
+68 ; store the ptr in the PCC node of ^RADPT IHS/HQW/JDH
IF '$$STORE(197,$GET(APCDALVR("APCDVSIT")))
GOTO EXIT
+69 ;
+70 ;---> QUIT IF VISIT WAS NOT CREATED.
+71 ;G:'$D(APCDALVR("APCDVSIT")) EXIT ; IHS/HQW/JDH replaced by the call to STORE
+72 IF $DATA(APCDALVR("APCDAFLG"))
GOTO EXIT
+73 ;
+74 ;RETURNS APCDVSIT - PTR TO VISIT JUST SELECTED OR CREATED
+75 ; APCDVSIT("NEW") - IF ^APCDALVR CREATED A NEW VISIT
+76 ; APCDAFLG - =2 IF FAILED TO CREATE VISIT
+77 ;
VRAD ;---> CREATE (ADD) VISIT TO V RADIOLOGY FILE.
+1 ;
+2 ;IHS/ITSC/CLS 01/09/2004
IF $PIECE($GET(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"PCC")),"^",2)
DO UPDTIMP(RADFN,RADTI)
QUIT
+3 ;
+4 ;V RADIOLOGY FILE#=9000010.22
+5 SET DLAYGO=9000010.22
+6 ;
+7 ;---> RADIOLOGY PROCEDURE
+8 SET APCDALVR("APCDTRAD")="`"_$PIECE(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0),U,2)
+9 ;
+10 ;IHS/BJI/DAY - Patch 1003 - Add Encounter Provider to V Rad
+11 SET X=$PIECE(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0),U,15)
+12 IF +X
SET APCDALVR("APCDTEPR")="`"_X
+13 ;End patch
+14 ;
+15 ;---> RADIOLOGY PROCEDURE EVENT DATE/TIME
+16 SET APCDALVR("APCDTCDT")=$PIECE(^RADPT(RADFN,"DT",RADTI,0),U)
+17 ;
+18 ;---> ABNORMAL ; V RAD ^DD SHOULD BE MODIFIED TO TAKE DIAG CODES!
+19 ;---> 4/6/95:
+20 ;---> LORI WILL BE CHANGING THE .05 FIELD OF V RADIOLOGY TO POINT
+21 ;---> THE THE DIAGNOSTIC CODES FILE #78.3 SOMETIME SOON. FOR NOW
+22 ;---> FIELD #.05 IS STILL A SET OF CODES: NORMAL/ABNORMAL.
+23 ;S APCDALVR("APCDTABN")=0
+24 ;
+25 ;---> 3/17/97 WE DECIDED TO LEAVE .05 FIELD AS IS FOR DIRECT DATA
+26 ;---> ENTRY AND ADDED A .06 FIELD FOR DIAGNOSTIC CODE IHS/ISD/EDE
+27 ;S APCDALVR("APCDTDC")="`"_$P(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0),U,13)
+28 IF +$PIECE($GET(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)),U,13)
Begin DoDot:1
+29 SET APCDALVR("APCDTDC")="`"_$PIECE(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0),U,13)
End DoDot:1
+30 ;---> REMOVE THE ; FROM ABOVE LINE WHEN PCC READY TO TAKE DIAGNOSTIC
+31 ;---> CODES ::IHS/ISD/EDE 03/17/97
+32 ;---> ;IHS/ITSC/CLS 01/08/2004 don't send just an "`"
+33 ;
+34 ;---> IMPRESSION
+35 SET APCDALVR("APCDTIMP")="NO IMPRESSION."
+36 ;IHS/PLS 12/26/2001 - $G added
IF $GET(RARPT)
IF $DATA(^RARPT(RARPT,"I"))
Begin DoDot:1
+37 ;IHS/ITSC/CLS 01/08/2004
SET I=$$SETIMP
+38 IF $LENGTH(I)
SET APCDALVR("APCDTIMP")=I
End DoDot:1
+39 ;
+40 ;---> TEMPLATE TO ADD VISIT TO V RADIOLOGY FILE.
+41 SET APCDALVR("APCDATMP")="[APCDALVR 9000010.22 (ADD)]"
+42 DO ^APCDALVR
+43 IF BRATEST
DO DISPLAY2
+44 ;
+45 ; store the pointer in PCC node of ^RADPT IHS/HQW/JDH
IF '$$STORE(196,$GET(APCDALVR("APCDADFN")))
GOTO EXIT
+46 ;
+47 ;G:'$D(APCDALVR("APCDADFN")) EXIT ; IHS/HQW/JDH replaced by the call to STORE
+48 IF $DATA(APCDALVR("APCDAFLG"))
GOTO EXIT
+49 IF BRATEST
DO DISPLAY3
+50 ; replaced by STORE
+51 ;S X=APCDALVR("APCDADFN")_"^"_APCDALVR("APCDVSIT")
+52 ;S $P(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"PCC"),U,2,3)=X
+53 ;D:BRATEST DISPLAY3
+54 ;
EXIT ;
+1 KILL I,N,BRATEST,X
+2 QUIT
+3 ;
CLINIC ;
+1 ; Identify radiology clinic rather than stuff a value
+2 ;IHS/HQW/PMF - 05/30/01 **8**
+3 ;
+4 ;retrieve the clinic number
+5 NEW RACLINIC
+6 ;first get the hospital location pointer from the rad patient file
+7 SET RACLINIC=$PIECE(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0),U,8)
+8 ;if that pointer is not null, get the stop code number from the
+9 ;hospital location file, if it's there.
+10 ;if not there, clinic will be null
+11 IF RACLINIC'=""
SET RACLINIC=$PIECE($GET(^SC(+RACLINIC,0)),U,7)
+12 ;
+13 ;if we got one, set the arrays and stop.
+14 ;
+15 IF RACLINIC
SET (APCDALVR("APCDTCLN"),APCDALVR("APCDCLN"))="`"_RACLINIC
QUIT
+16 ;
+17 ;if that didn't work, and this is NOT a category A, stop
+18 ;
+19 IF APCDALVR("APCDCAT")'="A"
QUIT
+20 ;if we got this far, use the ein of the Radiology clinic stop
+21 SET RACLINIC=$ORDER(^DIC(40.7,"B","RADIOLOGY",""))
+22 IF RACLINIC
SET (APCDALVR("APCDTCLN"),APCDALVR("APCDCLN"))="`"_RACLINIC
+23 QUIT
+24 ;End changes to identify correct clinic -IHS/HWQ/PWF -05/30/01 **8**
+25 ;
STORE(RAFLD,RAVALUE) ;---> STORE VISIT AND V RAD IEN'S IN RADIOLOGY EXAMS FILE #70
+1 NEW RAFDA,RAOK
+2 SET RAOK=1
+3 ; If pointer fields were defined for the PCC node, this kludge would not be needed.
IF 'RAVALUE
SET RAOK=0
+4 IF RAOK
Begin DoDot:1
+5 SET RAFDA($JOB,70.03,""_RACNI_","_RADTI_","_RADFN_",",RAFLD)=RAVALUE
+6 DO FILE^DIE("E","RAFDA($J)","RAFDA($J,""ERR"")")
End DoDot:1
+7 IF $GET(DIERR)!'RAOK
Begin DoDot:1
+8 WRITE !!,*7,"The Radiology to PCC interface has encountered an error. Please call the HQW help desk at 248-4371"
+9 WRITE !!,$GET(RAFDA($JOB,"ERR","DIERR",1,"TEXT",1)),!!
+10 ; trap an error
DO ^%ZTER
SET RAOK=0
End DoDot:1
+11 QUIT RAOK
+12 ;
+13 ;
DELETE ;EP---> DELETE PCC V RAD ENTRY. (REQUIRES RADFN, RADTI, & RACNI)
+1 ;---> CALLED FROM CIAZPRAD (DELETE OR CANCEL AN EXAM). ;IHS/ITSC/CLS 01/08/2004
+2 ;---> QUIT IF NECESSARY RAD VARIABLES ARE NOT PRESENT.
+3 ;IHS/ITSC/CLS 12/31/2003
IF '$DATA(RADFN)
QUIT
IF '$DATA(RADTI)
QUIT
IF '$DATA(RACNI)
QUIT
IF '$DATA(RADTE)
QUIT
+4 IF $DATA(^RADPT(RADFN,"DT",RADTI,"P",+RACNI,"PCC"))
Begin DoDot:1
+5 SET DA=$PIECE(^RADPT(RADFN,"DT",RADTI,"P",+RACNI,"PCC"),U,2)
+6 ;---> QUIT IF POINTER TO VRAD FILE IS NULL.
+7 IF '+DA
QUIT
+8 IF '$DATA(^AUPNVRAD(DA,0))
QUIT
+9 SET APCDVDLT=$PIECE(^AUPNVRAD(DA,0),U,3)
+10 SET DIK="^AUPNVRAD("
DO ^DIK
+11 IF APCDVDLT'=$PIECE(^RADPT(RADFN,"DT",RADTI,"P",+RACNI,"PCC"),U,3)
QUIT
+12 IF '$PIECE(^AUPNVSIT(APCDVDLT,0),U,9)
DO ^APCDVDLT
+13 ;---> SET PCC VISIT POINTERS FOR THIS EXAM = NULL.
+14 SET $PIECE(^RADPT(RADFN,"DT",RADTI,"P",+RACNI,"PCC"),U,2,3)=""
End DoDot:1
+15 QUIT
+16 ;
+17 ;
DISPLAY1 ;---> DISPLAY VISIT IEN.
+1 IF $DATA(APCDALVR("APCDVSIT"))
Begin DoDot:1
+2 WRITE !,"APCDVSIT DEFINED: ",APCDALVR("APCDVSIT")
End DoDot:1
+3 IF $DATA(APCDALVR("APCDVSIT","NEW"))
Begin DoDot:1
+4 WRITE !,"NEW VISIT: ",APCDALVR("APCDVSIT","NEW")
End DoDot:1
+5 ;---> SHOW FLAG IF VISIT WAS NOT CREATED.
+6 IF $DATA(APCDALVR("APCDAFLG"))
Begin DoDot:1
+7 WRITE !,"APCDAFLG DEFINED, FAILED: ",APCDALVR("APCDAFLG")
End DoDot:1
+8 QUIT
DISPLAY2 ;---> DISPLAY V RAD IEN.
+1 IF $DATA(APCDALVR("APCDADFN"))
Begin DoDot:1
+2 WRITE !,"APCDADFN DEFINED: ",APCDALVR("APCDADFN")
End DoDot:1
+3 ;> SHOW FLAG IF VISIT WAS NOT CREATED.
+4 IF $DATA(APCDALVR("APCDAFLG"))
Begin DoDot:1
+5 WRITE !,"APCDAFLG DEFINED, FAILED: ",APCDALVR("APCDAFLG")
End DoDot:1
+6 QUIT
DISPLAY3 ;---> DISPLAY VISIT AND V RAD GLOBAL NODES AND FILE#70 IENS.
+1 WRITE !!,"VISIT FILE: "
+2 SET N=APCDALVR("APCDVSIT")-3
+3 FOR
SET N=$ORDER(^AUPNVSIT(N))
IF 'N
QUIT
Begin DoDot:1
+4 WRITE !,N,": ",^AUPNVSIT(N,0)
End DoDot:1
+5 ;
+6 WRITE !!,"V RAD FILE: "
+7 SET N=APCDALVR("APCDADFN")-3
SET M=N+10
+8 FOR
SET N=$ORDER(^AUPNVRAD(N))
IF 'N
QUIT
IF N>M
QUIT
Begin DoDot:1
+9 WRITE !,N,": ",^AUPNVRAD(N,0)
End DoDot:1
+10 WRITE !,"EXAM IENS: ",RADFN," ",RADTI," ",RACNI
+11 QUIT
+12 ;
UPDTIMP(RADFN,RADTI) ;EP ---> Called from BRAPRAD and VRAD above
+1 ;Updates V RAD file with impression after a visit has been sent to PCC
+2 ;at EXAMINED with "NO IMPRESSION." in V RAD file
+3 ;IHS/HQW/SCR - 07/20/01 **8**
+4 ;
+5 ;IHS/CMI/DAY - We sometimes get calls with RACNE instead of RACN
+6 IF $GET(RACN)=""
IF $GET(RACNE)]""
SET RACN=RACNE
+7 ;
+8 ;IHS/HQW/SCR - 07/20/01 **8**
SET RAXM=0
SET RACNUM=""
+9 ;
+10 ;If the exam has been VERIFIED locate the CaseNumber of the EXam since
+11 ;multiple EXams can be part of the same visit-IHS/HQW/SCR-07/20/01**8**
+12 ;
+13 ;IHS/HQW/SCR - 07/20/01 **8**
FOR
IF RAXM=""
DO Q
SET RAXM=$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RAXM))
SET RACNUM=$PIECE(^(RAXM,0),U)
IF RACNUM=RACN
QUIT
+14 ;
+15 ;Use the RAXM to identify the IEN of the V RAD file for this visit
+16 ;IHS/HQW/SCR - 7/20/01 **8**
+17 ;IHS/HQW/SCR - 07/20/01 **8**
SET PCCVRAD=$PIECE(^RADPT(RADFN,"DT",RADTI,"P",RAXM,"PCC"),U,2)
+18 ;IHS/HQW/SCR - 8/15/01 **8**
IF $GET(PCCVRAD)=""
WRITE !,"NO PCC data available for this exam."
DO CLN
QUIT
+19 ;
+20 ;If report is Unverified (ORDSTS="ZU"), revert back to "NO IMPRESSION."
+21 ;If report has been deleted, report pointer is null.
+22 ;
+23 ;IHS/ITSC/CLS 01/08/2004 if report unverified, reset impression
IF ORDSTS="ZU"
SET I="NO IMPRESSION."
DO CDIE
QUIT
+24 ;
+25 ;If the impression field of the VRAD file holds "NO IMPRESSION.", update the
+26 ;field with the impression that is now stored in the Radiology Reports file.
+27 ; -- IHS/HQW/SCR - 07/20/01 **8**
+28 ;
+29 ;If report is Re-verified (ACTION="ZE"), update impression.
+30 ;
+31 ;I $G(^AUPNVRAD(PCCVRAD,11))="NO IMPRESSION." D ;IHS/HQW/SCR-7/20/01
+32 ;IHS/ITSC/CLS 01/08/2004
IF $GET(^AUPNVRAD(PCCVRAD,11))="NO IMPRESSION."!(ACTION="RE")
Begin DoDot:1
+33 ;IHS/HQW/SCR - 07/20/01 **8**
NEW DIE,DA,DR
+34 ;S DIE="^AUPNVRAD(",DA=PCCVRAD,DR="1101///"_$G(^RARPT(RARPT,"I",1,0)) ;IHS/HQW/SCR - 07/20/01 **8**
+35 ;N RARPT S RARPT=$P(^RADPT(RADFN,"DT",RADTI,"P",RAXM,0),U,17) Q:'$D(^RARPT(RARPT,"I")) ;IHS/ITSC/CLS 07/15/2004
+36 ;IHS/ITSC/CLS 07/15/2004 09/28/2004
IF '$GET(RARPT)
NEW RARPT
SET RARPT=$PIECE(^RADPT(RADFN,"DT",RADTI,"P",RAXM,0),U,17)
IF RARPT=""
GOTO CLN
IF '$DATA(^RARPT(RARPT,"I"))
GOTO CLN
+37 ;IHS/ITSC/CLS 01/08/2004
SET I=$$SETIMP
+38 IF +$PIECE($GET(^RADPT(RADFN,"DT",RADTI,"P",RAXM,0)),U,13)
Begin DoDot:2
+39 ;IHS/ITSC/CLS 01/09/2004 added diagnostic code
SET DC="`"_$PIECE(^RADPT(RADFN,"DT",RADTI,"P",RAXM,0),U,13)
End DoDot:2
+40 DO CDIE
End DoDot:1
+41 QUIT
+42 ;
CDIE ;CALL DIE
+1 ;S DIE="^AUPNVRAD(",DA=PCCVRAD,DR="1101///"_I
+2 ;IHS/ITSC/CLS 01/09/2004
SET DIE="^AUPNVRAD("
SET DA=PCCVRAD
SET DR="1101///"_I_";.06///"_$GET(DC)
+3 ;IHS/HQW/SCR - 07/20/01 **8**
LOCK +^AUPNVRAD(PCCVRAD):0
IF '$TEST
WRITE !,"Can not update IMPRESSION in V RAD file. File being edit by another user."
QUIT
+4 ;IHS/HQW/SCR - 07/20/01 **8**
DO ^DIE
+5 ;IHS/HQW/SCR - 07/20/01 **8**
LOCK -^AUPNVRAD(PCCVRAD)
+6 ;IHS/HQW/SCR - 07/20/01 **8**
WRITE !,"IMPRESSION has been updated in the V RAD file."
+7 ;
+8 ;The following two lines tell the VISIT file when this visit was
+9 ;last modified and is needed whenever PCC is not updated through
+10 ; ^APCDALVR per Lori Butcher - IHS/HQW/SCR - 07/24/01 **8**
+11 ;
+12 SET AUPNVSIT=""
+13 ;IHS/HQW/SCR - 7/24/01 **8**
IF $GET(PCCVRAD)]""
SET AUPNVSIT=$PIECE($GET(^AUPNVRAD(PCCVRAD,0)),U,3)
+14 ;IHS/HQW/SCR - 07/24/01 **8**
IF $GET(AUPNVSIT)]""
DO MOD^AUPNVSIT
+15 ;IHS/HQW/SCR - 07/20/01 **8**
KILL DIE,DA,DR,AUPNVSIT
CLN ;
+1 ;IHS/HQW/SCR - 07/20/01 **8**
KILL DC,I,RAFN,RATI,XM,CN,PCCVRAD
+2 ;IHS/HQW/SCR - 07/20/01 **8**
QUIT
+3 ;
Q ;
+1 KILL RADA,RADFNZ,RADTIZ,RACNIZ
QUIT
+2 ;
SETIMP() ;moved set impression string to function call ;IHS/ITSC/CLS 01/08/2004
+1 SET I=""
SET N=0
FOR
SET N=$ORDER(^RARPT(RARPT,"I",N))
IF 'N
QUIT
Begin DoDot:1
+2 IF $LENGTH(I)+$LENGTH(^RARPT(RARPT,"I",N,0))<220
SET I=I_" "_^(0)
QUIT
+3 SET I=I_"...*MORE* (SEE EXAM)."
SET N=-1
End DoDot:1
+4 ;IHS/BJI/DAY - Patch 1003 - Cleanup needed for Fileman
+5 IF $EXTRACT(I)=" "
SET I=$EXTRACT(I,2,999)
+6 IF $EXTRACT(I)=" "
SET I=$EXTRACT(I,2,999)
+7 IF $EXTRACT(I)=" "
SET I=$EXTRACT(I,2,999)
+8 SET I=$TRANSLATE(I,";",",")
+9 QUIT I
