- 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 Feb 19, 2025@00:04:49 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
