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

ACRFEXP2.m

Go to the documentation of this file. 
  1. ACRFEXP2 ;IHS/OIRM/DSD/AEF - MAIN DRIVER ROUTINE FOR DHR & ECS EXPORT [ 09/23/2005  8:29 AM ]
  1.  ;;2.1;ADMIN RESOURCE MGT SYSTEM;**2,19**;NOV 05, 2001
  1.  ;
  1.  ;ACR*2.1*2.1;THIS ROUTINE IS REWRITTEN TO RESTORE THE ACH-GROUPED
  1.  ;PAYMENTS
  1.  ;
  1.  ;This routine processes payments from the 1166 Approvals
  1.  ;for Payment file and places them into the DHR Data Records
  1.  ;file for subsequent transmission to CORE and into the Treasury
  1.  ;ECS file for transmission to Treasury
  1.  ;
  1.  ;      VARIABLES USED:
  1.  ;      ACRALC = AGENCY LOCATION CODE USED BY TREASURY
  1.  ;      ACRBTYP= BATCH TYPE: T=TRAVEL;V=VENDOR
  1.  ;      ACRECS = UNIX TREASURY ECS FILE NAME
  1.  ;      ACRFIN = FINANCE OFFICE IEN
  1.  ;      ACRRFC = TREASURY REGIONAL FINANCE CENTER CODE
  1.  ;      ACRACH = TREASURY SCHEDULE FORMAT:
  1.  ;               T = TAPE-GROUPED
  1.  ;               C = CHECKS GROUPED
  1.  ;               N = CHECKS-NOT GROUPED
  1.  ;               A = ACH-GROUPED (ELECTRONIC FUNDS TRANSFER)
  1.  ;               B = ACH-NOT GROUPED (ELECTRONIC FUNDS TRANSFER)
  1.  ;               G = DHR ONLY
  1.  ;
  1.  ;
  1. EN(ACRD0,ACRD1)    ;EP
  1.  ;----- MAIN DRIVER ENTRY POINT
  1.  ;
  1.  ;      ACRD0  = FY IEN IN 1166 APPROVALS FOR PAYMENT FILE
  1.  ;      ACRD1  = BATCH IEN IN 1166 APPROVALS FOR PAYMENT FILE
  1.  ;      ACRALC = AGENCY LOCATION CODE
  1.  ;      ACRFIN = FINANCE OFFICE IEN
  1.  ;      ACROUT = QUIT CONTROLLER         
  1.  ;      ACRRFC = REGIONAL FINANCE CENTER
  1.  ;
  1.  N ACRALC,ACRECS,ACRFIN,ACROUT,ACRRFC
  1.  ;
  1.  D FINCHK(.ACRFIN,.ACROUT)
  1.  Q:ACROUT
  1.  ;
  1.  D PARAMCK(1,.ACRALC,.ACRRFC,.ACROUT)
  1.  Q:ACROUT
  1.  ;
  1.  D GET(ACRD0,ACRD1)
  1.  Q:'$D(^TMP("ACR",$J))
  1.  ;
  1.  D DHR^ACRFEXP3
  1.  ;
  1.  D ECS^ACRFEXP4(ACRD0,ACRD1,ACRFIN,ACRALC,ACRRFC,.ACRECS)
  1.  ;
  1.  D UPDATE(ACRD0,ACRD1,$G(ACRECS))
  1.  ;
  1.  D BSR(ACRD0,ACRD1)
  1.  ;
  1.  K ^TMP("ACR",$J)
  1.  ;
  1.  Q
  1. GET(ACRD0,ACRD1)   ;
  1.  ;----- LOOP THROUGH 1166 APPROVALS FOR PAYMENT SEQUENCES
  1.  ;      TO GATHER PAYMENT DATA AND PUT INTO ^TMP("ACR",$J)
  1.  ;      GLOBAL
  1.  ;
  1.  ;      ACRACH  = TREASURY SCHEDULE FORMAT
  1.  ;      ACRAMT  = TRANSACTION AMOUNT
  1.  ;      ACRAPPN = APPROPRIATION NUMBER
  1.  ;      ACRBTYP = BATCH TYPE
  1.  ;      ACRD0   = FY IEN IN 1166 APPROVALS FOR PAYMENT FILE
  1.  ;      ACRD1   = BATCH IEN IN 1166 AFP FILE
  1.  ;      ACRD2   = SEQ NO IEN IN 1166 AFP FILE
  1.  ;      ACRIEN  = VENDOR/TRAVELER INTERNAL ENTRY NUMBER
  1.  ;      ACRNAME = VENDOR/TRAVELER NAME
  1.  ;      ACROCC  = OBJECT CLASS CODE
  1.  ;      ACRPDFOR= ACH ADDENDUM/INVOICE NUMBER/TO NUMBER
  1.  ;      ACRREF  = REFERENCE CODE
  1.  ;      ACRSSN  = VENDOR EIN/TRAVELER SSN
  1.  ;      ACRTCOD = TRANSACTION TYPE
  1.  ;
  1.  N ACRD2,ACRACH,ACRAMT,ACRAPPN,ACRBTYP,ACRDATA,ACRIEN,ACRNAME,ACROCC,ACRPDFOR,ACRREF,ACRSSN,ACRTCOD
  1.  K ^TMP("ACR",$J)
  1.  S ACRBTYP=$P($G(^AFSLAFP(ACRD0,1,ACRD1,0)),U,4)
  1.  Q:ACRBTYP=""
  1.  S ACRDATA=$G(^AFSLAFP(ACRD0,1,ACRD1,2))
  1.  S ACRACH=$P(ACRDATA,U,8)
  1.  Q:ACRACH=""
  1.  S ACRD2=0
  1.  F  S ACRD2=$O(^AFSLAFP(ACRD0,1,ACRD1,1,ACRD2)) Q:'ACRD2  D
  1.  . S ACRDATA=$G(^AFSLAFP(ACRD0,1,ACRD1,1,ACRD2,0))
  1.  . S ACRTCOD=$P(ACRDATA,U,18)
  1.  . Q:ACRTCOD=""
  1.  . S ACRAMT=+$P(ACRDATA,U,11)
  1.  . I $E(ACRTCOD,U,4)=2 S ACRAMT=0-ACRAMT
  1.  . S ACRREF=$P(ACRDATA,U,6)
  1.  . S ACRREF=$TR(ACRREF," ","")
  1.  . Q:ACRREF=""
  1.  . S ACROCC=$P(ACRDATA,U,8)
  1.  . Q:'ACROCC
  1.  . S ACROCC=$P($G(^AUTTOBJC(ACROCC,0)),U)
  1.  . Q:ACROCC=""
  1.  . I ACRBTYP="V" D
  1.  . . S ACRIEN=$P(ACRDATA,U,10)
  1.  . . S ACRNAME=$P($G(^AUTTVNDR(ACRIEN,0)),U)
  1.  . . S ACRSSN=$P($G(^AUTTVNDR(ACRIEN,11)),U,13)
  1.  . I ACRBTYP="T" D
  1.  . . S ACRIEN=$P(ACRDATA,U,24)
  1.  . . ;S ACRNAME=$P($G(^VA(200,ACRIEN,0)),U)  ;ACR*2.1*19.02 IM16848
  1.  . . S ACRNAME=$$NAME2^ACRFUTL1(ACRIEN)  ;ACR*2.1*19.02 IM16848
  1.  . . S ACRSSN=$P($G(^VA(200,ACRIEN,1)),U,9)
  1.  . Q:ACRNAME=""
  1.  . S ACRAPPN=$P($G(^AFSLAFP(ACRD0,1,ACRD1,1,ACRD2,1)),U,21)
  1.  . Q:ACRAPPN=""
  1.  . S ACRNAME=$$UPPER^ACRFUTL(ACRNAME)
  1.  . S ACRNAME=$TR(ACRNAME,"~"," ")
  1.  . S ACRNAME=ACRNAME_"~"_ACRIEN_"~"_ACRAPPN
  1.  . S ACRDATA=$G(^AFSLAFP(ACRD0,1,ACRD1,1,ACRD2,2))
  1.  . S ACRPDFOR=$S(ACRACH="C"!(ACRACH="N"):$P(ACRDATA,U,14),1:$P(ACRDATA,U,2))
  1.  . D DHRSET(ACRNAME,ACRD0,ACRD1,ACRD2,ACRAMT,ACRPDFOR)
  1.  . Q:ACRACH="G"
  1.  . Q:ACRACH="T"
  1.  . ;Q:ACROCC="219M" ;COMMENTED OUT TO ALLOW TRAVEL MGT FEE TO GO TO ECS FILE
  1.  . Q:"^061^192^191^190^182^181^199^"'[$E(ACRTCOD,1,3)
  1.  . I ACRBTYP="T" D
  1.  . . Q:$E(ACRTCOD,1,3)="061"
  1.  . . S ACRDATA=$G(^AFSLAFP(ACRD0,1,ACRD1,1,ACRD2,0))
  1.  . . S ACRAMT=ACRAMT-$P(ACRDATA,U,12)
  1.  . D APPSET(ACRAPPN,ACRAMT)
  1.  . I ACRACH="A" D A(ACRAMT,ACRD0,ACRD1,ACRD2,ACRNAME,ACRPDFOR)
  1.  . I ACRACH="B" D B(ACRAMT,ACRD0,ACRD1,ACRD2,ACRNAME,ACRPDFOR)
  1.  . I ACRACH="C" D C(ACRAMT,ACRD0,ACRD1,ACRD2,ACRNAME,ACRPDFOR)
  1.  . I ACRACH="N" D N(ACRAMT,ACRD0,ACRD1,ACRD2,ACRNAME,ACRPDFOR)
  1.  ;
  1.  S ACRCNT=0
  1.  S ACRAPPN=""
  1.  F  S ACRAPPN=$O(^TMP("ACR",$J,"X",ACRAPPN)) Q:ACRAPPN']""  D
  1.  . S ACRCNT=ACRCNT+1
  1.  . S ^TMP("ACR",$J,"ECSAPPN",ACRCNT,0)=ACRAPPN_U_^TMP("ACR",$J,"X",ACRAPPN,0)
  1.  Q
  1. APPSET(ACRAPPN,ACRAMT)       ;
  1.  ;----- SET APPROPRIATION NUMBER/AMOUNT ARRAY
  1.  ;
  1.  S ^TMP("ACR",$J,"X",ACRAPPN,0)=$G(^TMP("ACR",$J,"X",ACRAPPN,0))+ACRAMT
  1.  Q
  1. DHRSET(ACRNAME,ACRD0,ACRD1,ACRD2,ACRAMT,ACRPDFOR)          ;
  1.  ;----- SET ^TMP GLOBAL WITH DHR PAYMENT DATA
  1.  ;
  1.  ;      3RD PIECE = FY IEN OF 1166 APPROVALS FOR PAYMENT FILE
  1.  ;      4TH PIECE = BATCH IEN
  1.  ;      5TH PIECE = SEQUENCE NO IEN
  1.  ;      OTHER DATA PIECES ARE INCLUDED FOR TROUBLESHOOTING PURPOSES
  1.  ;      ALSO, VENDOR/TRAVELER NAMES ARE ALPHABETIZED
  1.  ;
  1.  S ^TMP("ACR",$J,"DHR",ACRNAME,ACRD2,0)=ACRD2_U_ACRAMT_U_ACRD0_U_ACRD1_U_ACRD2_U_ACRPDFOR
  1.  Q
  1. A(ACRAMT,ACRD0,ACRD1,ACRD2,ACRNAME,ACRPDFOR)     ;
  1.  ;----- SET ^TMP GLOBAL FOR ACH-GROUPED PAYMENTS
  1.  ;
  1.  N ACRPDFRX,ACRPMT,ACRX
  1.  ;
  1.  S ACRPDFOR=$$PDFOR(ACRPDFOR)
  1.  S ACRPDFRX=""
  1.  ;
  1.  I '$D(^TMP("ACR",$J,"ECS","A",ACRNAME,0)) D
  1.  . S ^TMP("ACR",$J,"ECS","A",ACRNAME,0)="1^0"
  1.  . S ACRDATA=$G(^TMP("ACR",$J,"ECS","A",0))
  1.  . S $P(ACRDATA,U)=$P(ACRDATA,U)+1
  1.  . S ^TMP("ACR",$J,"ECS","A",0)=ACRDATA
  1.  ;
  1.  S ACRPMT=$P(^TMP("ACR",$J,"ECS","A",ACRNAME,0),U)
  1.  ;
  1.  S ACRPDFRX=$TR(ACRPDFRX,"\","")
  1.  I ACRPDFRX]"" S ACRPDFRX=ACRPDFRX_","
  1.  S ACRPDFRX=ACRPDFRX_ACRPDFOR
  1.  S ACRPDFRX=ACRPDFRX_"\"
  1.  ;
  1.  S ACRDATA=$G(^TMP("ACR",$J,"ECS","A",ACRNAME,ACRPMT,0))
  1.  S $P(ACRDATA,U)=$P(ACRDATA,U)+1
  1.  S $P(ACRDATA,U,2)=$P(ACRDATA,U,2)+ACRAMT
  1.  S $P(ACRDATA,U,3)=ACRD0
  1.  S $P(ACRDATA,U,4)=ACRD1
  1.  S $P(ACRDATA,U,5)=ACRD2
  1.  S $P(ACRDATA,U,6)=ACRPDFRX
  1.  S ^TMP("ACR",$J,"ECS","A",ACRNAME,ACRPMT,0)=ACRDATA
  1.  ;
  1.  S ^TMP("ACR",$J,"ECS","A",ACRNAME,ACRPMT,$P(ACRDATA,U),0)=1_U_ACRAMT_U_ACRD0_U_ACRD1_U_ACRD2_U_ACRPDFOR
  1.  ;
  1.  S ACRDATA=^TMP("ACR",$J,"ECS","A",ACRNAME,0)
  1.  S $P(ACRDATA,U,2)=$P(ACRDATA,U,2)+ACRAMT
  1.  S ^TMP("ACR",$J,"ECS","A",ACRNAME,0)=ACRDATA
  1.  ;
  1.  S ACRDATA=$G(^TMP("ACR",$J,"ECS","A",0))
  1.  S $P(ACRDATA,U,2)=$P(ACRDATA,U,2)+ACRAMT
  1.  S ^TMP("ACR",$J,"ECS","A",0)=ACRDATA
  1.  Q
  1. B(ACRAMT,ACRD0,ACRD1,ACRD2,ACRNAME,ACRPDFOR)     ;
  1.  ;----- SET ^TMP GLOBAL FOR ACH-NOT GROUPED PAYMENTS
  1.  ;
  1.  N ACRDATA,ACRPMT
  1.  ;
  1.  S ACRDATA=$G(^TMP("ACR",$J,"ECS","B",0))
  1.  S $P(ACRDATA,U)=$P(ACRDATA,U)+1
  1.  S $P(ACRDATA,U,2)=$P(ACRDATA,U,2)+ACRAMT
  1.  S ^TMP("ACR",$J,"ECS","B",0)=ACRDATA
  1.  ;
  1.  S ACRDATA=$G(^TMP("ACR",$J,"ECS","B",ACRNAME,0))
  1.  S $P(ACRDATA,U)=$P(ACRDATA,U)+1
  1.  S $P(ACRDATA,U,2)=$P(ACRDATA,U,2)+ACRAMT
  1.  S ^TMP("ACR",$J,"ECS","B",ACRNAME,0)=ACRDATA
  1.  ;
  1.  S ACRPMT=$P(^TMP("ACR",$J,"ECS","B",ACRNAME,0),U)
  1.  S ^TMP("ACR",$J,"ECS","B",ACRNAME,ACRPMT,0)=1_U_ACRAMT_U_ACRD0_U_ACRD1_U_ACRD2_U_ACRPDFOR
  1.  Q
  1. C(ACRAMT,ACRD0,ACRD1,ACRD2,ACRNAME,ACRPDFOR)     ;
  1.  ;----- SET ^TMP GLOBAL FOR CHECKS-GROUPED PAYMENTS
  1.  ;
  1.  ;14 PAYMENT ID LINES
  1.  ;
  1.  N ACRDATA,ACRGPMT
  1.  ;
  1.  S ACRPDFOR=$$PDFOR(ACRPDFOR)
  1.  ;
  1.  S ACRDATA=$G(^TMP("ACR",$J,"ECS","C",0))
  1.  S $P(ACRDATA,U,2)=$P(ACRDATA,U,2)+ACRAMT
  1.  S ^TMP("ACR",$J,"ECS","C",0)=ACRDATA
  1.  ;
  1.  I '$D(^TMP("ACR",$J,"ECS","C",ACRNAME,0)) D
  1.  . S ^TMP("ACR",$J,"ECS","C",ACRNAME,0)="1^0"
  1.  . S ACRDATA=^TMP("ACR",$J,"ECS","C",0)
  1.  . S $P(ACRDATA,U)=$P(ACRDATA,U)+1
  1.  . S ^TMP("ACR",$J,"ECS","C",0)=ACRDATA
  1.  ;
  1.  S ACRDATA=$G(^TMP("ACR",$J,"ECS","C",ACRNAME,0))
  1.  S $P(ACRDATA,U,2)=$P(ACRDATA,U,2)+ACRAMT
  1.  S ^TMP("ACR",$J,"ECS","C",ACRNAME,0)=ACRDATA
  1.  ;
  1.  S ACRGPMT=$P(^TMP("ACR",$J,"ECS","C",ACRNAME,0),U)
  1.  ;
  1.  ;Only 14 payments in Checks-Grouped
  1.  S ACRDATA=$G(^TMP("ACR",$J,"ECS","C",ACRNAME,ACRGPMT,0))
  1.  I $P(ACRDATA,U)+1>14 D
  1.  . S ACRGPMT=ACRGPMT+1
  1.  . S $P(^TMP("ACR",$J,"ECS","C",ACRNAME,0),U)=ACRGPMT
  1.  . S ACRDATA=^TMP("ACR",$J,"ECS","C",0)
  1.  . S $P(ACRDATA,U)=$P(ACRDATA,U)+1
  1.  . S ^TMP("ACR",$J,"ECS","C",0)=ACRDATA
  1.  ;
  1.  S ACRDATA=$G(^TMP("ACR",$J,"ECS","C",ACRNAME,ACRGPMT,0))
  1.  S $P(ACRDATA,U)=$P(ACRDATA,U)+1
  1.  S $P(ACRDATA,U,2)=$P(ACRDATA,U,2)+ACRAMT
  1.  S $P(ACRDATA,U,3)=ACRD0
  1.  S $P(ACRDATA,U,4)=ACRD1
  1.  S $P(ACRDATA,U,5)=ACRD2
  1.  S ^TMP("ACR",$J,"ECS","C",ACRNAME,ACRGPMT,0)=ACRDATA
  1.  ;
  1.  S ^TMP("ACR",$J,"ECS","C",ACRNAME,ACRGPMT,$P(ACRDATA,U),0)=1_U_ACRAMT_U_ACRD0_U_ACRD1_U_ACRD2_U_ACRPDFOR
  1.  Q
  1. N(ACRAMT,ACRD0,ACRD1,ACRD2,ACRNAME,ACRPDFOR)     ;
  1.  ;----- SET ^TMP GLOBAL FOR CHECKS-NOT GROUPED PAYMENTS
  1.  ;
  1.  S ACRDATA=$G(^TMP("ACR",$J,"ECS","N",0))
  1.  S $P(ACRDATA,U)=$P(ACRDATA,U)+1
  1.  S $P(ACRDATA,U,2)=$P(ACRDATA,U,2)+ACRAMT
  1.  S ^TMP("ACR",$J,"ECS","N",0)=ACRDATA
  1.  ;
  1.  S ACRPMT=$P(ACRDATA,U)
  1.  S ^TMP("ACR",$J,"ECS","N",ACRNAME,ACRPMT,0)=1_U_ACRAMT_U_ACRD0_U_ACRD1_U_ACRD2_U_ACRPDFOR
  1.  Q
  1. FINCHK(ACRFIN,ACROUT)        ;
  1.  ;----- CHECK IF PURCHASE AND FINANCE OFFICES SET UP PROPERLY
  1.  ;
  1.  ;      RETURNS:
  1.  ;      ACRFIN = INTERNAL FINANCE OFFICE
  1.  ;      ACROUT = QUIT CONTROLLER
  1.  ;
  1.  N X
  1.  S ACROUT=0
  1.  S ACRFIN=$P($G(^ACRPO(1,0)),U,8)
  1.  I 'ACRFIN D  Q
  1.  . S ACROUT=1
  1.  . W !!,"The Area Purchase Office is not properly set up."
  1.  . W !,"Contact your Area ARMS Manager for assistance."
  1.  I '$D(^AUTTPRG(ACRFIN,"DT")) D  Q
  1.  . S ACROUT=1
  1.  . W !!,"Information on the Area Finance Office is not properly set up."
  1.  . W !,"Contact your ARMS Manager for assistance."
  1.  . D PAUSE^ACRFWARN
  1.  Q
  1. PARAMCK(ACRD0,ACRALC,ACRRFC,ACROUT)    ;
  1.  ;----- SET UP REQUIRED ALC AND RFC PARAMETERS
  1.  ;
  1.  ;      INPUT:
  1.  ;      ACRD0  =  THE IEN OF THE FACILITY IN THE FMS SYSTEM DEFAULTS
  1.  ;                FILE
  1.  ;
  1.  ;      RETURNS:
  1.  ;      ACRALC =  AGENCY LOCATION CODE
  1.  ;      ACRRFC =  TREASURY REGIONAL FINANCIAL CENTER CODE
  1.  ;      ACROUT =  QUIT CONTROLLER: 0=SUCCESSFUL, 1=UNSUCCESSFUL
  1.  ;
  1.  N ACRDATA
  1.  S ACROUT=0
  1.  S ACRDATA=$G(^ACRSYS(ACRD0,402))
  1.  S ACRALC=$P(ACRDATA,U)
  1.  S ACRRFC=$P(ACRDATA,U,2)
  1.  I ACRALC=""!(ACRRFC="") D  S ACROUT=1 Q
  1.  . W *7,!?5,"Agency Location Code and/or Regional Financial Center"
  1.  . W !?5,"Code missing from FMS Systems Defaults File"
  1.  . W !
  1.  . H 2
  1.  Q
  1. BSR(ACRD0,ACRD1)   ;
  1.  ;----- PRINTS BATCH STATUS REPORT
  1.  ;      INTERFACE TO ROUTINE BS1^ACRFPAY8
  1.  ;
  1.  ;      INPUT:
  1.  ;      ACRD0    = FY IEN IN 1166 APPROVALS FOR PAYMENT FILE
  1.  ;      ACRD1    = BATCH IEN IN 1166 APPROVALS FOR PAYMENT FILE
  1.  ;
  1.  ;      VARIABLES NEEDED FOR CALL TO BS1^ACRFPAY8:
  1.  ;      ACRBATDA = BATCH IEN
  1.  ;      ACRBATNO = BATCH NUMBER
  1.  ;      ACRFY    = FISCAL YEAR
  1.  ;      ACRFYDA  = FISCAL YEAR IEN
  1.  ;      ACROUT   = QUIT CONTROLLER - NOT USED HERE, BUT NEWED TO
  1.  ;                 PREVENT IT FROM INTERFERING WHEN BS1^ACRFPAY8
  1.  ;                 CALLS PAUSE^ACRFWARN
  1.  ;                
  1.  N ACRBATDA,ACRBATNO,ACRFY,ACRFYDA,ACROUT
  1.  D HOME^%ZIS
  1.  S ACRFY=$P($G(^AFSLAFP(ACRD0,0)),U)
  1.  S ACRBATNO=$P($G(^AFSLAFP(ACRD0,1,ACRD1,0)),U)
  1.  S ACRFYDA=ACRD0
  1.  S ACRBATDA=ACRD1
  1.  D BS1^ACRFPAY8
  1.  Q
  1. UPDATE(ACRD0,ACRD1,ACRECS)   ;
  1.  ;----- UPDATE EXPORT FIELDS: EXPORT DATE, ECS FILE
  1.  ;
  1.  ;      ACRD0  = FY IEN IN 1166 APPROVALS FOR PAYMENT FILE
  1.  ;      ACRD1  = BATCH IEN IN 1166 APPROVALS FOR PAYMENT FILE
  1.  ;      ACRECS = TREASURY ECS FILE NAME
  1.  ;
  1.  N DA,DIE,DR,X,Y
  1.  D ^XBKVAR
  1.  S DA=ACRD1
  1.  S DA(1)=ACRD0
  1.  S DIE="^AFSLAFP("_DA(1)_",1,"
  1.  S DR="5////"_DT_";25///"_$G(ACRECS)
  1.  D ^DIE
  1.  K ^AFSLAFP("EXPORT",ACRD0,ACRD1)
  1.  Q
  1. PDFOR(X) ;----- EXTRINSIC FUNCTION TO CONVERT PAID FOR
  1.  ;
  1.  I "REF*"[$E(X,1,4) D
  1.  . S X=$P(X,"*",4)
  1.  I "RMT*^RMR*"[$E(X,1,4) D
  1.  . S X=$P(X,"*",3)
  1.  S X=$TR(X,"\","")
  1.  Q X