Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BARPADJ

BARPADJ.m

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