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

BARPRMK.m

Go to the documentation of this file.
  1. BARPRMK ; IHS/SD/LSL - Remark 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 REMARK CODES
  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:'+BARMKIEN ; No code to lookup
  1. S BARQ("RC")="COMPUTE^BARPRMK" ; Compute routine
  1. S BARQ("RP")="PRINT^BARPRMK" ; 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 BARMKIEN=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,"To obtain a complete hardcopy listing of Remittance Advice Remark Codes,"
  1. I BARV<1.8 W !?7,"please refer to the User Manual Addendum for A/R V1.7 Patch 5."
  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="^BARMKCD("
  1. S DIC(0)="AEMQZ"
  1. S DIC("A")="Remittance Advice Remark Code: "
  1. K DD,DO
  1. D ^DIC
  1. Q:Y<1
  1. S BARMKIEN=+Y
  1. S BARMK=Y(0)
  1. Q
  1. ; ********************************************************************
  1. ; ********************************************************************
  1. ;
  1. COMPUTE ;
  1. ; Required for queueing
  1. Q
  1. ; ********************************************************************
  1. ;
  1. PRINT ;
  1. ; Print data of inquiry
  1. S BAR("HD",0)="Standard Remittance Advice Remark Code Inquiry"
  1. S BAR("PG")=BAR("PG")+1
  1. S BAR("LVL")=1
  1. D WHD^BARRHD ; Report header
  1. W !!?6,$$EN^BARVDF("ULN"),"CODE:",$$EN^BARVDF("ULF")
  1. W ?15,$P(BARMK,U)
  1. W !!,$$EN^BARVDF("ULN"),"SHORT DESC:",$$EN^BARVDF("ULF")
  1. W ?15,$E($P(BARMK,U,2),1,63)
  1. I $L($P(BARMK,U,2))>63 W !?15,$E($P(BARMK,U,2),64,80)
  1. W !!,$$EN^BARVDF("ULN")," LONG DESC:",$$EN^BARVDF("ULF")
  1. W !
  1. ;
  1. F BARLOOP=1:1 Q:$G(^BARMKCD(BARMKIEN,1,BARLOOP,0))="" D Q:+BAR("F1")
  1. . W !?5,^BARMKCD(BARMKIEN,1,BARLOOP,0)
  1. . I $Y>(IOSL-5) D Q:$G(BAR("F1"))
  1. . . D PAZ^BARRUTL
  1. . . I $D(DTOUT)!$D(DUOUT)!$D(DIROUT) S BAR("F1")=1 Q
  1. . . S BAR("PG")=BAR("PG")+1
  1. . . D WHD^BARRHD ; Report header
  1. Q