BARPRMK.m

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