RAPERR1 ;HIRMFO/GJC,CAH-Prt Img Locs missing/invalid Stop codes ;10/30/96 09:20
;;5.0;Radiology/Nuclear Medicine;**13**;Mar 16, 1998
BSTP(X) ; Check for bad stop codes (DSS ID) per Imaging Location
; Make sure each imaging location points to an entry in the
; Hospital Location file #44 that is a 'COUNT' clinic, with
; no appointment patterns allowed, Stop Code on file 44 entry
; should match DSS ID on Imaging loc, division for imaging loc
; should match the Institution of the file 44 entry
N RAERR,RASTOP,RAY S RAERR="Invalid Stop Code: ",RAY=X_","
D GETS^DIQ(40.7,RAY,".01;1;2","","RASTOP")
S RAERR=RAERR_" ("_RASTOP(40.7,RAY,1)_") "_RASTOP(40.7,RAY,.01)
I $G(RASTOP(40.7,RAY,2))]"" S RAERR=RAERR_" (Inactive)"
Q RAERR
CK700(X) ;Check for a 700-level stop code as a DSS ID
N RAERR,RASTOP,RAY S RAERR="",RAY=X_","
D GETS^DIQ(40.7,RAY,"1","","RASTOP")
I $G(RASTOP(40.7,RAY,1))?1"7"2N D
. S RAERR="700-series noncredit Stop Code being used"
. Q
Q RAERR
ISTOP ; Check the validity of the stop code on the Imaging Locations file.
N RACNT K ^TMP($J,"RAPERR") S (RACNT,RAILOC,RAISTP,RAOUT)=0
F S RAILOC=$O(^RA(79.1,RAILOC)) Q:RAILOC'>0 D
. K RAMSG S RA791(0)=$G(^RA(79.1,RAILOC,0))
. Q:$P(RA791(0),"^",21)=2 ; no credit method for this location
. S X=+$P(RA791(0),"^",22),RA44=+$P(RA791(0),U) ;RA44 = ptr to file 44
. I '$D(^SC(RA44)) D
.. S RAMSG="Broken pointer - Hospital Location file 44 entry missing",RACNT=RACNT+1
.. S ^TMP($J,"RAPERR",RAILOC,RACNT)=RAMSG
.. Q
. S RA44(0)=$G(^SC(RA44,0)) D ;get 0th node of file 44
.. I $P(RA44(0),U,3)'="C" D
... S RAMSG="Hospital Location file 44 entry not CLINIC type",RACNT=RACNT+1
... S ^TMP($J,"RAPERR",RAILOC,RACNT)=RAMSG
... Q
.. I X,($P(RA44(0),U,7)'=X) D
... S RAMSG="Hospital Location Stop Code doesn't match Imaging Loc's DSS ID",RACNT=RACNT+1
... S ^TMP($J,"RAPERR",RAILOC,RACNT)=RAMSG
... Q
.. I $P(RA44(0),U,17)="Y" D
... S RAMSG="Hospital Location is a NON-COUNT clinic",RACNT=RACNT+1
... S ^TMP($J,"RAPERR",RAILOC,RACNT)=RAMSG
... Q
.. I $G(^RA(79.1,RAILOC,"DIV"))="" D
... S RAMSG="No Rad/Nuc Med Division assigned to this imaging location",RACNT=RACNT+1
... S ^TMP($J,"RAPERR",RAILOC,RACNT)=RAMSG
.. E I +$G(^RA(79.1,RAILOC,"DIV"))'=$P(RA44(0),U,4) D
... S RAMSG="Institution on Hosp Loc entry doesn't match Rad/NM Div of Imaging Loc",RACNT=RACNT+1
... S ^TMP($J,"RAPERR",RAILOC,RACNT)=RAMSG
... Q
.. Q
. I 'X D Q
.. S RAMSG="Missing DSS ID",RACNT=RACNT+1
.. S ^TMP($J,"RAPERR",RAILOC,RACNT)=RAMSG
.. Q
. S RAMSG=$$CK700(X) I RAMSG]"" D
.. S RACNT=RACNT+1,^TMP($J,"RAPERR",RAILOC,RACNT)=RAMSG
.. Q
. I '$D(^RAMIS(71.5,"B",+X))!($P(^DIC(40.7,+X,0),U,3)) D
.. S RAMSG=$$BSTP(X),RACNT=RACNT+1,^TMP($J,"RAPERR",RAILOC,RACNT)=RAMSG
.. Q
. Q
I $D(^TMP($J,"RAPERR")) D
. S (RAILOC,RAOUT)=0
. F S RAILOC=$O(^TMP($J,"RAPERR",RAILOC)) Q:RAILOC'>0 D Q:RAOUT
.. I $Y>(IOSL-4) D HDG^RAPERR Q:RAOUT
.. W !!,"Imaging Location: ",$$GET1^DIQ(44,+$P(^RA(79.1,RAILOC,0),"^"),.01) S RACNT=0
.. F S RACNT=$O(^TMP($J,"RAPERR",RAILOC,RACNT)) Q:RACNT'>0 D Q:RAOUT
... I $Y>(IOSL-4) D HDG^RAPERR W:'RAOUT !
... Q:RAOUT W !?3,$G(^TMP($J,"RAPERR",RAILOC,RACNT))
... Q
.. Q
. K ^TMP($J,"RAPERR")
. Q
E D
. I $Y>(IOSL-4) D HDG^RAPERR Q:RAOUT
. W !!,"All Imaging Location crediting data is valid."
. Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRAPERR1 3406 printed Apr 09, 2024@21:40:21 Page 2
RAPERR1 ;HIRMFO/GJC,CAH-Prt Img Locs missing/invalid Stop codes ;10/30/96 09:20
+1 ;;5.0;Radiology/Nuclear Medicine;**13**;Mar 16, 1998
BSTP(X) ; Check for bad stop codes (DSS ID) per Imaging Location
+1 ; Make sure each imaging location points to an entry in the
+2 ; Hospital Location file #44 that is a 'COUNT' clinic, with
+3 ; no appointment patterns allowed, Stop Code on file 44 entry
+4 ; should match DSS ID on Imaging loc, division for imaging loc
+5 ; should match the Institution of the file 44 entry
+6 NEW RAERR,RASTOP,RAY
SET RAERR="Invalid Stop Code: "
SET RAY=X_","
+7 DO GETS^DIQ(40.7,RAY,".01;1;2","","RASTOP")
+8 SET RAERR=RAERR_" ("_RASTOP(40.7,RAY,1)_") "_RASTOP(40.7,RAY,.01)
+9 IF $GET(RASTOP(40.7,RAY,2))]""
SET RAERR=RAERR_" (Inactive)"
+10 QUIT RAERR
CK700(X) ;Check for a 700-level stop code as a DSS ID
+1 NEW RAERR,RASTOP,RAY
SET RAERR=""
SET RAY=X_","
+2 DO GETS^DIQ(40.7,RAY,"1","","RASTOP")
+3 IF $GET(RASTOP(40.7,RAY,1))?1"7"2N
Begin DoDot:1
+4 SET RAERR="700-series noncredit Stop Code being used"
+5 QUIT
End DoDot:1
+6 QUIT RAERR
ISTOP ; Check the validity of the stop code on the Imaging Locations file.
+1 NEW RACNT
KILL ^TMP($JOB,"RAPERR")
SET (RACNT,RAILOC,RAISTP,RAOUT)=0
+2 FOR
SET RAILOC=$ORDER(^RA(79.1,RAILOC))
if RAILOC'>0
QUIT
Begin DoDot:1
+3 KILL RAMSG
SET RA791(0)=$GET(^RA(79.1,RAILOC,0))
+4 ; no credit method for this location
if $PIECE(RA791(0),"^",21)=2
QUIT
+5 ;RA44 = ptr to file 44
SET X=+$PIECE(RA791(0),"^",22)
SET RA44=+$PIECE(RA791(0),U)
+6 IF '$DATA(^SC(RA44))
Begin DoDot:2
+7 SET RAMSG="Broken pointer - Hospital Location file 44 entry missing"
SET RACNT=RACNT+1
+8 SET ^TMP($JOB,"RAPERR",RAILOC,RACNT)=RAMSG
+9 QUIT
End DoDot:2
+10 ;get 0th node of file 44
SET RA44(0)=$GET(^SC(RA44,0))
Begin DoDot:2
+11 IF $PIECE(RA44(0),U,3)'="C"
Begin DoDot:3
+12 SET RAMSG="Hospital Location file 44 entry not CLINIC type"
SET RACNT=RACNT+1
+13 SET ^TMP($JOB,"RAPERR",RAILOC,RACNT)=RAMSG
+14 QUIT
End DoDot:3
+15 IF X
IF ($PIECE(RA44(0),U,7)'=X)
Begin DoDot:3
+16 SET RAMSG="Hospital Location Stop Code doesn't match Imaging Loc's DSS ID"
SET RACNT=RACNT+1
+17 SET ^TMP($JOB,"RAPERR",RAILOC,RACNT)=RAMSG
+18 QUIT
End DoDot:3
+19 IF $PIECE(RA44(0),U,17)="Y"
Begin DoDot:3
+20 SET RAMSG="Hospital Location is a NON-COUNT clinic"
SET RACNT=RACNT+1
+21 SET ^TMP($JOB,"RAPERR",RAILOC,RACNT)=RAMSG
+22 QUIT
End DoDot:3
+23 IF $GET(^RA(79.1,RAILOC,"DIV"))=""
Begin DoDot:3
+24 SET RAMSG="No Rad/Nuc Med Division assigned to this imaging location"
SET RACNT=RACNT+1
+25 SET ^TMP($JOB,"RAPERR",RAILOC,RACNT)=RAMSG
End DoDot:3
+26 IF '$TEST
IF +$GET(^RA(79.1,RAILOC,"DIV"))'=$PIECE(RA44(0),U,4)
Begin DoDot:3
+27 SET RAMSG="Institution on Hosp Loc entry doesn't match Rad/NM Div of Imaging Loc"
SET RACNT=RACNT+1
+28 SET ^TMP($JOB,"RAPERR",RAILOC,RACNT)=RAMSG
+29 QUIT
End DoDot:3
+30 QUIT
End DoDot:2
+31 IF 'X
Begin DoDot:2
+32 SET RAMSG="Missing DSS ID"
SET RACNT=RACNT+1
+33 SET ^TMP($JOB,"RAPERR",RAILOC,RACNT)=RAMSG
+34 QUIT
End DoDot:2
QUIT
+35 SET RAMSG=$$CK700(X)
IF RAMSG]""
Begin DoDot:2
+36 SET RACNT=RACNT+1
SET ^TMP($JOB,"RAPERR",RAILOC,RACNT)=RAMSG
+37 QUIT
End DoDot:2
+38 IF '$DATA(^RAMIS(71.5,"B",+X))!($PIECE(^DIC(40.7,+X,0),U,3))
Begin DoDot:2
+39 SET RAMSG=$$BSTP(X)
SET RACNT=RACNT+1
SET ^TMP($JOB,"RAPERR",RAILOC,RACNT)=RAMSG
+40 QUIT
End DoDot:2
+41 QUIT
End DoDot:1
+42 IF $DATA(^TMP($JOB,"RAPERR"))
Begin DoDot:1
+43 SET (RAILOC,RAOUT)=0
+44 FOR
SET RAILOC=$ORDER(^TMP($JOB,"RAPERR",RAILOC))
if RAILOC'>0
QUIT
Begin DoDot:2
+45 IF $Y>(IOSL-4)
DO HDG^RAPERR
if RAOUT
QUIT
+46 WRITE !!,"Imaging Location: ",$$GET1^DIQ(44,+$PIECE(^RA(79.1,RAILOC,0),"^"),.01)
SET RACNT=0
+47 FOR
SET RACNT=$ORDER(^TMP($JOB,"RAPERR",RAILOC,RACNT))
if RACNT'>0
QUIT
Begin DoDot:3
+48 IF $Y>(IOSL-4)
DO HDG^RAPERR
if 'RAOUT
WRITE !
+49 if RAOUT
QUIT
WRITE !?3,$GET(^TMP($JOB,"RAPERR",RAILOC,RACNT))
+50 QUIT
End DoDot:3
if RAOUT
QUIT
+51 QUIT
End DoDot:2
if RAOUT
QUIT
+52 KILL ^TMP($JOB,"RAPERR")
+53 QUIT
End DoDot:1
+54 IF '$TEST
Begin DoDot:1
+55 IF $Y>(IOSL-4)
DO HDG^RAPERR
if RAOUT
QUIT
+56 WRITE !!,"All Imaging Location crediting data is valid."
+57 QUIT
End DoDot:1
+58 QUIT
