BARPADJ ; IHS/SD/LSL - Standard Adjustment Reason Codes Inquiry ;
;;1.8;IHS ACCOUNTS RECEIVABLE;;OCT 26, 2005
;
; IHS/SD/LSL - 02/13/04 - V1.7 Patch 5
; Routine created. Inquiry to A/R EDI STND CLAIM ADJ REASONS
;
Q
; ********************************************************************
;
EN ; EP
D INIT ; Initialize environment
D MSG ; Note entire list user manual
D LOOKUP ; Ask user code to lookup
Q:'+BARAJIEN ; No code to lookup
S BARQ("RC")="COMPUTE^BARPADJ" ; Compute routine
S BARQ("RP")="PRINT^BARPADJ" ; Print routine
S BARQ("NS")="BAR" ; Namespace for variables
S BARQ("RX")="POUT^BARRUTL" ; Clean-up routine
D ^BARDBQUE ; Double queuing
D PAZ^BARRUTL
Q
; ********************************************************************
;
INIT ;
I '$D(BARUSR) D INIT^BARUTL
S BARAJIEN=0
S BAR("PG")=0
S BAR("F1")=0
Q
; ********************************************************************
;
MSG ;
; Display message informing user that a complete listing of codes may be
; found in the user manual.
S BARV=$$VERSION^XPDUTL("BAR")
W !!,$$EN^BARVDF("RVN"),"NOTE:",$$EN^BARVDF("RVF")
W ?7,"For a complete hardcopy listing of Standard Adjustment Reason Codes,"
I BARV<1.8 W !?7,"please refer to the User Manual Addendum for A/R V1.7 Patch 4."
E W !?7,"please refer to the User Manual."
W !!
Q
; ********************************************************************
;
LOOKUP ;
; Ask for code user wants to see
K DIC,DR,DA,X,Y
S DIC="^BARADJ("
S DIC(0)="AEMQZ"
S DIC("A")="Standard Adjustment Reason Code: "
K DD,DO
D ^DIC
Q:Y<1
S BARAJIEN=+Y
S BARADJ=Y(0)
Q
; ********************************************************************
; ********************************************************************
;
COMPUTE ;
S BARDESC=$$GET1^DIQ(90056.06,BARAJIEN,101)
D WP^BARDUTL($P(BARADJ,U,2),"BARSD",40)
D WP^BARDUTL(BARDESC,"BARLD",70)
; Required for queueing
Q
; ********************************************************************
;
PRINT ;
; Print data of inquiry
S BAR("HD",0)="Standard Adjustment Reason Code Inquiry"
S BAR("PG")=BAR("PG")+1
S BAR("LVL")=1
D WHD^BARRHD ; Report header
;
W !!,$$EN^BARVDF("ULN"),"STANDARD",$$EN^BARVDF("ULF")
W ?30,$$EN^BARVDF("ULN"),"SHORT",$$EN^BARVDF("ULF")
I $O(BARSD($J,""),-1)>1 D
. W ?36,BARSD($J,1)
. K BARSD($J,1)
W !?4,$$EN^BARVDF("ULN"),"CODE:",$$EN^BARVDF("ULF")
W ?10,$P(BARADJ,U)
W ?30,$$EN^BARVDF("ULN"),"DESC:",$$EN^BARVDF("ULF")
S I=0
F S I=$O(BARSD($J,I)) Q:'+I D
. W ?36,BARSD($J,I),!
;
W !!?4,$$EN^BARVDF("ULN"),"RPMS",$$EN^BARVDF("ULF")
W ?10,$P(BARADJ,U,3)
W ?30,$$EN^BARVDF("ULN"),"RPMS",$$EN^BARVDF("ULF")
W ?38,$P(BARADJ,U,4)
W !,$$EN^BARVDF("ULN"),"CATEGORY:",$$EN^BARVDF("ULF")
W ?10,$$GET1^DIQ(90052.01,$P(BARADJ,U,3),.01)
W ?30,$$EN^BARVDF("ULN"),"REASON:",$$EN^BARVDF("ULF")
W ?38,$$GET1^DIQ(90052.02,$P(BARADJ,U,4),.01)
;
W !!!,$$EN^BARVDF("ULN"),"FULL STANDARD CODE DESCRIPTION:",$$EN^BARVDF("ULF"),!
S I=0
F S I=$O(BARLD($J,I)) Q:'+I D
. W !?5,BARLD($J,I)
Q
BARPADJ ; IHS/SD/LSL - Standard Adjustment Reason Codes Inquiry ;
+1 ;;1.8;IHS ACCOUNTS RECEIVABLE;;OCT 26, 2005
+2 ;
+3 ; IHS/SD/LSL - 02/13/04 - V1.7 Patch 5
+4 ; Routine created. Inquiry to A/R EDI STND CLAIM ADJ REASONS
+5 ;
+6 QUIT
+7 ; ********************************************************************
+8 ;
EN ; EP
+1 ; Initialize environment
DO INIT
+2 ; Note entire list user manual
DO MSG
+3 ; Ask user code to lookup
DO LOOKUP
+4 ; No code to lookup
IF '+BARAJIEN
QUIT
+5 ; Compute routine
SET BARQ("RC")="COMPUTE^BARPADJ"
+6 ; Print routine
SET BARQ("RP")="PRINT^BARPADJ"
+7 ; Namespace for variables
SET BARQ("NS")="BAR"
+8 ; Clean-up routine
SET BARQ("RX")="POUT^BARRUTL"
+9 ; Double queuing
DO ^BARDBQUE
+10 DO PAZ^BARRUTL
+11 QUIT
+12 ; ********************************************************************
+13 ;
INIT ;
+1 IF '$DATA(BARUSR)
DO INIT^BARUTL
+2 SET BARAJIEN=0
+3 SET BAR("PG")=0
+4 SET BAR("F1")=0
+5 QUIT
+6 ; ********************************************************************
+7 ;
MSG ;
+1 ; Display message informing user that a complete listing of codes may be
+2 ; found in the user manual.
+3 SET BARV=$$VERSION^XPDUTL("BAR")
+4 WRITE !!,$$EN^BARVDF("RVN"),"NOTE:",$$EN^BARVDF("RVF")
+5 WRITE ?7,"For a complete hardcopy listing of Standard Adjustment Reason Codes,"
+6 IF BARV<1.8
WRITE !?7,"please refer to the User Manual Addendum for A/R V1.7 Patch 4."
+7 IF '$TEST
WRITE !?7,"please refer to the User Manual."
+8 WRITE !!
+9 QUIT
+10 ; ********************************************************************
+11 ;
LOOKUP ;
+1 ; Ask for code user wants to see
+2 KILL DIC,DR,DA,X,Y
+3 SET DIC="^BARADJ("
+4 SET DIC(0)="AEMQZ"
+5 SET DIC("A")="Standard Adjustment Reason Code: "
+6 KILL DD,DO
+7 DO ^DIC
+8 IF Y<1
QUIT
+9 SET BARAJIEN=+Y
+10 SET BARADJ=Y(0)
+11 QUIT
+12 ; ********************************************************************
+13 ; ********************************************************************
+14 ;
COMPUTE ;
+1 SET BARDESC=$$GET1^DIQ(90056.06,BARAJIEN,101)
+2 DO WP^BARDUTL($PIECE(BARADJ,U,2),"BARSD",40)
+3 DO WP^BARDUTL(BARDESC,"BARLD",70)
+4 ; Required for queueing
+5 QUIT
+6 ; ********************************************************************
+7 ;
PRINT ;
+1 ; Print data of inquiry
+2 SET BAR("HD",0)="Standard Adjustment Reason Code Inquiry"
+3 SET BAR("PG")=BAR("PG")+1
+4 SET BAR("LVL")=1
+5 ; Report header
DO WHD^BARRHD
+6 ;
+7 WRITE !!,$$EN^BARVDF("ULN"),"STANDARD",$$EN^BARVDF("ULF")
+8 WRITE ?30,$$EN^BARVDF("ULN"),"SHORT",$$EN^BARVDF("ULF")
+9 IF $ORDER(BARSD($JOB,""),-1)>1
Begin DoDot:1
+10 WRITE ?36,BARSD($JOB,1)
+11 KILL BARSD($JOB,1)
End DoDot:1
+12 WRITE !?4,$$EN^BARVDF("ULN"),"CODE:",$$EN^BARVDF("ULF")
+13 WRITE ?10,$PIECE(BARADJ,U)
+14 WRITE ?30,$$EN^BARVDF("ULN"),"DESC:",$$EN^BARVDF("ULF")
+15 SET I=0
+16 FOR
SET I=$ORDER(BARSD($JOB,I))
IF '+I
QUIT
Begin DoDot:1
+17 WRITE ?36,BARSD($JOB,I),!
End DoDot:1
+18 ;
+19 WRITE !!?4,$$EN^BARVDF("ULN"),"RPMS",$$EN^BARVDF("ULF")
+20 WRITE ?10,$PIECE(BARADJ,U,3)
+21 WRITE ?30,$$EN^BARVDF("ULN"),"RPMS",$$EN^BARVDF("ULF")
+22 WRITE ?38,$PIECE(BARADJ,U,4)
+23 WRITE !,$$EN^BARVDF("ULN"),"CATEGORY:",$$EN^BARVDF("ULF")
+24 WRITE ?10,$$GET1^DIQ(90052.01,$PIECE(BARADJ,U,3),.01)
+25 WRITE ?30,$$EN^BARVDF("ULN"),"REASON:",$$EN^BARVDF("ULF")
+26 WRITE ?38,$$GET1^DIQ(90052.02,$PIECE(BARADJ,U,4),.01)
+27 ;
+28 WRITE !!!,$$EN^BARVDF("ULN"),"FULL STANDARD CODE DESCRIPTION:",$$EN^BARVDF("ULF"),!
+29 SET I=0
+30 FOR
SET I=$ORDER(BARLD($JOB,I))
IF '+I
QUIT
Begin DoDot:1
+31 WRITE !?5,BARLD($JOB,I)
End DoDot:1
+32 QUIT
