Routine: RCTOP2

RCTOP2 ;WASH IRMFO@ALTOONA,PA/TJK-TOP TRANSMISSION ;2/11/00  3:25 PM

V ;;4.5;Accounts Receivable;**141,169,333**;Mar 20, 1995;Build 7

 ;;Per VA Directive 6402, this routine should not be modified

EN1(DEBTOR,CODE,FILE) ;entry point to compile type 2 documents into global

 ;called from RCTOPD

 ;needs debtor internal number and code:"M" or "U"

 ;PRC*4.5*333 Modify routine to handle foreign addressing

 ;            correctly for transmitting to Treasury.

 I $P($G(^RCD(340,DEBTOR,1)),U,9)=1 G QUIT

 N DEBTOR5,ADDR,LENGTH,DEBNR

 ;get debtor ar address, compare to top address for 'update' documents

 S DEBTOR5=$G(^RCD(340,DEBTOR,5))

 S ADDR=$$DADD(DEBTOR),ADDR=$P(ADDR,U,1,2)_U_$P(ADDR,U,4,8)

 I +$P(ADDR,U,7)'<2 S $P(ADDR,U,4)="",$P(ADDR,U,5)=""

 S $P(ADDR,U,7)=$$COUNTRY($P(ADDR,U,7))

 I CODE="U",ADDR=DEBTOR5 G QUIT

 ;set record in temporary global

 S REC="04      "_$P(^RC(342,1,3),U,5)_"      "

 S DEBNR=$E(SITE,1,3)_$S(FILE=2:0,FILE=440:"V",1:"E")_$TR($J(DEBTOR,14)," ",0),REC=REC_DEBNR

 S REC=REC_$S(CODE="M":"A",1:"U")_2

 F I=1:1:5,7 D

 . S ADDR(I)=$P(ADDR,U,I),LENGTH=$S(I<3:30,I=3:25,I=4:2,I=7:3,1:9)

 . S:I=5 ADDR(5)=$P(ADDR(5),"-")_$P(ADDR(5),"-",2)

 . S REC=REC_$$LJ^XLFSTR($E(ADDR(I),1,LENGTH),LENGTH)

 S REC=REC_$$BLANK^RCTOP1(68)

 S CNTR(2)=CNTR(2)+1,^XTMP("RCTOPD",$J,2,CNTR(2))=REC

 ;set TOP address in ar debtor file

 S ^RCD(340,DEBTOR,5)=ADDR

QUIT Q

DADD(RCDB,RCCONF) ;

