- IBARXEPS ;ALB/RM/PHH,EG - RX COPAY EXEMPTION UPDATE STATUS ; 12/13/2005
- ;;2.0;INTEGRATED BILLING;**321**; 21-MAR-94
- ;;Per VHA Directive 10-93-142, this routine should not be modified.
- ;
- ; This routine was copied/modified from IBARXEPV.
- ;
- Q
- POST ; Entry point from TaskMan
- I '$D(DT) D
- .N %,%H,%I,X,DT
- .D NOW^%DTC
- .S DT=X
- N NAMESPC
- S NAMESPC=$$NAMESPC()
- D UPDT($E(DT,1,3)_"0101",DT,1)
- K ^XTMP(NAMESPC,"RUNNING")
- Q
- START ;Entry Point from post-install
- N QTIME,X,NAMESPC
- S NAMESPC=$$NAMESPC()
- Q:$$RUNCHK(NAMESPC) ; Quit if already running or has run to completion
- K ^XTMP(NAMESPC)
- S X=$$QTIME(.QTIME)
- S ^XTMP(NAMESPC,"USER")=$S($G(DUZ)'="":DUZ,1:"UNKNOWN")
- S:'$$QUEUE(QTIME) ^XTMP(NAMESPC,"RUNNING")=""
- Q
- NAMESPC() ; API returns the name space for this patch
- Q "IBARXEPS"
- RUNCHK(NAMESPC) ; Check to see if clean up is already running
- Q:NAMESPC="" 1 ; Name Space must be defined
- Q:$D(^XTMP(NAMESPC,"RUNNING")) 1
- Q 0
- QTIME(WHEN) ; Get the run time for queuing
- N %,%H,%I,X
- D NOW^%DTC
- S WHEN=$P(%,".")_"."_$E($P(%,".",2),1,4)
- Q 0
- QUEUE(ZTDTH) ; Queue the process
- N NAMESPC,QUEERR,ZTDESC,ZTRTN,ZTSK
- S NAMESPC=$$NAMESPC
- S QUEERR=0
- S ZTRTN="POST^IBARXEPS"
- S ZTDESC=NAMESPC_" - RX COPAY EXEMPTION UPDATE STATUS"
- S ZTIO=""
- D ^%ZTLOAD
- K ^XTMP(NAMESPC,"ZTSK")
- I '$D(ZTSK) S ^XTMP(NAMESPC,"ZTSK")="Unable to queue post-install process.",QUEERR=1
- I $D(ZTSK) D
- . S ^XTMP(NAMESPC,"ZTSK")="Post-install queued. Task ID: "_$G(ZTSK)
- . D MES^XPDUTL(" This request queued as Task # "_ZTSK)
- . D MES^XPDUTL("")
- . Q
- Q QUEERR
- ;
- UPDT(IBBDT,IBEDT,IBUP) ;
- ; IBBDT - Beginning Date for the process
- ; IBEDT - Ending Date for the process
- ; IBUP - Update mode (1 - Update, 0 - Report only)
- ;
- ; All three input parameters are required
- I 'IBBDT!('IBEDT)!(IBEDT<IBBDT) Q
- ;
- ; Entry point to start comparison
- N IBJOB,IBWHER,%
- S (IBPCNT,IBPAG)=0,IBOK=1 D NOW^%DTC S Y=% D D^DIQ
- S IBPDAT=$P(Y,"@")_" "_$E($P(Y,"@",2),1,5)
- K ^TMP($J,"IBUNVER")
- ;
- ; Look through EFFECTIVE DATE x-ref in BILLING EXEMPTIONS File #354.1
- S IBDT=IBBDT-.00001
- F S IBDT=$O(^IBA(354.1,"B",IBDT)) Q:'IBDT!(IBDT>(IBEDT+.9)) D
- .S IBDA=0 F S IBDA=$O(^IBA(354.1,"B",IBDT,IBDA)) Q:'IBDA D
- ..D CHK I 'IBOK D UP:IBUP,SET
- D REPORT
- ;
- K ^TMP($J,"IBUNVER")
- K DFN,DIR,DIRUT,DIC,DIE,DA,DR,X,Y
- K IBBDT,IBDA,IBDATA,IBDEPEN,IBDFN,IBDT,IBEDT,IBER,IBERR,IBEXREA,IBEXREAN,IBEXREAO,IBJ,IBMESS,IBNAM,IBOK,IBP,IBPAG,IBPCNT,IBPDAT,IBQUIT,IBUP
- Q
- ;
- CHK ; Check if current status = computed status
- S IBOK=1,IBMESS="Nothing Updated",IBERR=""
- S X=$G(^IBA(354.1,+IBDA,0)) G CHKQ:'$P(X,"^",10) ;not active skip
- S DFN=$P(X,"^",2)
- S Y=$G(^IBA(354,DFN,0)) I +X<$P(Y,"^",3) G CHKQ ;not current exemption
- ;
- N DGMT,CONV,CLN S (CLN,CONV)=0,DGMT=$$LST^DGMTU(DFN,+X,1)
- I $P(DGMT,U,5)=2 D G:CONV CHKQ ; skip Edb conv. tests
- .; Loop through the MT comments, Check for EDB converted test
- .; No comments to check
- .Q:'$D(^DGMT(408.31,+DGMT,"C",1,0))
- .F S CLN=$O(^DGMT(408.31,+DGMT,"C",CLN)) Q:'CLN!(CONV) D
- ..I ^DGMT(408.31,+DGMT,"C",CLN,0)["Z06 MT via Edb" S CONV=1
- ;
- S IBPCNT=IBPCNT+1
- I '+Y S IBOK=0,IBERR=4
- S IBEXREAO=$P(X,"^",5)_"^"_+X ;current exemption
- I $P($G(^IBE(354.2,+IBEXREAO,0)),"^",5)=2010 G CHKQ ; hardships don't report
- I +X>$P(Y,"^",3) S IBOK=0,IBERR=1 ;most current exemption not in 354
- I $P(X,"^",5)'=$P(Y,"^",5) S IBOK=0,IBERR=2 ;Current exemption not in 354
- I $P(X,"^",4)'=$P(Y,"^",4) S IBOK=0,IBERR=5 ;current status in exemption not in 354
- S IBEXREAN=$$STATUS^IBARXEU1(DFN,DT)
- I +IBEXREAO'=+IBEXREAN S IBOK=0,IBERR=3
- CHKQ Q
- ;
- UP ; -- update current exemption status
- Q:IBOK
- S IBJOB=15,IBWHER=16
- I IBERR=4 D G UPQ
- .S DIE="^IBA(354,",DA=DFN,DR=".01////"_DFN D ^DIE
- .K DIE,DA,DR,DIC
- .S IBMESS="Name Corrected"
- UP1 N IBOLDAUT S IBOLDAUT=""
- ;
- ; -- if currently not auto exempt make sure not more recent auto exempt
- I $L($P($G(^IBE(354.2,+IBEXREAN,0)),"^",5))>2 D OLDAUT^IBARXEX1(IBEXREAN)
- S IBFORCE=$P(IBEXREAN,"^",2)
- D MOSTR^IBARXEU5($P(IBEXREAN,"^",2),+IBEXREAN)
- D ADDEX^IBAUTL6(+IBEXREAN,$P(IBEXREAN,"^",2),1,1,IBOLDAUT)
- S IBMESS="Updated"
- UPQ K IBFORCE Q
- ;
- SET ; Set ^tmp node if not okay
- Q:IBOK
- S IBP=$$PT^IBEFUNC(DFN)
- S IBDFN=DFN
- I $D(^TMP($J,"IBUNVER",$P(IBP,"^"),DFN)) S IBDFN=DFN_"-"_IBPCNT
- S ^TMP($J,"IBUNVER",$P(IBP,"^"),IBDFN)=IBEXREAO_"^"_IBEXREAN_"^"_IBERR_"^"_IBMESS_"^"_IBP
- Q
- ;
- REPORT ; Send MailMan recap report of updated records
- N IBMGRP,XMDUZ,XMTEXT,XMY,XMSUB,LNCNT,IBPDAT,IBDCNT,MSG,TXT,EXRSN,XMDUZ
- S IBMGRP=$$GET1^DIQ(350.9,1,.13)
- Q:IBMGRP=""
- S IBMGRP=$O(^XMB(3.8,"B",IBMGRP,""))
- Q:'IBMGRP
- D XMY^DGMTUTL(IBMGRP,0,1)
- S XMDUZ="IB PACKAGE",XMTEXT="MSG(",LNCNT=1,IBDCNT=0
- S XMY(DUZ)="",XMSUB="IB RX COPAY EXEMPT UPDATE"
- D NOW^%DTC S Y=% D D^DIQ S IBPDAT=$P(Y,"@")_" "_$E($P(Y,"@",2),1,5)
- S MSG(LNCNT)=" Medication Copayment Exemption Problem Report "_IBPDAT
- S LNCNT=LNCNT+1,MSG(LNCNT)=" "
- S TXT="Patient PT. ID Error Current/Calc Exemption"
- S LNCNT=LNCNT+1,MSG(LNCNT)=TXT
- S LNCNT=LNCNT+1,MSG(LNCNT)=$TR($J(" ",78)," ","-")
- D EXRSN
- S IBNAM="" F S IBNAM=$O(^TMP($J,"IBUNVER",IBNAM)) Q:IBNAM="" D
- .S IBDFN="" F S IBDFN=$O(^TMP($J,"IBUNVER",IBNAM,IBDFN)) Q:IBDFN="" D
- ..S IBER=^(IBDFN) D MSGLN(IBNAM,IBER)
- ;
- I $D(^TMP($J,"IBUNVER")) D
- .S LNCNT=LNCNT+1,MSG(LNCNT)=" "
- .S LNCNT=LNCNT+1,MSG(LNCNT)="There were "_IBDCNT_" discrepancies found in "_IBPCNT_" exemptions checked."
- I '$D(^TMP($J,"IBUNVER")) S LNCNT=LNCNT+1,MSG(LNCNT)=" No discrepancies found in "_IBPCNT_" exemptions checked."
- D ^XMD
- REPORTQ Q
- ;
- MSGLN(IBNAM,IBER) ; Create the body of the report
- N IBSSN,IBCURX,IBCALX,RECORD
- S IBNAM=$E(IBNAM,1,20),IBDCNT=IBDCNT+1
- S IBSSN=$P(IBER,U,8)
- S X=$P(IBER,U,5),X=$E($S(X=3:"Incorr Exmpt",X=1!(X=2)!(X=5):"Not Curr Stat",X=4:"Name Missing",1:"Hmmmm"),1,13)
- S IBCURX=EXRSN($P(IBER,U))
- S IBCALX=EXRSN($P(IBER,U,3))
- S RECORD=$$LJ^XLFSTR(IBNAM,22," ")_IBSSN_" "_$$LJ^XLFSTR(X,15," ")_IBCURX_"/"_IBCALX
- S LNCNT=LNCNT+1,MSG(LNCNT)=RECORD
- Q
- ;
- EXRSN ; Exempt Reason Array for MailMan Message
- N IBIEN S IBIEN=0
- F S IBIEN=$O(^IBE(354.2,IBIEN)) Q:'IBIEN S EXRSN(IBIEN)=$E($P(^IBE(354.2,IBIEN,0),U),1,15)
- Q
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBARXEPS 6328 printed Jan 18, 2025@03:08:32 Page 2
- IBARXEPS ;ALB/RM/PHH,EG - RX COPAY EXEMPTION UPDATE STATUS ; 12/13/2005
- +1 ;;2.0;INTEGRATED BILLING;**321**; 21-MAR-94
- +2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
- +3 ;
- +4 ; This routine was copied/modified from IBARXEPV.
- +5 ;
- +6 QUIT
- POST ; Entry point from TaskMan
- +1 IF '$DATA(DT)
- Begin DoDot:1
- +2 NEW %,%H,%I,X,DT
- +3 DO NOW^%DTC
- +4 SET DT=X
- End DoDot:1
- +5 NEW NAMESPC
- +6 SET NAMESPC=$$NAMESPC()
- +7 DO UPDT($EXTRACT(DT,1,3)_"0101",DT,1)
- +8 KILL ^XTMP(NAMESPC,"RUNNING")
- +9 QUIT
- START ;Entry Point from post-install
- +1 NEW QTIME,X,NAMESPC
- +2 SET NAMESPC=$$NAMESPC()
- +3 ; Quit if already running or has run to completion
- if $$RUNCHK(NAMESPC)
- QUIT
- +4 KILL ^XTMP(NAMESPC)
- +5 SET X=$$QTIME(.QTIME)
- +6 SET ^XTMP(NAMESPC,"USER")=$SELECT($GET(DUZ)'="":DUZ,1:"UNKNOWN")
- +7 if '$$QUEUE(QTIME)
- SET ^XTMP(NAMESPC,"RUNNING")=""
- +8 QUIT
- NAMESPC() ; API returns the name space for this patch
- +1 QUIT "IBARXEPS"
- RUNCHK(NAMESPC) ; Check to see if clean up is already running
- +1 ; Name Space must be defined
- if NAMESPC=""
- QUIT 1
- +2 if $DATA(^XTMP(NAMESPC,"RUNNING"))
- QUIT 1
- +3 QUIT 0
- QTIME(WHEN) ; Get the run time for queuing
- +1 NEW %,%H,%I,X
- +2 DO NOW^%DTC
- +3 SET WHEN=$PIECE(%,".")_"."_$EXTRACT($PIECE(%,".",2),1,4)
- +4 QUIT 0
- QUEUE(ZTDTH) ; Queue the process
- +1 NEW NAMESPC,QUEERR,ZTDESC,ZTRTN,ZTSK
- +2 SET NAMESPC=$$NAMESPC
- +3 SET QUEERR=0
- +4 SET ZTRTN="POST^IBARXEPS"
- +5 SET ZTDESC=NAMESPC_" - RX COPAY EXEMPTION UPDATE STATUS"
- +6 SET ZTIO=""
- +7 DO ^%ZTLOAD
- +8 KILL ^XTMP(NAMESPC,"ZTSK")
- +9 IF '$DATA(ZTSK)
- SET ^XTMP(NAMESPC,"ZTSK")="Unable to queue post-install process."
- SET QUEERR=1
- +10 IF $DATA(ZTSK)
- Begin DoDot:1
- +11 SET ^XTMP(NAMESPC,"ZTSK")="Post-install queued. Task ID: "_$GET(ZTSK)
- +12 DO MES^XPDUTL(" This request queued as Task # "_ZTSK)
- +13 DO MES^XPDUTL("")
- +14 QUIT
- End DoDot:1
- +15 QUIT QUEERR
- +16 ;
- UPDT(IBBDT,IBEDT,IBUP) ;
- +1 ; IBBDT - Beginning Date for the process
- +2 ; IBEDT - Ending Date for the process
- +3 ; IBUP - Update mode (1 - Update, 0 - Report only)
- +4 ;
- +5 ; All three input parameters are required
- +6 IF 'IBBDT!('IBEDT)!(IBEDT<IBBDT)
- QUIT
- +7 ;
- +8 ; Entry point to start comparison
- +9 NEW IBJOB,IBWHER,%
- +10 SET (IBPCNT,IBPAG)=0
- SET IBOK=1
- DO NOW^%DTC
- SET Y=%
- DO D^DIQ
- +11 SET IBPDAT=$PIECE(Y,"@")_" "_$EXTRACT($PIECE(Y,"@",2),1,5)
- +12 KILL ^TMP($JOB,"IBUNVER")
- +13 ;
- +14 ; Look through EFFECTIVE DATE x-ref in BILLING EXEMPTIONS File #354.1
- +15 SET IBDT=IBBDT-.00001
- +16 FOR
- SET IBDT=$ORDER(^IBA(354.1,"B",IBDT))
- if 'IBDT!(IBDT>(IBEDT+.9))
- QUIT
- Begin DoDot:1
- +17 SET IBDA=0
- FOR
- SET IBDA=$ORDER(^IBA(354.1,"B",IBDT,IBDA))
- if 'IBDA
- QUIT
- Begin DoDot:2
- +18 DO CHK
- IF 'IBOK
- if IBUP
- DO UP
- DO SET
- End DoDot:2
- End DoDot:1
- +19 DO REPORT
- +20 ;
- +21 KILL ^TMP($JOB,"IBUNVER")
- +22 KILL DFN,DIR,DIRUT,DIC,DIE,DA,DR,X,Y
- +23 KILL IBBDT,IBDA,IBDATA,IBDEPEN,IBDFN,IBDT,IBEDT,IBER,IBERR,IBEXREA,IBEXREAN,IBEXREAO,IBJ,IBMESS,IBNAM,IBOK,IBP,IBPAG,IBPCNT,IBPDAT,IBQUIT,IBUP
- +24 QUIT
- +25 ;
- CHK ; Check if current status = computed status
- +1 SET IBOK=1
- SET IBMESS="Nothing Updated"
- SET IBERR=""
- +2 ;not active skip
- SET X=$GET(^IBA(354.1,+IBDA,0))
- if '$PIECE(X,"^",10)
- GOTO CHKQ
- +3 SET DFN=$PIECE(X,"^",2)
- +4 ;not current exemption
- SET Y=$GET(^IBA(354,DFN,0))
- IF +X<$PIECE(Y,"^",3)
- GOTO CHKQ
- +5 ;
- +6 NEW DGMT,CONV,CLN
- SET (CLN,CONV)=0
- SET DGMT=$$LST^DGMTU(DFN,+X,1)
- +7 ; skip Edb conv. tests
- IF $PIECE(DGMT,U,5)=2
- Begin DoDot:1
- +8 ; Loop through the MT comments, Check for EDB converted test
- +9 ; No comments to check
- +10 if '$DATA(^DGMT(408.31,+DGMT,"C",1,0))
- QUIT
- +11 FOR
- SET CLN=$ORDER(^DGMT(408.31,+DGMT,"C",CLN))
- if 'CLN!(CONV)
- QUIT
- Begin DoDot:2
- +12 IF ^DGMT(408.31,+DGMT,"C",CLN,0)["Z06 MT via Edb"
- SET CONV=1
- End DoDot:2
- End DoDot:1
- if CONV
- GOTO CHKQ
- +13 ;
- +14 SET IBPCNT=IBPCNT+1
- +15 IF '+Y
- SET IBOK=0
- SET IBERR=4
- +16 ;current exemption
- SET IBEXREAO=$PIECE(X,"^",5)_"^"_+X
- +17 ; hardships don't report
- IF $PIECE($GET(^IBE(354.2,+IBEXREAO,0)),"^",5)=2010
- GOTO CHKQ
- +18 ;most current exemption not in 354
- IF +X>$PIECE(Y,"^",3)
- SET IBOK=0
- SET IBERR=1
- +19 ;Current exemption not in 354
- IF $PIECE(X,"^",5)'=$PIECE(Y,"^",5)
- SET IBOK=0
- SET IBERR=2
- +20 ;current status in exemption not in 354
- IF $PIECE(X,"^",4)'=$PIECE(Y,"^",4)
- SET IBOK=0
- SET IBERR=5
- +21 SET IBEXREAN=$$STATUS^IBARXEU1(DFN,DT)
- +22 IF +IBEXREAO'=+IBEXREAN
- SET IBOK=0
- SET IBERR=3
- CHKQ QUIT
- +1 ;
- UP ; -- update current exemption status
- +1 if IBOK
- QUIT
- +2 SET IBJOB=15
- SET IBWHER=16
- +3 IF IBERR=4
- Begin DoDot:1
- +4 SET DIE="^IBA(354,"
- SET DA=DFN
- SET DR=".01////"_DFN
- DO ^DIE
- +5 KILL DIE,DA,DR,DIC
- +6 SET IBMESS="Name Corrected"
- End DoDot:1
- GOTO UPQ
- UP1 NEW IBOLDAUT
- SET IBOLDAUT=""
- +1 ;
- +2 ; -- if currently not auto exempt make sure not more recent auto exempt
- +3 IF $LENGTH($PIECE($GET(^IBE(354.2,+IBEXREAN,0)),"^",5))>2
- DO OLDAUT^IBARXEX1(IBEXREAN)
- +4 SET IBFORCE=$PIECE(IBEXREAN,"^",2)
- +5 DO MOSTR^IBARXEU5($PIECE(IBEXREAN,"^",2),+IBEXREAN)
- +6 DO ADDEX^IBAUTL6(+IBEXREAN,$PIECE(IBEXREAN,"^",2),1,1,IBOLDAUT)
- +7 SET IBMESS="Updated"
- UPQ KILL IBFORCE
- QUIT
- +1 ;
- SET ; Set ^tmp node if not okay
- +1 if IBOK
- QUIT
- +2 SET IBP=$$PT^IBEFUNC(DFN)
- +3 SET IBDFN=DFN
- +4 IF $DATA(^TMP($JOB,"IBUNVER",$PIECE(IBP,"^"),DFN))
- SET IBDFN=DFN_"-"_IBPCNT
- +5 SET ^TMP($JOB,"IBUNVER",$PIECE(IBP,"^"),IBDFN)=IBEXREAO_"^"_IBEXREAN_"^"_IBERR_"^"_IBMESS_"^"_IBP
- +6 QUIT
- +7 ;
- REPORT ; Send MailMan recap report of updated records
- +1 NEW IBMGRP,XMDUZ,XMTEXT,XMY,XMSUB,LNCNT,IBPDAT,IBDCNT,MSG,TXT,EXRSN,XMDUZ
- +2 SET IBMGRP=$$GET1^DIQ(350.9,1,.13)
- +3 if IBMGRP=""
- QUIT
- +4 SET IBMGRP=$ORDER(^XMB(3.8,"B",IBMGRP,""))
- +5 if 'IBMGRP
- QUIT
- +6 DO XMY^DGMTUTL(IBMGRP,0,1)
- +7 SET XMDUZ="IB PACKAGE"
- SET XMTEXT="MSG("
- SET LNCNT=1
- SET IBDCNT=0
- +8 SET XMY(DUZ)=""
- SET XMSUB="IB RX COPAY EXEMPT UPDATE"
- +9 DO NOW^%DTC
- SET Y=%
- DO D^DIQ
- SET IBPDAT=$PIECE(Y,"@")_" "_$EXTRACT($PIECE(Y,"@",2),1,5)
- +10 SET MSG(LNCNT)=" Medication Copayment Exemption Problem Report "_IBPDAT
- +11 SET LNCNT=LNCNT+1
- SET MSG(LNCNT)=" "
- +12 SET TXT="Patient PT. ID Error Current/Calc Exemption"
- +13 SET LNCNT=LNCNT+1
- SET MSG(LNCNT)=TXT
- +14 SET LNCNT=LNCNT+1
- SET MSG(LNCNT)=$TRANSLATE($JUSTIFY(" ",78)," ","-")
- +15 DO EXRSN
- +16 SET IBNAM=""
- FOR
- SET IBNAM=$ORDER(^TMP($JOB,"IBUNVER",IBNAM))
- if IBNAM=""
- QUIT
- Begin DoDot:1
- +17 SET IBDFN=""
- FOR
- SET IBDFN=$ORDER(^TMP($JOB,"IBUNVER",IBNAM,IBDFN))
- if IBDFN=""
- QUIT
- Begin DoDot:2
- +18 SET IBER=^(IBDFN)
- DO MSGLN(IBNAM,IBER)
- End DoDot:2
- End DoDot:1
- +19 ;
- +20 IF $DATA(^TMP($JOB,"IBUNVER"))
- Begin DoDot:1
- +21 SET LNCNT=LNCNT+1
- SET MSG(LNCNT)=" "
- +22 SET LNCNT=LNCNT+1
- SET MSG(LNCNT)="There were "_IBDCNT_" discrepancies found in "_IBPCNT_" exemptions checked."
- End DoDot:1
- +23 IF '$DATA(^TMP($JOB,"IBUNVER"))
- SET LNCNT=LNCNT+1
- SET MSG(LNCNT)=" No discrepancies found in "_IBPCNT_" exemptions checked."
- +24 DO ^XMD
- REPORTQ QUIT
- +1 ;
- MSGLN(IBNAM,IBER) ; Create the body of the report
- +1 NEW IBSSN,IBCURX,IBCALX,RECORD
- +2 SET IBNAM=$EXTRACT(IBNAM,1,20)
- SET IBDCNT=IBDCNT+1
- +3 SET IBSSN=$PIECE(IBER,U,8)
- +4 SET X=$PIECE(IBER,U,5)
- SET X=$EXTRACT($SELECT(X=3:"Incorr Exmpt",X=1!(X=2)!(X=5):"Not Curr Stat",X=4:"Name Missing",1:"Hmmmm"),1,13)
- +5 SET IBCURX=EXRSN($PIECE(IBER,U))
- +6 SET IBCALX=EXRSN($PIECE(IBER,U,3))
- +7 SET RECORD=$$LJ^XLFSTR(IBNAM,22," ")_IBSSN_" "_$$LJ^XLFSTR(X,15," ")_IBCURX_"/"_IBCALX
- +8 SET LNCNT=LNCNT+1
- SET MSG(LNCNT)=RECORD
- +9 QUIT
- +10 ;
- EXRSN ; Exempt Reason Array for MailMan Message
- +1 NEW IBIEN
- SET IBIEN=0
- +2 FOR
- SET IBIEN=$ORDER(^IBE(354.2,IBIEN))
- if 'IBIEN
- QUIT
- SET EXRSN(IBIEN)=$EXTRACT($PIECE(^IBE(354.2,IBIEN,0),U),1,15)
- +3 QUIT
- +4 ;