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

IBCOMA1.m

Go to the documentation of this file.
  1. IBCOMA1 ;ALB/CMS/JNM - IDENTIFY ACTIVE POLICIES W/NO EFFECTIVE DATE (CON'T) ; 09-29-2015
  1. ;;2.0;INTEGRATED BILLING;**103,516,528,549,743,752**;21-MAR-94;Build 20
  1. ;;Per VA Directive 6402, this routine should not be modified.
  1. Q
  1. BEG ; Entry to run Active Policies w/no Effective Date Report
  1. ; Input variables:
  1. ; IBAIB - Required. How to sort
  1. ; 1= Patient Name Range 2= Terminal Digit Range
  1. ; IBSIN - Required. Include Active Policies with
  1. ; 1= Verification Date 2= No Verification Date 3= Both
  1. ;
  1. ; IBRF - Required. Name or Terminal Digit Range Start value
  1. ; IBRL - Required. Name or Terminal Digit Range Go to value
  1. ; IBBDT - Optional. Beginning Verification Date Range
  1. ; IBEDT - Optional. Ending Verification Date Range
  1. ; IBEXCEL - 1 = Excel Format
  1. ;
  1. ; IB*2*549 - New filter variables
  1. ; IBPTYPE - Living/Deceased/Both filter ;
  1. ; IBAPPTS - Last Appointment Date Range Start
  1. ; IBAPPTE - Last Appointment Date Range End
  1. ;
  1. N APPTDATA,CAPPT,CDOD,CGRP,CINS,CLVBY,CLVDAT,CSSN,DFN,IBC,IBC0,IBCDA
  1. N IBCDA0,IBCDA1,IBI,IBPAGE,IBQUIT,IBTD,IBTMP,IBX,IDX,LASTAPPT,LASTVER
  1. N LVDATE,MAXGRP,MAXINS,MAXPT,MAXRPT,MAXVERBY,VA,VADM,VAERR,X,Y
  1. N IBVANM S IBVANM="" ;IB*752/DTG - new variable for case insensitive
  1. ;
  1. ; Set starting max field sizes to length of header text
  1. F IDX=1:1:2 S MAXPT(IDX)=12,MAXINS(IDX)=13,MAXGRP(IDX)=9,MAXVERBY(IDX)=5
  1. K ^TMP("IBCOMA",$J)
  1. S IBPAGE=0,IBQUIT=0
  1. ;
  1. ; Set up filter data for the call to SDAPI^SDAMA301 for IB*2*549
  1. I IBAPPTS>0 S APPTDATA(1)=IBAPPTS_";"_IBAPPTE
  1. S APPTDATA("FLDS")=1 ; Return Appt Date/Time Data
  1. S APPTDATA("MAX")=-1 ; Return Last Appt
  1. K ^TMP($J,"SDAMA301")
  1. ;
  1. S IBC=0 F S IBC=$O(^DPT("AB",IBC)) Q:'IBC D
  1. . S IBC0=$G(^DIC(36,IBC,0))
  1. . ;
  1. . ; If company inactive quit
  1. . Q:$P(IBC0,U,1)=""
  1. . Q:$P(IBC0,U,5)=1
  1. . S DFN=0 F S DFN=$O(^DPT("AB",IBC,DFN)) Q:'DFN D
  1. . . K VA,VADM,VAERR
  1. . . D DEM^VADPT
  1. . . ;
  1. . . ; IB*2*549 If Pt. deceased and not showing deceased patients quit
  1. . . I IBPTYPE=1,($G(VADM(6))>0) Q
  1. . . ;
  1. . . ; IB*2*549 If Pt. not deceased and not showing living patients quit
  1. . . I IBPTYPE=2,($G(VADM(6))'>0) Q
  1. . . S VADM(1)=$P($G(VADM(1)),U,1)
  1. . . ;
  1. . . ; I Pt. name out of range quit
  1. . . Q:VADM(1)=""
  1. . . ;IB*752/DTG - case insensitive check inclusive
  1. . . S IBVANM=$$UP^XLFSTR(VADM(1))
  1. . . ;I IBAIB=1,VADM(1)]IBRL Q
  1. . . ;I IBAIB=1,IBRF]VADM(1) Q
  1. . . I IBAIB=1,$E(IBVANM,1,$L(IBRLU))]IBRLU Q
  1. . . I IBAIB=1,IBRFU]$E(IBVANM,1,$L(IBRFU)) Q
  1. . . ;
  1. . . ; I Terminal Digit out of range quit
  1. . . I IBAIB=2 S IBTD=$$TERMDG^IBCONS2(DFN) S:IBTD="" IBTD="000000000" I (+IBTD>IBRL)!(IBRF>+IBTD) Q
  1. . . ;
  1. . . ; Fix subscript error if terminal digit is null
  1. . . I IBAIB=2,IBTD="" S IBTD=" "
  1. . . ;
  1. . . ; IB*2*549 Filter on last appointment date using ICR# 4433
  1. . . S APPTDATA(4)=DFN
  1. . . I $$SDAPI^SDAMA301(.APPTDATA)>0 D
  1. . . . S LASTAPPT=@$Q(^TMP($J,"SDAMA301"))
  1. . . . K ^TMP($J,"SDAMA301")
  1. . . E S LASTAPPT=0 I IBAPPTS>0 Q ; Filtering on Appt Date but no date in range
  1. . . ;
  1. . . S IBCDA=0 F S IBCDA=$O(^DPT("AB",IBC,DFN,IBCDA)) Q:'IBCDA D
  1. . . . ;IB*2.0*516/TAZ - Retrieve data from HIPAA compliant fields.
  1. . . . ;S IBCDA0=$G(^DPT(DFN,.312,IBCDA,0)) ;516 - baa
  1. . . . S IBCDA0=$$ZND^IBCNS1(DFN,IBCDA) ;516 - baa
  1. . . . ;
  1. . . . ; I Effective Date populated quit
  1. . . . Q:$P(IBCDA0,U,8)
  1. . . . ;
  1. . . . ; I Expiration Date entered and expired quit
  1. . . . I $P(IBCDA0,U,4),$P(IBCDA0,U,4)'>DT Q
  1. . . . ;
  1. . . . ; Sorting by verification date or no date check
  1. . . . S IBCDA1=$G(^DPT(DFN,.312,IBCDA,1))
  1. . . . S LVDATE=+$P($P(IBCDA1,U,3),".",1)
  1. . . . I IBSIN=1,LVDATE=0 Q
  1. . . . I IBSIN=1,IBBDT>0,(LVDATE<IBBDT)!(LVDATE>IBEDT) Q
  1. . . . I IBSIN=2,LVDATE>0 Q
  1. . . . I IBSIN=3,LVDATE>0,IBBDT>0,(LVDATE<IBBDT)!(LVDATE>IBEDT) Q
  1. . . . ;
  1. . . . ; Set data line for global
  1. . . . ;S IBTMP(1)=PT NAME^SSN^DATE OF DEATH^LAST APPT DATE
  1. . . . ;S IBTMP(2)=INSURANCE NAME
  1. . . . ;S IBTMP(3)=VERIFICATION DATE^LAST VERIFIED BY^GROUP NUMBER
  1. . . . ;
  1. . . . S IBTMP(1)=VADM(1)_U_$E(VADM(2),6,9)_U_$$FMTE^XLFDT($P(VADM(6),U,1),"2ZD")
  1. . . . S IBTMP(1)=IBTMP(1)_U_$$FMTE^XLFDT(LASTAPPT,"2ZD")
  1. . . . S IBTMP(2)=$P(IBC0,U,1)
  1. . . . S LASTVER=$P(IBCDA1,U,4)
  1. . . . I LASTVER'="" S LASTVER=$P($G(^VA(200,LASTVER,0)),U)
  1. . . . S IBTMP(3)=$$FMTE^XLFDT(LVDATE,"2ZD")_U_LASTVER_U_$P(IBCDA0,U,3)
  1. . . . ;
  1. . . . ; Set variable IBI for Verified=1 or Non verified=2
  1. . . . S IBI=$S(+$P(IBCDA1,U,3):1,1:2)
  1. . . . I 'IBEXCEL D
  1. . . . . D SETMAX(VADM(1),.MAXPT,IBI),SETMAX($P(IBC0,U,1),.MAXINS,IBI)
  1. . . . . D SETMAX(LASTVER,.MAXVERBY,IBI),SETMAX($P(IBCDA0,U,3),.MAXGRP,IBI)
  1. . . . ;
  1. . . . ; Set Global array
  1. . . . S ^TMP("IBCOMA",$J,IBI,$S(IBAIB=2:+IBTD,1:VADM(1)),DFN)=IBTMP(1)
  1. . . . S ^TMP("IBCOMA",$J,IBI,$S(IBAIB=2:+IBTD,1:VADM(1)),DFN,IBC)=IBTMP(2)
  1. . . . S ^TMP("IBCOMA",$J,IBI,$S(IBAIB=2:+IBTD,1:VADM(1)),DFN,IBC,IBCDA)=IBTMP(3)
  1. I 'IBEXCEL D CALCCOLS
  1. I '$D(^TMP("IBCOMA",$J)) D G QUEQ
  1. . D HD(1)
  1. . W !!,"** NO RECORDS FOUND **"
  1. . D EOR,ASK^IBCOMC2 ; IB*752/DTG - print EOR then pause
  1. D WRT
  1. ;IB*752/DTG - end of report then pause
  1. ;W !!,"** END OF REPORT **",!
  1. I '$G(IBQUIT) D EOR,ASK^IBCOMC2
  1. ;
  1. QUEQ ; Exit clean-UP
  1. W !
  1. D ^%ZISC
  1. K IBAIB,IBAPPTE,IBAPPTS,IBEXCEL,IBPTYPE,IBRF,IBRL,IBSIN,IBTMP,VA,VADM,VAERR,^TMP("IBCOMA",$J)
  1. K IBVANM ;IB*752/DTG - variable for case insensitive
  1. Q
  1. ;
  1. ;IB*752/DTG - end of report
  1. EOR ; end of report
  1. ;
  1. W !!,"** END OF REPORT **",!
  1. Q
  1. ;
  1. HD(IBA) ; Write Heading
  1. ; Input: IBA - 1 - Header for non-verified policies
  1. ; 2 - Header for verified policies
  1. ; CAPPT(IBA) - Starting Column Position for the 'Last Apt' Column
  1. ; CDOD(IBA) - Starting Column Position for the 'DoD' Column
  1. ; CGRP(IBA) - Starting Column Position for the 'Group No.' Column
  1. ; CINS(IBA) - Starting Column Position for the 'Insurance Co.' Column
  1. ; CSSN(IBA) - Starting Column Position for the 'SSN' Column
  1. ; CLVDAT(IBA) - Starting Column Position for the 'Last VC' Column
  1. ; CLVBY(IBA) - Starting Column Position for the 'VC By' Column
  1. ; IBPAGE - Current Page Number
  1. ; MAXRPT(IBA) - Maximum number of characters in column header line
  1. ; Output: IBPAGE - Updated Page Number
  1. ;
  1. ; IB*2.0*549 changed include Appoint Date filtering and
  1. ; dynamic column width based on actual data sizes
  1. I IBEXCEL D I 1
  1. . I +IBPAGE>0 Q ;IB*752/DTG correct header
  1. . D PGHD(0)
  1. . W !,"Patient Name^SSN^Insurance Co.^Group No.^Last VC^VC By^Last Apt^DoD"
  1. ;IB*752/DTG remove excel else
  1. ;E D
  1. I 'IBEXCEL D
  1. . S IBPAGE=IBPAGE+1
  1. . D PGHD(IBPAGE)
  1. . W !!,"Patient Name",?CSSN(IBA),"SSN",?CINS(IBA),"Insurance Co.",?CGRP(IBA),"Group No."
  1. . I IBA=1 W ?CLVDAT(IBA),"Last VC",?CLVBY(IBA),"VC By"
  1. . W ?CAPPT(IBA),"Last Apt",?CDOD(IBA),"DoD"
  1. . W !
  1. . F IBX=1:1:MAXRPT(IBA) W "="
  1. Q
  1. ;
  1. PGHD(IBPAGE) ; Print Report Page Header
  1. ; Input: IBPAGE - Current Page Number, 0 if exporting to Excel
  1. ; IBAIB - 1 Sorting by Patient Name, 2 - Sorting by Terminal Digit
  1. ; IBAPPTE - Internal Appointment Date Range End
  1. ; 0 if no Appointment Date Range filter
  1. ; IBAPPTS - Internal Appointment Date Range Start
  1. ; 0 if no Appointment Date Range filter
  1. ; IBBDT - Internal Verification Start date for Verification filter
  1. ; Null if no Verification filter
  1. ; IBEDT - Internal Verification End date for Verification filter
  1. ; Null if no Verification filter
  1. ; IB*743/TAZ - Modified IBRF to note NULL starts with the beginning of the list.
  1. ; IBRF - "" - First Patient Name, otherwise start of range filter
  1. ; IBRL - End of range filter
  1. ;
  1. N IBHDT
  1. S IBHDT=$$FMTE^XLFDT($$NOW^XLFDT,"Z")
  1. W:IBPAGE @IOF
  1. W:'IBPAGE !!
  1. W "Active Policies with no Effective Date Report "
  1. ;IB*752/DTG correct header for excel
  1. I IBEXCEL D Q
  1. . W " Run On: ",IBHDT
  1. . W !,"Filtered by: " ;IB*752/DTG - change sort to filter
  1. . W " Range: "_$S(IBRF="":"FIRST",1:IBRF)_" to "_$S(IBRL="zzzzzz":"LAST",1:IBRL)
  1. . I IBBDT>0 D
  1. . . W !,"Include: Verification Date Range: "_$$FMTE^XLFDT(IBBDT,"Z")
  1. . . W " to "_$$FMTE^XLFDT(IBEDT,"Z")
  1. . I IBAPPTS>0 D
  1. . . W !,"Include: Last Appointment Date Range: "_$$FMTE^XLFDT(IBAPPTS,"Z")
  1. . . W " to "_$$FMTE^XLFDT(IBAPPTE,"Z")
  1. . W !,"Filter: "
  1. . W $S(IBPTYPE=1:"Living Patients",IBPTYPE=2:"Deceased Patients",1:"Both Living & Deceased Patients")
  1. . W ", "_$S(IBSIN=1:"Verified Policies",IBSIN=2:"Non-Verified Policies",1:"Both Verified & Non-Verified Policies")
  1. ;E D
  1. ;. W ?IOM-34,IBHDT,?IOM-10,"Page: ",IBPAGE
  1. W ?IOM-34,IBHDT,?IOM-10,"Page: ",IBPAGE
  1. ;I IBPAGE W !,?5,"Filtered by: " ;IB*752/DTG - change sort to filter
  1. W !,?5,"Filtered by: " ;IB*752/DTG - change sort to filter
  1. ;E W !,?6,"Contains: "
  1. W $S(IBAIB=1:"Patient Name",1:"Terminal Digit")
  1. ;IB*743/TAZ - Modified Check on IBRF.
  1. ;W " Range: "_$S(IBRF="A":"FIRST",1:IBRF)_" to "_$S(IBRL="zzzzzz":"LAST",1:IBRL)
  1. W " Range: "_$S(IBRF="":"FIRST",1:IBRF)_" to "_$S(IBRL="zzzzzz":"LAST",1:IBRL)
  1. I IBBDT>0 D
  1. . W !,?7,"Include: Verification Date Range: "_$$FMTE^XLFDT(IBBDT,"Z")
  1. . W " to "_$$FMTE^XLFDT(IBEDT,"Z")
  1. I IBAPPTS>0 D
  1. . W !,?7,"Include: Last Appointment Date Range: "_$$FMTE^XLFDT(IBAPPTS,"Z")
  1. . W " to "_$$FMTE^XLFDT(IBAPPTE,"Z")
  1. W !,?8,"Filter: "_$S(IBPTYPE=1:"Living Patients",IBPTYPE=2:"Deceased Patients",1:"Both Living & Deceased Patients")
  1. W ", "_$S(IBSIN=1:"Verified Policies",IBSIN=2:"Non-Verified Policies",1:"Both Verified & Non-Verified Policies")
  1. Q
  1. ;
  1. WRT ; Write data lines
  1. N IBA,IBCDA,IBDA,IBFIRST,IBDFN,IBINS,IBLS,IBNA,IBPOL,IBPT,X,Y
  1. S IBQUIT=0,IBFIRST=1,IBLS="" ;IB*752/DTG added in IBLS for track of IBA change
  1. S IBA=0 F S IBA=$O(^TMP("IBCOMA",$J,IBA)) Q:('IBA)!(IBQUIT=1) D
  1. . I IBPAGE D ASK^IBCOMC2 I IBQUIT=1 Q
  1. . ;IB*752/DTG change for proper excel header
  1. . ;I IBEXCEL,IBFIRST D
  1. . ;. D HD(IBA)
  1. . ;. S IBFIRST=0
  1. . I IBEXCEL D
  1. . . I IBFIRST D
  1. . . . D HD(IBA)
  1. . . . S IBFIRST=0
  1. . ;
  1. . I 'IBEXCEL D
  1. . . D HD(IBA)
  1. . . W !,$S(IBA=1:"Verified",1:"Non-Verified"),!
  1. . S IBNA="" F S IBNA=$O(^TMP("IBCOMA",$J,IBA,IBNA)) Q:(IBNA="")!(IBQUIT=1) D
  1. . . S IBDFN=0 F S IBDFN=$O(^TMP("IBCOMA",$J,IBA,IBNA,IBDFN)) Q:('IBDFN)!(IBQUIT=1) D
  1. . . . S IBPT=$G(^TMP("IBCOMA",$J,IBA,IBNA,IBDFN))
  1. . . . ;
  1. . . . I 'IBEXCEL,($Y+7)>IOSL D I IBQUIT=1 Q
  1. . . . . D ASK^IBCOMC2 I IBQUIT=1 Q
  1. . . . . D HD(IBA)
  1. . . . ;
  1. . . . S IBDA=0 F S IBDA=$O(^TMP("IBCOMA",$J,IBA,IBNA,IBDFN,IBDA)) Q:('IBDA)!(IBQUIT=1) D
  1. . . . . S IBINS=$G(^TMP("IBCOMA",$J,IBA,IBNA,IBDFN,IBDA))
  1. . . . . ;
  1. . . . . S IBCDA=0 F S IBCDA=$O(^TMP("IBCOMA",$J,IBA,IBNA,IBDFN,IBDA,IBCDA)) Q:('IBCDA)!(IBQUIT=1) D
  1. . . . . . S IBPOL=$G(^TMP("IBCOMA",$J,IBA,IBNA,IBDFN,IBDA,IBCDA))
  1. . . . . . ;IB*752/DTG correct if and else to if's
  1. . . . . . ;I IBEXCEL D I 1
  1. . . . . . I IBEXCEL D
  1. . . . . . . W !,$P(IBPT,U,1),U,$P(IBPT,U,2),U,$P(IBINS,U,1),U,$P(IBPOL,U,3),U
  1. . . . . . . I $P(IBPOL,U,1)'=0 W $P(IBPOL,U,1)
  1. . . . . . . W U_$P(IBPOL,U,2)_U
  1. . . . . . . W $P(IBPT,U,4),U,$P(IBPT,U,3)
  1. . . . . . ;E D
  1. . . . . . I 'IBEXCEL D
  1. . . . . . . W !,$E($P(IBPT,U,1),1,MAXPT(IBA)),?CSSN(IBA),$P(IBPT,U,2),?CINS(IBA)
  1. . . . . . . W $E($P(IBINS,U,1),1,MAXINS(IBA)),?CGRP(IBA),$E($P(IBPOL,U,3),1,MAXGRP(IBA))
  1. . . . . . . I IBA=1 W ?CLVDAT(IBA),$P(IBPOL,U,1),?CLVBY(IBA),$E($P(IBPOL,U,2),1,MAXVERBY(IBA))
  1. . . . . . . W ?CAPPT(IBA),$P(IBPT,U,4),?CDOD(IBA),$P(IBPT,U,3)
  1. Q
  1. ;
  1. SETMAX(NAME,MAX,IBI) ; Get max length of data
  1. ; Input: NAME - Data to get maximum length for
  1. ; MAX(IBI)- Current Max length array
  1. ; IBI - Verified or Non-Verified section of the array
  1. ; Output MAX(IBI)- Updated Max length array (potentially)
  1. N LEN
  1. S LEN=$L(NAME)
  1. I LEN>MAX(IBI) S MAX(IBI)=LEN
  1. Q
  1. ;
  1. CALCCOLS ; Truncates the patient and insurance name field lengths if the total
  1. ; field lengths will not fit on the report (132 columns)
  1. ; Input: MAXGRP(IBA) - Maximum width of the 'Group No' column for
  1. ; verified (IBA=1) and non-verified (IBA=2) policies
  1. ; MAXINS(IBA) - Current Maximum width of the 'Insurance Co' column for
  1. ; verified (IBA=1) and non-verified (IBA=2) policies
  1. ; MAXPT(IBA) - Current Maximum width of the 'Patient Name' column for
  1. ; verified (IBA=1) and non-verified (IBA=2) policies
  1. ; MAXVERBY(IBA) - Maximum width of the 'VC By' column for
  1. ; verified (IBA=1) policies
  1. ; Output: MAXINS(IBA) - Updated Maximum width of the 'Insurance Co' column for
  1. ; verified (IBA=1) and non-verified (IBA=2) policies
  1. ; MAXPT(IBA) - Updated Maximum width of the 'Patient Name' column for
  1. ; verified (IBA=1) and non-verified (IBA=2) policies
  1. N DIFF,DIFF2,DIFF3,IDX,MAX
  1. S MAX(1)=89 ; MAX=131 - SSN(4) - 3 Dates(24) - 14 (Spaces between columns)
  1. S MAX(2)=101 ; MAX=131 - SSN(4) - 2 Dates(16) - 10 (Spaces between columns)
  1. F IDX=1:1:2 D
  1. . S DIFF=MAX(IDX)-MAXPT(IDX)-MAXINS(IDX)-MAXGRP(IDX)
  1. . I IDX=1 S DIFF=DIFF-MAXVERBY(IDX)
  1. . I DIFF<0 D
  1. . . S DIFF2=(-DIFF)\2
  1. . . S DIFF3=(-DIFF)-DIFF2
  1. . . S MAXPT(IDX)=MAXPT(IDX)-DIFF2
  1. . . S MAXINS(IDX)=MAXINS(IDX)-DIFF3
  1. . D SETCOLS(IDX)
  1. Q
  1. ;
  1. SETCOLS(IDX) ; Sets the column positions based on maximum data sizes
  1. ; Input: IDX - 1 - Verified policies section of the report
  1. ; 2 - Non-Verified policies section of the report
  1. ; MAXGRP(IBA) - Maximum width of the 'Group No' column for
  1. ; verified (IBA=1) and non-verified (IBA=2) policies
  1. ; MAXINS(IBA) - Maximum width of the 'Insurance Co' column for
  1. ; verified (IBA=1) and non-verified (IBA=2) policies
  1. ; MAXPT(IBA) - Maximum width of the 'Patient Name' column for
  1. ; verified (IBA=1) and non-verified (IBA=2) policies
  1. ; MAXVERBY(IBA) - Maximum width of the 'VC By' column for
  1. ; verified (IBA=1) policies
  1. ; Output: CAPPT(IDX) - Starting Column position for the 'Last Apt'
  1. ; Column for Verified and Non-Verified policies
  1. ; CDOD(IDX) - Starting Column position for the 'DoD'
  1. ; Column for Verified and Non-Verified policies
  1. ; CGRP(IDX) - Starting Column position for the 'Group No'
  1. ; Column for Verified and Non-Verified policies
  1. ; CINS(IDX) - Starting Column position for the 'Insurance Co.'
  1. ; Column for Verified and Non-Verified policies
  1. ; CLVBY(IDX) - Starting Column position for the 'VC By'
  1. ; Column for Verified and Non-Verified policies
  1. ; CLVDAT(IDX) - Starting Column position for the 'Last VC'
  1. ; Column for Verified and Non-Verified policies
  1. ; CSSN(IDX) - Starting Column position for the 'SSN'
  1. ; Column for Verified and Non-Verified policies
  1. S CSSN(IDX)=MAXPT(IDX)+2
  1. S CINS(IDX)=CSSN(IDX)+6
  1. S CGRP(IDX)=CINS(IDX)+MAXINS(IDX)+2
  1. I IDX=1 D
  1. . S CLVDAT(IDX)=CGRP(IDX)+MAXGRP(IDX)+2
  1. . S CLVBY(IDX)=CLVDAT(IDX)+10
  1. . S CAPPT(IDX)=CLVBY(IDX)+MAXVERBY(IDX)+2
  1. E S CAPPT(IDX)=CGRP(IDX)+MAXGRP(IDX)+2
  1. S CDOD(IDX)=CAPPT(IDX)+10
  1. S MAXRPT(IDX)=CDOD(IDX)+8
  1. Q
  1. ;IBCOMA1