N X

 S X="" G:$G(RCDB)="" Q

 I RCDB?1N.N S RCDB=$P($G(^RCD(340,RCDB,0)),"^")

 ; the confidential address has greatest priority for mailing

 I $G(RCCONF),RCDB["DPT(" S X=$$PAT^RCAMADD(+RCDB,1) I X'="" G Q

 ; the AR DEBTOR address (if exists) has a greater priority the permanent address in PATIENT file.

 I RCDB["DPT(" S X=$$ARDEB(+$O(^RCD(340,"B",RCDB,0))) S:$P(X,U)]"" $P(X,U,8)=$P(^DPT(+RCDB,.11),U,10) I ($P(X,U)'=""),($P(X,U,4)'=""),($P(X,U,5)'=""),(($P(X,U,6)'="")!($P(X,U,8)'="")) G Q

 I RCDB["DPT(" S X=$$PAT(+RCDB,0) G Q

 I RCDB["DIC(4" S X=$$INST^RCAMADD(+RCDB) G Q

 I RCDB["PRC(440," S X=$$VEN^RCAMADD(+RCDB) G Q

 I RCDB["DIC(36," S X=$$INSUR^RCAMADD(+RCDB) G Q

 I RCDB["VA(200," S X=$$PER^RCAMADD(+RCDB)

Q Q X

ARDEB(RCDB) ;Get address from AR Debtor file (340)

 NEW X,Y

 S X="" G:'$D(^RCD(340,+$G(RCDB),0)) Q6 S X=$P($G(^RCD(340,RCDB,1)),U,1,8)

 S:$P(X,U,5) $P(X,U,5)=$P($G(^DIC(5,+$P(X,U,5),0)),U,2)

Q6 Q X

PAT(RCDB,RCCONF) ;Get patient address as "Str1^Str2^Str3^City^State^ZIP^Telephone" from ^DPT

 ; if RCCONF=0 (default), then return patients permanent address

 ; if RCCONF=1, then return confidential address, or NULL

 N DFN,RCX,RCY,II,RCTRY

 I '$D(^DPT(+$G(RCDB),0)) S RCX="" G Q3

 S DFN=RCDB S RCY=$G(^DPT(DFN,.11)) I RCY="" S RCX="" G Q3

 S RCX=""

 I $P(RCY,U,10)<2 D  G Q3

 . S RCX=$P(RCY,U,1,6)

 . S:$P(RCX,U,5) $P(RCX,U,5)=$P($G(^DIC(5,+$P(RCX,U,5),0)),U,2)

 . I $D(^DPT(DFN,.13)) S $P(RCX,U,7)=$P(^DPT(DFN,.13),U)

 . S $P(RCX,U,8)="",$P(RCX,U,9)=$S($P(RCY,U,16):1,1:0)

 S RCX=$P(RCY,U,1,3),$P(RCX,U,4)=$E($P(RCY,U,4)_" "_$E($P(RCY,U,8),1,2)_" "_$P(RCY,U,9),1,25)

 S $P(RCX,U,8)=$P(RCY,U,10)

 I $D(^DPT(DFN,.13)) S $P(RCX,U,7)=$P(^DPT(DFN,.13),U)

 S $P(RCX,U,9)=$S($P(RCY,U,16):1,1:0)

Q3 Q RCX

COUNTRY(Z) ;

 N PRCACC

 ;get TOP country code

 I +Z<2 S PRCACC="US" G COUNTRYQ

 S PRCACC=$S(Z=4:"AF",Z=5:"AL",Z=7:"DZ",Z=8:"AD",Z=9:"AO",Z=180:"AI",Z=10:"AG",Z=12:"AR",Z=18:"AM",Z=151:"AW",Z=13:"AU",Z=14:"AT",Z=11:"AZ",Z=15:"BS",Z=16:"BH",Z=17:"BD",1:"  ") G:PRCACC'="  " COUNTRYQ

 S PRCACC=$S(Z=19:"BB",Z=36:"BY",Z=20:"BE",Z=28:"BZ",Z=61:"BJ",Z=21:"BM",Z=22:"BT",Z=23:"BO",Z=24:"BA",Z=25:"BW",Z=27:"BR",Z=29:"IO",Z=32:"BN",Z=33:"BG",Z=223:"Faso",Z=35:"BI",1:"  ") G:PRCACC'="  " COUNTRYQ

 S PRCACC=$S(Z=37:"KH",Z=38:"CM",Z=39:"CA",Z=40:"CV",Z=41:"KY",Z=42:"CF",Z=44:"TD",Z=45:"CL",Z=46:"CN",Z=50:"CO",Z=51:"KM",Z=53:"CG",Z=54:"CD",Z=55:"CK",Z=56:"CR",Z=109:"CI",1:"  ") G:PRCACC'="  " COUNTRYQ

 S PRCACC=$S(Z=57:"HR",Z=58:"CU",Z=59:"CY",Z=60:"CZ",Z=115:"KP",Z=62:"DK",Z=80:"DJ",Z=63:"DM",Z=64:"DO",Z=172:"TP",Z=65:"EC",Z=220:"EG",Z=66:"SV",Z=67:"GQ",Z=69:"ER",Z=70:"EE",1:"  ") G:PRCACC'="  " COUNTRYQ

 S PRCACC=$S(Z=68:"ET",Z=72:"FK",Z=71:"FO",Z=74:"FJ",Z=75:"FI",Z=76:"FR",Z=77:"GF",Z=78:"PF",Z=79:"TF",Z=81:"GA",Z=83:"GM",Z=82:"GE",Z=84:"DE",Z=85:"GH",Z=86:"GI",Z=221:"GB",1:"  ") G:PRCACC'="  " COUNTRYQ

 S PRCACC=$S(Z=88:"GR",Z=89:"GL",Z=90:"GD",Z=91:"GP",Z=92:"GT",Z=93:"GN",Z=171:"GW",Z=94:"GY",Z=95:"HT",Z=98:"HN",Z=99:"HK",Z=100:"HU",Z=101:"IS",Z=102:"IN",Z=103:"ID",1:"  ") G:PRCACC'="  " COUNTRYQ

 S PRCACC=$S(Z=105:"IQ",Z=106:"IE",Z=107:"IL",Z=108:"IT",Z=110:"JM",Z=111:"JP",Z=113:"JO",Z=112:"KZ",Z=114:"KE",Z=87:"KI",Z=116:"KR",Z=117:"KW",Z=118:"KG",Z=119:"LA",Z=122:"LV",1:"  ") G:PRCACC'="  " COUNTRYQ

 S PRCACC=$S(Z=120:"LB",Z=121:"LS",Z=123:"LR",Z=124:"LY",Z=125:"LI",Z=126:"LT",Z=127:"LU",Z=128:"MO",Z=129:"MG",Z=130:"MW",Z=131:"MY",Z=132:"MV",Z=133:"ML",Z=134:"MT",1:"  ") G:PRCACC'="  " COUNTRYQ

 S PRCACC=$S(Z=999:"MH",Z=135:"MQ",Z=136:"MR",Z=137:"MU",Z=52:"YT",Z=138:"MX",Z=161:"FM",Z=141:"MD",Z=139:"MC",Z=140:"MN",Z=142:"MS",Z=143:"MA",Z=144:"MZ",Z=34:"MM",Z=146:"NA",1:"  ") G:PRCACC'="  " COUNTRYQ

 S PRCACC=$S(Z=147:"NR",Z=148:"NP",Z=149:"NL",Z=150:"AN",Z=152:"NC",Z=154:"NZ",Z=155:"NI",Z=156:"NE",Z=157:"NG",Z=158:"NU",Z=159:"NF",Z=160:"NO",Z=145:"OM",Z=162:"PK",1:"  ") G:PRCACC'="  " COUNTRYQ

 S PRCACC=$S(Z=999:"PW",Z=163:"PA",Z=164:"PG",Z=165:"PY",Z=166:"PE",Z=167:"PH",Z=168:"PN",Z=169:"PL",Z=170:"PT",Z=173:"QA",Z=999:"RE",Z=175:"RO",Z=176:"RU",Z=177:"RW",Z=178:"SH",1:"  ") G:PRCACC'="  " COUNTRYQ

 S PRCACC=$S(Z=179:"KN",Z=181:"LC",Z=183:"VC",Z=999:"WS",Z=184:"SM",Z=185:"ST",Z=186:"SA",Z=187:"SN",Z=188:"SC",Z=189:"SL",Z=190:"SG",Z=191:"SK",Z=193:"SI",Z=30:"SB",1:"  ") G:PRCACC'="  " COUNTRYQ

 S PRCACC=$S(Z=194:"SO",Z=195:"ZA",Z=197:"ES",Z=43:"LK",Z=199:"SD",Z=200:"SR",Z=201:"SZ",Z=202:"SE",Z=203:"CH",Z=204:"SY",Z=205:"TJ",Z=222:"TZ",Z=182:"PM",Z=206:"TH",Z=219:"MK",1:"  ") G:PRCACC'="  " COUNTRYQ

 S PRCACC=$S(Z=207:"TG",Z=208:"TK",Z=209:"TO",Z=210:"TT",Z=212:"TN",Z=213:"TR",Z=214:"TM",Z=215:"TC",Z=216:"TV",Z=217:"UG",Z=218:"UA",Z=211:"AE",Z=1:"US",Z=224:"UY",1:"  ") G:PRCACC'="  " COUNTRYQ

 S PRCACC=$S(Z=104:"IR",Z=225:"UZ",Z=153:"VU",Z=97:"VA",Z=226:"VE",Z=183:"VN",Z=31:"VG",Z=227:"WF",Z=228:"YE",Z=229:"YU",Z=230:"ZM",Z=196:"ZW",1:"  ") G:PRCACC'="  " COUNTRYQ

COUNTRYQ ;

 Q PRCACC

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCTOP2   6363     printed  Mar 13, 2025@20:53:44                                                                                                                                                                                                      Page 2

RCTOP2    ;WASH IRMFO@ALTOONA,PA/TJK-TOP TRANSMISSION ;2/11/00  3:25 PM

V         ;;4.5;Accounts Receivable;**141,169,333**;Mar 20, 1995;Build 7

 +1       ;;Per VA Directive 6402, this routine should not be modified

EN1(DEBTOR,CODE,FILE) ;entry point to compile type 2 documents into global

 +1       ;called from RCTOPD

 +2       ;needs debtor internal number and code:"M" or "U"

 +3       ;

 +4       ;PRC*4.5*333 Modify routine to handle foreign addressing

 +5       ;            correctly for transmitting to Treasury.

 +6       ;

 +7        IF $PIECE($GET(^RCD(340,DEBTOR,1)),U,9)=1

               GOTO QUIT

 +8        NEW DEBTOR5,ADDR,LENGTH,DEBNR

 +9       ;

 +10      ;get debtor ar address, compare to top address for 'update' documents

 +11      ;

 +12       SET DEBTOR5=$GET(^RCD(340,DEBTOR,5))

 +13       SET ADDR=$$DADD(DEBTOR)

           SET ADDR=$PIECE(ADDR,U,1,2)_U_$PIECE(ADDR,U,4,8)

 +14       IF +$PIECE(ADDR,U,7)'<2

               SET $PIECE(ADDR,U,4)=""

               SET $PIECE(ADDR,U,5)=""

 +15       SET $PIECE(ADDR,U,7)=$$COUNTRY($PIECE(ADDR,U,7))

 +16       IF CODE="U"

               IF ADDR=DEBTOR5

                   GOTO QUIT

 +17      ;

 +18      ;set record in temporary global

 +19      ;

 +20       SET REC="04      "_$PIECE(^RC(342,1,3),U,5)_"      "

 +21       SET DEBNR=$EXTRACT(SITE,1,3)_$SELECT(FILE=2:0,FILE=440:"V",1:"E")_$TRANSLATE($JUSTIFY(DEBTOR,14)," ",0)

           SET REC=REC_DEBNR

 +22       SET REC=REC_$SELECT(CODE="M":"A",1:"U")_2

 +23       FOR I=1:1:5,7

               Begin DoDot:1

 +24               SET ADDR(I)=$PIECE(ADDR,U,I)

                   SET LENGTH=$SELECT(I<3:30,I=3:25,I=4:2,I=7:3,1:9)

 +25               if I=5

                       SET ADDR(5)=$PIECE(ADDR(5),"-")_$PIECE(ADDR(5),"-",2)

 +26               SET REC=REC_$$LJ^XLFSTR($EXTRACT(ADDR(I),1,LENGTH),LENGTH)

               End DoDot:1

 +27       SET REC=REC_$$BLANK^RCTOP1(68)

 +28       SET CNTR(2)=CNTR(2)+1

           SET ^XTMP("RCTOPD",$JOB,2,CNTR(2))=REC

 +29      ;

 +30      ;set TOP address in ar debtor file

 +31      ;

 +32       SET ^RCD(340,DEBTOR,5)=ADDR

 +33      ;

QUIT       QUIT

DADD(RCDB,RCCONF) ;

 +1        NEW X

 +2        SET X=""

           if $GET(RCDB)=""

               GOTO Q

 +3        IF RCDB?1N.N

               SET RCDB=$PIECE($GET(^RCD(340,RCDB,0)),"^")

 +4       ; the confidential address has greatest priority for mailing

 +5        IF $GET(RCCONF)

               IF RCDB["DPT("

                   SET X=$$PAT^RCAMADD(+RCDB,1)

                   IF X'=""

                       GOTO Q

 +6       ; the AR DEBTOR address (if exists) has a greater priority the permanent address in PATIENT file.

 +7        IF RCDB["DPT("

               SET X=$$ARDEB(+$ORDER(^RCD(340,"B",RCDB,0)))

               if $PIECE(X,U)]""

                   SET $PIECE(X,U,8)=$PIECE(^DPT(+RCDB,.11),U,10)

               IF ($PIECE(X,U)'="")

                   IF ($PIECE(X,U,4)'="")

                       IF ($PIECE(X,U,5)'="")

                           IF (($PIECE(X,U,6)'="")!($PIECE(X,U,8)'=""))

                               GOTO Q

 +8        IF RCDB["DPT("

               SET X=$$PAT(+RCDB,0)

               GOTO Q

 +9        IF RCDB["DIC(4"

               SET X=$$INST^RCAMADD(+RCDB)

               GOTO Q

 +10       IF RCDB["PRC(440,"

               SET X=$$VEN^RCAMADD(+RCDB)

               GOTO Q

 +11       IF RCDB["DIC(36,"

               SET X=$$INSUR^RCAMADD(+RCDB)

               GOTO Q

 +12       IF RCDB["VA(200,"

               SET X=$$PER^RCAMADD(+RCDB)

Q          QUIT X

ARDEB(RCDB) ;Get address from AR Debtor file (340)

 +1        NEW X,Y

 +2        SET X=""

           if '$DATA(^RCD(340,+$GET(RCDB),0))

               GOTO Q6

           SET X=$PIECE($GET(^RCD(340,RCDB,1)),U,1,8)

 +3        if $PIECE(X,U,5)

               SET $PIECE(X,U,5)=$PIECE($GET(^DIC(5,+$PIECE(X,U,5),0)),U,2)

Q6         QUIT X

PAT(RCDB,RCCONF) ;Get patient address as "Str1^Str2^Str3^City^State^ZIP^Telephone" from ^DPT

 +1       ; if RCCONF=0 (default), then return patients permanent address

 +2       ; if RCCONF=1, then return confidential address, or NULL

 +3        NEW DFN,RCX,RCY,II,RCTRY

 +4        IF '$DATA(^DPT(+$GET(RCDB),0))

               SET RCX=""

               GOTO Q3

 +5        SET DFN=RCDB

           SET RCY=$GET(^DPT(DFN,.11))

           IF RCY=""

               SET RCX=""

               GOTO Q3

 +6        SET RCX=""

 +7        IF $PIECE(RCY,U,10)<2

               Begin DoDot:1

 +8                SET RCX=$PIECE(RCY,U,1,6)

 +9                if $PIECE(RCX,U,5)

                       SET $PIECE(RCX,U,5)=$PIECE($GET(^DIC(5,+$PIECE(RCX,U,5),0)),U,2)

 +10               IF $DATA(^DPT(DFN,.13))

                       SET $PIECE(RCX,U,7)=$PIECE(^DPT(DFN,.13),U)

 +11               SET $PIECE(RCX,U,8)=""

                   SET $PIECE(RCX,U,9)=$SELECT($PIECE(RCY,U,16):1,1:0)

               End DoDot:1

               GOTO Q3

 +12       SET RCX=$PIECE(RCY,U,1,3)

           SET $PIECE(RCX,U,4)=$EXTRACT($PIECE(RCY,U,4)_" "_$EXTRACT($PIECE(RCY,U,8),1,2)_" "_$PIECE(RCY,U,9),1,25)

 +13       SET $PIECE(RCX,U,8)=$PIECE(RCY,U,10)

 +14       IF $DATA(^DPT(DFN,.13))

               SET $PIECE(RCX,U,7)=$PIECE(^DPT(DFN,.13),U)

 +15       SET $PIECE(RCX,U,9)=$SELECT($PIECE(RCY,U,16):1,1:0)

Q3         QUIT RCX

COUNTRY(Z) ;

 +1        NEW PRCACC

 +2       ;get TOP country code

 +3        IF +Z<2

               SET PRCACC="US"

               GOTO COUNTRYQ

 +4        SET PRCACC=$SELECT(Z=4:"AF",Z=5:"AL",Z=7:"DZ",Z=8:"AD",Z=9:"AO",Z=180:"AI",Z=10:"AG",Z=12:"AR",Z=18:"AM",Z=151:"AW",Z=13:"AU",Z=14:"AT",Z=11:"AZ",Z=15:"BS",Z=16:"BH",Z=17:"BD",1:"  ")

           if PRCACC'="  "

               GOTO COUNTRYQ

 +5        SET PRCACC=$SELECT(Z=19:"BB",Z=36:"BY",Z=20:"BE",Z=28:"BZ",Z=61:"BJ",Z=21:"BM",Z=22:"BT",Z=23:"BO",Z=24:"BA",Z=25:"BW",Z=27:"BR",Z=29:"IO",Z=32:"BN",Z=33:"BG",Z=223:"Faso",Z=35:"BI",1:"  ")

           if PRCACC'="  "

               GOTO COUNTRYQ

 +6        SET PRCACC=$SELECT(Z=37:"KH",Z=38:"CM",Z=39:"CA",Z=40:"CV",Z=41:"KY",Z=42:"CF",Z=44:"TD",Z=45:"CL",Z=46:"CN",Z=50:"CO",Z=51:"KM",Z=53:"CG",Z=54:"CD",Z=55:"CK",Z=56:"CR",Z=109:"CI",1:"  ")

           if PRCACC'="  "

               GOTO COUNTRYQ

 +7        SET PRCACC=$SELECT(Z=57:"HR",Z=58:"CU",Z=59:"CY",Z=60:"CZ",Z=115:"KP",Z=62:"DK",Z=80:"DJ",Z=63:"DM",Z=64:"DO",Z=172:"TP",Z=65:"EC",Z=220:"EG",Z=66:"SV",Z=67:"GQ",Z=69:"ER",Z=70:"EE",1:"  ")

           if PRCACC'="  "

               GOTO COUNTRYQ

 +8        SET PRCACC=$SELECT(Z=68:"ET",Z=72:"FK",Z=71:"FO",Z=74:"FJ",Z=75:"FI",Z=76:"FR",Z=77:"GF",Z=78:"PF",Z=79:"TF",Z=81:"GA",Z=83:"GM",Z=82:"GE",Z=84:"DE",Z=85:"GH",Z=86:"GI",Z=221:"GB",1:"  ")

           if PRCACC'="  "

               GOTO COUNTRYQ

 +9        SET PRCACC=$SELECT(Z=88:"GR",Z=89:"GL",Z=90:"GD",Z=91:"GP",Z=92:"GT",Z=93:"GN",Z=171:"GW",Z=94:"GY",Z=95:"HT",Z=98:"HN",Z=99:"HK",Z=100:"HU",Z=101:"IS",Z=102:"IN",Z=103:"ID",1:"  ")

           if PRCACC'="  "

               GOTO COUNTRYQ

 +10       SET PRCACC=$SELECT(Z=105:"IQ",Z=106:"IE",Z=107:"IL",Z=108:"IT",Z=110:"JM",Z=111:"JP",Z=113:"JO",Z=112:"KZ",Z=114:"KE",Z=87:"KI",Z=116:"KR",Z=117:"KW",Z=118:"KG",Z=119:"LA",Z=122:"LV",1:"  ")

           if PRCACC'="  "

               GOTO COUNTRYQ

 +11       SET PRCACC=$SELECT(Z=120:"LB",Z=121:"LS",Z=123:"LR",Z=124:"LY",Z=125:"LI",Z=126:"LT",Z=127:"LU",Z=128:"MO",Z=129:"MG",Z=130:"MW",Z=131:"MY",Z=132:"MV",Z=133:"ML",Z=134:"MT",1:"  ")

           if PRCACC'="  "

               GOTO COUNTRYQ

 +12       SET PRCACC=$SELECT(Z=999:"MH",Z=135:"MQ",Z=136:"MR",Z=137:"MU",Z=52:"YT",Z=138:"MX",Z=161:"FM",Z=141:"MD",Z=139:"MC",Z=140:"MN",Z=142:"MS",Z=143:"MA",Z=144:"MZ",Z=34:"MM",Z=146:"NA",1:"  ")

           if PRCACC'="  "

               GOTO COUNTRYQ

 +13       SET PRCACC=$SELECT(Z=147:"NR",Z=148:"NP",Z=149:"NL",Z=150:"AN",Z=152:"NC",Z=154:"NZ",Z=155:"NI",Z=156:"NE",Z=157:"NG",Z=158:"NU",Z=159:"NF",Z=160:"NO",Z=145:"OM",Z=162:"PK",1:"  ")

           if PRCACC'="  "

               GOTO COUNTRYQ

 +14       SET PRCACC=$SELECT(Z=999:"PW",Z=163:"PA",Z=164:"PG",Z=165:"PY",Z=166:"PE",Z=167:"PH",Z=168:"PN",Z=169:"PL",Z=170:"PT",Z=173:"QA",Z=999:"RE",Z=175:"RO",Z=176:"RU",Z=177:"RW",Z=178:"SH",1:"  ")

           if PRCACC'="  "

               GOTO COUNTRYQ

 +15       SET PRCACC=$SELECT(Z=179:"KN",Z=181:"LC",Z=183:"VC",Z=999:"WS",Z=184:"SM",Z=185:"ST",Z=186:"SA",Z=187:"SN",Z=188:"SC",Z=189:"SL",Z=190:"SG",Z=191:"SK",Z=193:"SI",Z=30:"SB",1:"  ")

           if PRCACC'="  "

               GOTO COUNTRYQ

 +16       SET PRCACC=$SELECT(Z=194:"SO",Z=195:"ZA",Z=197:"ES",Z=43:"LK",Z=199:"SD",Z=200:"SR",Z=201:"SZ",Z=202:"SE",Z=203:"CH",Z=204:"SY",Z=205:"TJ",Z=222:"TZ",Z=182:"PM",Z=206:"TH",Z=219:"MK",1:"  ")

           if PRCACC'="  "

               GOTO COUNTRYQ

 +17       SET PRCACC=$SELECT(Z=207:"TG",Z=208:"TK",Z=209:"TO",Z=210:"TT",Z=212:"TN",Z=213:"TR",Z=214:"TM",Z=215:"TC",Z=216:"TV",Z=217:"UG",Z=218:"UA",Z=211:"AE",Z=1:"US",Z=224:"UY",1:"  ")

           if PRCACC'="  "

               GOTO COUNTRYQ

 +18       SET PRCACC=$SELECT(Z=104:"IR",Z=225:"UZ",Z=153:"VU",Z=97:"VA",Z=226:"VE",Z=183:"VN",Z=31:"VG",Z=227:"WF",Z=228:"YE",Z=229:"YU",Z=230:"ZM",Z=196:"ZW",1:"  ")

           if PRCACC'="  "

               GOTO COUNTRYQ

COUNTRYQ  ;

 +1        QUIT PRCACC

RCTOP2.m