PSOREJP7 ;AITC/PD - Third Party Reject Display Screen Cont;03/06/25
;;7.0;OUTPATIENT PHARMACY;**766**;DEC 1997;Build 25
;
Q
;
DIA ; Protocol Action to allow user the ability to include a
; Diagnosis Code on the claim
;
N DIAG,PSOET
;
I $$CLOSED^PSOREJP1(RX,REJ,1) Q
;
S PSOET=$$PSOET^PSOREJP3(RX,FILL)
I PSOET D Q
. S VALMSG="DIA not allowed for "_$$ELIGDISP^PSOREJP1(RX,FILL)_" Non-Billable claim."
. S VALMBCK="R"
;
D FULL^VALM1
;
S DIAG=$$DIAG
I DIAG="^" S VALMBCK="R" Q
;
D SEND^PSOREJP3(,,,PSOET,DIAG)
;
Q
;
DIAG() ; Ask for Diagnosis Code
;
N DFLTDX,DIAG,DIR,DIRUT,DTOUT,DUOUT,PSOCLAIM,PSOIEN59,X,Y
;
S PSOIEN59=$$CLAIM^BPSBUTL(RX,FILL) ; ICR# 4719
S PSOCLAIM=$P(PSOIEN59,U,2)
S PSOIEN59=$P(PSOIEN59,U,1)
;
; Diagnosis Code, 424-DO
; Default Diagnosis Code from BPS CLAIMS file, field 424
; Only ICD-10-CM codes are allowed for selection
;
DIAG1 ;
S DIAG=""
S DIR(0)="PO^80:AEQMZ"
S DFLTDX=$P($E($$GET1^DIQ(9002313.0201,1_","_PSOCLAIM_",",424),3,17)," ")
I $G(DFLTDX)'="" S DFLTDX=$E(DFLTDX,1,3)_"."_$E(DFLTDX,4,10)
S DIR("B")=DFLTDX
S DIR("S")="I $P($G(^ICDS($P(^(1),""^"",1),0)),""^"",1)=""ICD-10-CM"""
D ^DIR
I ($D(DUOUT))!($D(DTOUT)) K DIR,X,Y Q "^"
; If no value entered, or @ was entered with no default value, prompt
; user to enter ^ to exit and return them to the Dx prompt
I X=""!((X="@")&(DFLTDX="")) W " ??",!," Enter '^' to exit" G DIAG1
S DIAG=$P(Y,U,2)
I $D(DIRUT),X="@" D I $D(DIRUT) K DIR,X,Y Q "^"
. K DIR,DIRUT,X,Y
. S DIR(0)="Y^E"
. S DIR("A")=" Are you sure you want to delete "_DFLTDX
. S DIR("B")="No"
. S DIAG=DFLTDX
. D ^DIR
. I Y S DIAG="REMOVED"
K DIR,X,Y
;
Q DIAG
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOREJP7 1726 printed Sep 23, 2025@20:10:03 Page 2
PSOREJP7 ;AITC/PD - Third Party Reject Display Screen Cont;03/06/25
+1 ;;7.0;OUTPATIENT PHARMACY;**766**;DEC 1997;Build 25
+2 ;
+3 QUIT
+4 ;
DIA ; Protocol Action to allow user the ability to include a
+1 ; Diagnosis Code on the claim
+2 ;
+3 NEW DIAG,PSOET
+4 ;
+5 IF $$CLOSED^PSOREJP1(RX,REJ,1)
QUIT
+6 ;
+7 SET PSOET=$$PSOET^PSOREJP3(RX,FILL)
+8 IF PSOET
Begin DoDot:1
+9 SET VALMSG="DIA not allowed for "_$$ELIGDISP^PSOREJP1(RX,FILL)_" Non-Billable claim."
+10 SET VALMBCK="R"
End DoDot:1
QUIT
+11 ;
+12 DO FULL^VALM1
+13 ;
+14 SET DIAG=$$DIAG
+15 IF DIAG="^"
SET VALMBCK="R"
QUIT
+16 ;
+17 DO SEND^PSOREJP3(,,,PSOET,DIAG)
+18 ;
+19 QUIT
+20 ;
DIAG() ; Ask for Diagnosis Code
+1 ;
+2 NEW DFLTDX,DIAG,DIR,DIRUT,DTOUT,DUOUT,PSOCLAIM,PSOIEN59,X,Y
+3 ;
+4 ; ICR# 4719
SET PSOIEN59=$$CLAIM^BPSBUTL(RX,FILL)
+5 SET PSOCLAIM=$PIECE(PSOIEN59,U,2)
+6 SET PSOIEN59=$PIECE(PSOIEN59,U,1)
+7 ;
+8 ; Diagnosis Code, 424-DO
+9 ; Default Diagnosis Code from BPS CLAIMS file, field 424
+10 ; Only ICD-10-CM codes are allowed for selection
+11 ;
DIAG1 ;
+1 SET DIAG=""
+2 SET DIR(0)="PO^80:AEQMZ"
+3 SET DFLTDX=$PIECE($EXTRACT($$GET1^DIQ(9002313.0201,1_","_PSOCLAIM_",",424),3,17)," ")
+4 IF $GET(DFLTDX)'=""
SET DFLTDX=$EXTRACT(DFLTDX,1,3)_"."_$EXTRACT(DFLTDX,4,10)
+5 SET DIR("B")=DFLTDX
+6 SET DIR("S")="I $P($G(^ICDS($P(^(1),""^"",1),0)),""^"",1)=""ICD-10-CM"""
+7 DO ^DIR
+8 IF ($DATA(DUOUT))!($DATA(DTOUT))
KILL DIR,X,Y
QUIT "^"
+9 ; If no value entered, or @ was entered with no default value, prompt
+10 ; user to enter ^ to exit and return them to the Dx prompt
+11 IF X=""!((X="@")&(DFLTDX=""))
WRITE " ??",!," Enter '^' to exit"
GOTO DIAG1
+12 SET DIAG=$PIECE(Y,U,2)
+13 IF $DATA(DIRUT)
IF X="@"
Begin DoDot:1
+14 KILL DIR,DIRUT,X,Y
+15 SET DIR(0)="Y^E"
+16 SET DIR("A")=" Are you sure you want to delete "_DFLTDX
+17 SET DIR("B")="No"
+18 SET DIAG=DFLTDX
+19 DO ^DIR
+20 IF Y
SET DIAG="REMOVED"
End DoDot:1
IF $DATA(DIRUT)
KILL DIR,X,Y
QUIT "^"
+21 KILL DIR,X,Y
+22 ;
+23 QUIT DIAG
