Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BRAPCC

BRAPCC.m

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