RGRSUTIL ;ALB/RJS-MPI/PD UTILITIES ;03/12/96
;;1.0;CLINICAL INFO RESOURCE NETWORK;**1,3,19,45,57**;30 Apr 99;Build 2
EXCEPT ;Members of the RG CIRN DEMOGRAPHIC ISSUES Mail Group are
;notified upon login if there are unresolved Primary View
;Reject exceptions for review in the MPI/PD Exception
;Handler ;**57 MPIC_1893 Only exception type 234 remains
;
;Is user a member of this mail group?
S RGCDI=$$FIND1^DIC(3.8,,,"RG CIRN DEMOGRAPHIC ISSUES")
I RGCDI="" G END
S XMDUZ=DUZ,Y=RGCDI D CHK^XMA21 I '$T G END
;User is a member.
I $O(^RGHL7(991.1,"ASTAT","0",234,0)) D
.D SET^XUS1A("! <<------------------------------------------------------------------------>>")
.D SET^XUS1A("! << You have Primary View Reject exceptions that need to be reviewed using >>")
.D SET^XUS1A("! << the MPI/PD Exception Handling Option on the Message Exception Menu. >>")
.D SET^XUS1A("! <<------------------------------------------------------------------------>>")
END K RGCDI,XMDUZ,Y
Q
;
SEG(SEGMENT,PIECE,CODE) ;Return segment from RGDC array and kill node
N RGNODE,RGDATA,RGDONE,RGC K RGDONE
I '$D(RGC) S RGC=$E(HL("ECH"))
S RGNODE=0
F S RGNODE=$O(RGDC(RGNODE)) Q:RGNODE=""!($D(RGDONE)) D
.S RGDATA=RGDC(RGNODE)
.I ($P(RGDATA,HL("FS"),1)=SEGMENT)&($P($P(RGDATA,HL("FS"),PIECE),RGC,1)=CODE) S RGDONE=1 K RGDC(RGNODE)
Q:$D(RGDONE) $G(RGDATA)
Q ""
SEG1(SEGMENT,PIECE,CODE) ;Return segment from RGDC array
N RGNODE,RGDATA,RGDONE,RGC K RGDONE
I '$D(RGC) S RGC=$E(HL("ECH"))
S RGNODE=0
F S RGNODE=$O(RGDC(RGNODE)) Q:RGNODE=""!($D(RGDONE)) D
.S RGDATA=RGDC(RGNODE)
.I ($P(RGDATA,HL("FS"),1)=SEGMENT)&($P($P(RGDATA,HL("FS"),PIECE),RGC,1)=CODE) S RGDONE=1
Q:$D(RGDONE) $G(RGDATA)
Q ""
ERROR(CODE) ;**THIS ENTRY POINT IS NO LONGER USED**
Q ""
INITIZE ;Initialize RGDC array with incoming message
N I,J,X
F I=1:1 X HLNEXT Q:HLQUIT'>0 S RGDC(I)=HLNODE,J=0 F S J=$O(HLNODE(J)) Q:'J S RGDC(I,J)=HLNODE(J)
Q
SSNDFN(SSN) ;Input ssn output DFN
N DFN
Q:$G(SSN)="" -1
S DFN=$O(^DPT("SSN",+SSN,0))
Q:$L(DFN) DFN
S DFN=$O(^DPT("SSN",SSN,0))
Q:$L(DFN) DFN
Q -1
;
LINE() ; Return a dashed line.
Q $TR($J("",80)," ","-")
;
PAUSE() ; Pause for CRT output.
; Input: IOST, IOSL
; Output: 0 -- Continue to display output
; 1 -- Quit
Q:$E(IOST,1,2)'["C-" 0
N DIR,DIRUT,DTOUT,DUOUT,RGJ
F RGJ=$Y:1:(IOSL-4) W !
S DIR(0)="E" D ^DIR
Q $D(DIRUT)!($D(DUOUT))
;
DIAG(X) ; Return a string for diagnoses.
; Input: X - Code for type of diagnosis (Primary, etc.)
; Output: Descriptive string, i.e., "Primary", etc.
Q $S($G(X)="":"Unknown",X="A":"Additional",X="P":"Primary",X="S":"Secondary",X="T":"Tertiary",1:"Unknown")
;
ORD(X) ; Return a string for orders.
; Input: X - Code for type of order (Lab, etc.)
; Output: Descriptive string, i.e., "Lab", etc.
Q $S($G(X)="":"Unknown",X="L":"Lab",X="R":"Radiology",1:"Unknown")
;
UPDTFLD(FILE,FLD,ANS1,ANS2) ; Returns the correct field answer
;DLR - Added to prevent the overwriting the last four in ZIP with null
; input: FILE - file number (ex. 2 PATIENT)
; FLD - field number (ex. .1112 ZIP+4)
; ANS1 - existing field value
; ANS2 - incoming value
I (FILE=2)&(FLD=.1112) I $E(ANS1,1,5)=$E(ANS2,1,5),($L(ANS2)=5) Q ANS1
Q ANS2
;
SSNINT(SSN) ;
Q:$G(SSN)="" ""
Q $TRANSLATE(SSN,"-","")
;
ACTION ;Entry action for Primary View Reject exceptions
I $O(^RGHL7(991.1,"ASTAT","0",234,0)) D
.W !!," <<------------------------------------------------------------------------>>"
.W !," << You have Primary View Reject exceptions that need to be reviewed using >>"
.W !," << the MPI/PD Exception Handling Option on the Message Exception Menu. >>"
.W !," <<------------------------------------------------------------------------>>"
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRGRSUTIL 3886 printed Apr 09, 2024@20:47:29 Page 2
RGRSUTIL ;ALB/RJS-MPI/PD UTILITIES ;03/12/96
+1 ;;1.0;CLINICAL INFO RESOURCE NETWORK;**1,3,19,45,57**;30 Apr 99;Build 2
EXCEPT ;Members of the RG CIRN DEMOGRAPHIC ISSUES Mail Group are
+1 ;notified upon login if there are unresolved Primary View
+2 ;Reject exceptions for review in the MPI/PD Exception
+3 ;Handler ;**57 MPIC_1893 Only exception type 234 remains
+4 ;
+5 ;Is user a member of this mail group?
+6 SET RGCDI=$$FIND1^DIC(3.8,,,"RG CIRN DEMOGRAPHIC ISSUES")
+7 IF RGCDI=""
GOTO END
+8 SET XMDUZ=DUZ
SET Y=RGCDI
DO CHK^XMA21
IF '$TEST
GOTO END
+9 ;User is a member.
+10 IF $ORDER(^RGHL7(991.1,"ASTAT","0",234,0))
Begin DoDot:1
+11 DO SET^XUS1A("! <<------------------------------------------------------------------------>>")
+12 DO SET^XUS1A("! << You have Primary View Reject exceptions that need to be reviewed using >>")
+13 DO SET^XUS1A("! << the MPI/PD Exception Handling Option on the Message Exception Menu. >>")
+14 DO SET^XUS1A("! <<------------------------------------------------------------------------>>")
End DoDot:1
END KILL RGCDI,XMDUZ,Y
+1 QUIT
+2 ;
SEG(SEGMENT,PIECE,CODE) ;Return segment from RGDC array and kill node
+1 NEW RGNODE,RGDATA,RGDONE,RGC
KILL RGDONE
+2 IF '$DATA(RGC)
SET RGC=$EXTRACT(HL("ECH"))
+3 SET RGNODE=0
+4 FOR
SET RGNODE=$ORDER(RGDC(RGNODE))
if RGNODE=""!($DATA(RGDONE))
QUIT
Begin DoDot:1
+5 SET RGDATA=RGDC(RGNODE)
+6 IF ($PIECE(RGDATA,HL("FS"),1)=SEGMENT)&($PIECE($PIECE(RGDATA,HL("FS"),PIECE),RGC,1)=CODE)
SET RGDONE=1
KILL RGDC(RGNODE)
End DoDot:1
+7 if $DATA(RGDONE)
QUIT $GET(RGDATA)
+8 QUIT ""
SEG1(SEGMENT,PIECE,CODE) ;Return segment from RGDC array
+1 NEW RGNODE,RGDATA,RGDONE,RGC
KILL RGDONE
+2 IF '$DATA(RGC)
SET RGC=$EXTRACT(HL("ECH"))
+3 SET RGNODE=0
+4 FOR
SET RGNODE=$ORDER(RGDC(RGNODE))
if RGNODE=""!($DATA(RGDONE))
QUIT
Begin DoDot:1
+5 SET RGDATA=RGDC(RGNODE)
+6 IF ($PIECE(RGDATA,HL("FS"),1)=SEGMENT)&($PIECE($PIECE(RGDATA,HL("FS"),PIECE),RGC,1)=CODE)
SET RGDONE=1
End DoDot:1
+7 if $DATA(RGDONE)
QUIT $GET(RGDATA)
+8 QUIT ""
ERROR(CODE) ;**THIS ENTRY POINT IS NO LONGER USED**
+1 QUIT ""
INITIZE ;Initialize RGDC array with incoming message
+1 NEW I,J,X
+2 FOR I=1:1
XECUTE HLNEXT
if HLQUIT'>0
QUIT
SET RGDC(I)=HLNODE
SET J=0
FOR
SET J=$ORDER(HLNODE(J))
if 'J
QUIT
SET RGDC(I,J)=HLNODE(J)
+3 QUIT
SSNDFN(SSN) ;Input ssn output DFN
+1 NEW DFN
+2 if $GET(SSN)=""
QUIT -1
+3 SET DFN=$ORDER(^DPT("SSN",+SSN,0))
+4 if $LENGTH(DFN)
QUIT DFN
+5 SET DFN=$ORDER(^DPT("SSN",SSN,0))
+6 if $LENGTH(DFN)
QUIT DFN
+7 QUIT -1
+8 ;
LINE() ; Return a dashed line.
+1 QUIT $TRANSLATE($JUSTIFY("",80)," ","-")
+2 ;
PAUSE() ; Pause for CRT output.
+1 ; Input: IOST, IOSL
+2 ; Output: 0 -- Continue to display output
+3 ; 1 -- Quit
+4 if $EXTRACT(IOST,1,2)'["C-"
QUIT 0
+5 NEW DIR,DIRUT,DTOUT,DUOUT,RGJ
+6 FOR RGJ=$Y:1:(IOSL-4)
WRITE !
+7 SET DIR(0)="E"
DO ^DIR
+8 QUIT $DATA(DIRUT)!($DATA(DUOUT))
+9 ;
DIAG(X) ; Return a string for diagnoses.
+1 ; Input: X - Code for type of diagnosis (Primary, etc.)
+2 ; Output: Descriptive string, i.e., "Primary", etc.
+3 QUIT $SELECT($GET(X)="":"Unknown",X="A":"Additional",X="P":"Primary",X="S":"Secondary",X="T":"Tertiary",1:"Unknown")
+4 ;
ORD(X) ; Return a string for orders.
+1 ; Input: X - Code for type of order (Lab, etc.)
+2 ; Output: Descriptive string, i.e., "Lab", etc.
+3 QUIT $SELECT($GET(X)="":"Unknown",X="L":"Lab",X="R":"Radiology",1:"Unknown")
+4 ;
UPDTFLD(FILE,FLD,ANS1,ANS2) ; Returns the correct field answer
+1 ;DLR - Added to prevent the overwriting the last four in ZIP with null
+2 ; input: FILE - file number (ex. 2 PATIENT)
+3 ; FLD - field number (ex. .1112 ZIP+4)
+4 ; ANS1 - existing field value
+5 ; ANS2 - incoming value
+6 IF (FILE=2)&(FLD=.1112)
IF $EXTRACT(ANS1,1,5)=$EXTRACT(ANS2,1,5)
IF ($LENGTH(ANS2)=5)
QUIT ANS1
+7 QUIT ANS2
+8 ;
SSNINT(SSN) ;
+1 if $GET(SSN)=""
QUIT ""
+2 QUIT $TRANSLATE(SSN,"-","")
+3 ;
ACTION ;Entry action for Primary View Reject exceptions
+1 IF $ORDER(^RGHL7(991.1,"ASTAT","0",234,0))
Begin DoDot:1
+2 WRITE !!," <<------------------------------------------------------------------------>>"
+3 WRITE !," << You have Primary View Reject exceptions that need to be reviewed using >>"
+4 WRITE !," << the MPI/PD Exception Handling Option on the Message Exception Menu. >>"
+5 WRITE !," <<------------------------------------------------------------------------>>"
End DoDot:1
+6 QUIT
+7 ;
