- BARPRMK ; IHS/SD/LSL - Remark 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 REMARK CODES
- ;
- Q
- ; ********************************************************************
- ;
- EN ; EP
- D INIT ; Initialize environment
- D MSG ; Note entire list user manual
- D LOOKUP ; Ask user code to lookup
- Q:'+BARMKIEN ; No code to lookup
- S BARQ("RC")="COMPUTE^BARPRMK" ; Compute routine
- S BARQ("RP")="PRINT^BARPRMK" ; 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 BARMKIEN=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,"To obtain a complete hardcopy listing of Remittance Advice Remark Codes,"
- I BARV<1.8 W !?7,"please refer to the User Manual Addendum for A/R V1.7 Patch 5."
- 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="^BARMKCD("
- S DIC(0)="AEMQZ"
- S DIC("A")="Remittance Advice Remark Code: "
- K DD,DO
- D ^DIC
- Q:Y<1
- S BARMKIEN=+Y
- S BARMK=Y(0)
- Q
- ; ********************************************************************
- ; ********************************************************************
- ;
- COMPUTE ;
- ; Required for queueing
- Q
- ; ********************************************************************
- ;
- PRINT ;
- ; Print data of inquiry
- S BAR("HD",0)="Standard Remittance Advice Remark Code Inquiry"
- S BAR("PG")=BAR("PG")+1
- S BAR("LVL")=1
- D WHD^BARRHD ; Report header
- W !!?6,$$EN^BARVDF("ULN"),"CODE:",$$EN^BARVDF("ULF")
- W ?15,$P(BARMK,U)
- W !!,$$EN^BARVDF("ULN"),"SHORT DESC:",$$EN^BARVDF("ULF")
- W ?15,$E($P(BARMK,U,2),1,63)
- I $L($P(BARMK,U,2))>63 W !?15,$E($P(BARMK,U,2),64,80)
- W !!,$$EN^BARVDF("ULN")," LONG DESC:",$$EN^BARVDF("ULF")
- W !
- ;
- F BARLOOP=1:1 Q:$G(^BARMKCD(BARMKIEN,1,BARLOOP,0))="" D Q:+BAR("F1")
- . W !?5,^BARMKCD(BARMKIEN,1,BARLOOP,0)
- . I $Y>(IOSL-5) D Q:$G(BAR("F1"))
- . . D PAZ^BARRUTL
- . . I $D(DTOUT)!$D(DUOUT)!$D(DIROUT) S BAR("F1")=1 Q
- . . S BAR("PG")=BAR("PG")+1
- . . D WHD^BARRHD ; Report header
- Q
- BARPRMK ; IHS/SD/LSL - Remark 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 REMARK CODES
- +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 '+BARMKIEN
- QUIT
- +5 ; Compute routine
- SET BARQ("RC")="COMPUTE^BARPRMK"
- +6 ; Print routine
- SET BARQ("RP")="PRINT^BARPRMK"
- +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 BARMKIEN=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,"To obtain a complete hardcopy listing of Remittance Advice Remark Codes,"
- +6 IF BARV<1.8
- WRITE !?7,"please refer to the User Manual Addendum for A/R V1.7 Patch 5."
- +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="^BARMKCD("
- +4 SET DIC(0)="AEMQZ"
- +5 SET DIC("A")="Remittance Advice Remark Code: "
- +6 KILL DD,DO
- +7 DO ^DIC
- +8 IF Y<1
- QUIT
- +9 SET BARMKIEN=+Y
- +10 SET BARMK=Y(0)
- +11 QUIT
- +12 ; ********************************************************************
- +13 ; ********************************************************************
- +14 ;
- COMPUTE ;
- +1 ; Required for queueing
- +2 QUIT
- +3 ; ********************************************************************
- +4 ;
- PRINT ;
- +1 ; Print data of inquiry
- +2 SET BAR("HD",0)="Standard Remittance Advice Remark Code Inquiry"
- +3 SET BAR("PG")=BAR("PG")+1
- +4 SET BAR("LVL")=1
- +5 ; Report header
- DO WHD^BARRHD
- +6 WRITE !!?6,$$EN^BARVDF("ULN"),"CODE:",$$EN^BARVDF("ULF")
- +7 WRITE ?15,$PIECE(BARMK,U)
- +8 WRITE !!,$$EN^BARVDF("ULN"),"SHORT DESC:",$$EN^BARVDF("ULF")
- +9 WRITE ?15,$EXTRACT($PIECE(BARMK,U,2),1,63)
- +10 IF $LENGTH($PIECE(BARMK,U,2))>63
- WRITE !?15,$EXTRACT($PIECE(BARMK,U,2),64,80)
- +11 WRITE !!,$$EN^BARVDF("ULN")," LONG DESC:",$$EN^BARVDF("ULF")
- +12 WRITE !
- +13 ;
- +14 FOR BARLOOP=1:1
- IF $GET(^BARMKCD(BARMKIEN,1,BARLOOP,0))=""
- QUIT
- Begin DoDot:1
- +15 WRITE !?5,^BARMKCD(BARMKIEN,1,BARLOOP,0)
- +16 IF $Y>(IOSL-5)
- Begin DoDot:2
- +17 DO PAZ^BARRUTL
- +18 IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)
- SET BAR("F1")=1
- QUIT
- +19 SET BAR("PG")=BAR("PG")+1
- +20 ; Report header
- DO WHD^BARRHD
- End DoDot:2
- IF $GET(BAR("F1"))
- QUIT
- End DoDot:1
- IF +BAR("F1")
- QUIT
- +21 QUIT