IBCNES1 ;ALB/ESG/JM - eIV elig/benefit utilities ; 01/13/2016
;;2.0;INTEGRATED BILLING;**416,438,497,549,702,732**;21-MAR-94;Build 13
;;Per VA Directive 6402, this routine should not be modified.
;
Q
;
EB(IBVF,IBVIENS,IBVV,IBVSUB) ; Main Eligibility/Benefit Information
;
; IBVF = file# 2.322 or 365.02
; IBVIENS = std IENS list of internal entry numbers
; IBVV = video attributes flag
; IBVSUB = display scratch global subscript
;
N EB,EBERR,DSP,LN,COL1,COL2,ZF,ZIEN
D GETS^DIQ(IBVF,IBVIENS,".02:.13;8*;11*","IEN","EB","EBERR")
S DSP=$NA(^TMP(IBVSUB,$J,"DISP")) ; scratch global display array
S LN=+$O(@DSP@(""),-1) ; last line# used in scratch global
;
S COL1=2,COL2=40
;
S LN=LN+1
D SET(LN,1,"Eligibility/Benefit Information",,IBVV)
;
S LN=LN+1
D SET(LN,COL1,"Elig/Ben Info",$P($G(^IBE(365.011,+$G(EB(IBVF,IBVIENS,.02,"I")),0)),U,2))
D SET(.LN,COL2,"Coverage Level",$P($G(^IBE(365.012,+$G(EB(IBVF,IBVIENS,.03,"I")),0)),U,2))
;
; now loop through and display all of the dates and date qualifiers
S ZF=2.3228
I IBVF=365.02 S ZF=365.28 ; subscriber dates subfile#
I '$D(EB(ZF)) S EB(ZF,1)="" ; so the fields display once
S ZIEN="" F S ZIEN=$O(EB(ZF,ZIEN)) Q:ZIEN="" D
. N HLDT,DTYP,EXDT
. S LN=LN+1
. D SET(LN,COL1,"Date/Time Qual",$P($G(^IBE(365.026,+$G(EB(ZF,ZIEN,.03,"I")),0)),U,2))
. S HLDT=$G(EB(ZF,ZIEN,.02,"E"))
. S DTYP=$G(EB(ZF,ZIEN,.04,"E")) ;IB*2.0*549 changed "I" to "E"
. S EXDT=$S(DTYP="D8":$$DATE(HLDT),DTYP="RD8":($$DATE($P(HLDT,"-",1))_"-"_$$DATE($P(HLDT,"-",2))),1:HLDT)
. D SET(.LN,COL2,"D/T Period",EXDT)
. Q
; loop through service type codes
S ZF=2.32292
I IBVF=365.02 S ZF=365.292 ; service types subfile#
I '$D(EB(ZF)) S EB(ZF,1)="" ; so the fields display once
S ZIEN="" F S ZIEN=$O(EB(ZF,ZIEN)) Q:ZIEN="" S LN=LN+1 D SET(LN,COL1,"Service Type",$P($G(^IBE(365.013,+$G(EB(ZF,ZIEN,.01,"I")),0)),U,2))
;
S LN=LN+1
D SET(LN,COL1,"Time Period",$P($G(^IBE(365.015,+$G(EB(IBVF,IBVIENS,.07,"I")),0)),U,2))
;
S LN=LN+1
D SET(LN,COL1,"Insurance Type",$P($G(^IBE(365.014,+$G(EB(IBVF,IBVIENS,.05,"I")),0)),U,2))
;
S LN=LN+1
D SET(LN,COL1,"Plan Coverage Desc",$G(EB(IBVF,IBVIENS,.06,"E")))
;
S LN=LN+1
D SET(LN,COL1,"Benefit Amount",$G(EB(IBVF,IBVIENS,.08,"E")))
D SET(.LN,COL2,"Benefit %",$G(EB(IBVF,IBVIENS,.09,"E")))
;
S LN=LN+1
D SET(LN,COL1,"Quantity Qual",$P($G(^IBE(365.016,+$G(EB(IBVF,IBVIENS,.1,"I")),0)),U,2))
D SET(.LN,COL2,"Quantity Amount",$G(EB(IBVF,IBVIENS,.11,"E")))
;
S LN=LN+1
D SET(LN,COL1,"Auth/Certification Required",$P($G(^IBE(365.033,+$G(EB(IBVF,IBVIENS,.12,"I")),0)),U,2)) ;IB*2*497
D SET(.LN,COL2,"In-Plan-Network",$P($G(^IBE(365.033,+$G(EB(IBVF,IBVIENS,.13,"I")),0)),U,2)) ;IB*2*497
;
S LN=LN+1
D SET(LN)
;
EBX ;
Q
;
CMPI(IBVF,IBVIENS,IBVV,IBVSUB) ; Composite Medical Procedure Information
;
; IBVF = file# 2.322 or 365.02
; IBVIENS = std IENS list of internal entry numbers
; IBVV = video attributes flag
; IBVSUB = display scratch global subscript
;
N CMPI,CMPIERR,DSP,LN,COL1,COL2,PCTYP,PCODE,PCIEN,PCDESC,MODLST,FCZ,PM,ZF,ZIEN,POS,POSD,DX,DXD
D GETS^DIQ(IBVF,IBVIENS,"1.01:1.06;9*","IEN","CMPI","CMPIERR")
S DSP=$NA(^TMP(IBVSUB,$J,"DISP")) ; scratch global display array
S LN=+$O(@DSP@(""),-1) ; last line# used in scratch global
;
S COL1=2,COL2=40
;
S LN=LN+1
I '$D(CMPI) G CMPIX
D SET(LN,1,"Composite Medical Procedure Information",,IBVV)
;
; get procedure code, desc, and type information
S PCTYP=$G(CMPI(IBVF,IBVIENS,1.01,"E")) ;IB*2*497
S PCODE=$G(CMPI(IBVF,IBVIENS,1.02,"E"))
S PCIEN=0,PCDESC=""
I PCTYP="CJ"!(PCTYP="HC") D ; cpt or hcpcs procedure codes
. Q:PCODE=""
. S PCIEN=+$O(^ICPT("BA",PCODE_" ",0))
. Q:'PCIEN
. S PCDESC=$P($$CPT^IBACSV(PCIEN),U,2)
. S PCDESC=$$TITLE^XLFSTR(PCDESC)
. Q
;
I PCTYP="ID" D ; icd-9-cm procedure codes
. Q:PCODE=""
. S PCIEN=+$O(^ICD0("BA",PCODE_" ",0))
. Q:'PCIEN
. S PCDESC=$P($$ICD0^IBACSV(PCIEN),U,4)
. S PCDESC=$$TITLE^XLFSTR(PCDESC)
. Q
;
S LN=LN+1
D SET(LN,COL1,"Prod/Serv ID Qual",$G(CMPI(IBVF,IBVIENS,1.01,"E")))
D SET(.LN,COL2,"Procedure Code",PCODE_" "_PCDESC)
;
S LN=LN+1
S MODLST=""
F FCZ=1.03:.01:1.06 S PM=$G(CMPI(IBVF,IBVIENS,FCZ,"E")) I PM'="" S MODLST=$S(MODLST="":PM,1:(MODLST_", "_PM))
D SET(LN,COL1,"Procedure Modifier(s)",MODLST)
;
; now loop through and display all of the additional info (POS and DX)
S ZF=2.3229
I IBVF=365.02 S ZF=365.29 ; additional info subfile#
;
; if no additional info (POS and DX), then display the prompts here once
I '$D(CMPI(ZF)) D
. S LN=LN+1
. D SET(LN,COL1,"DX/Facility Qual","")
. D SET(.LN,COL2,"DX/Facility","")
. S LN=LN+1
. D SET(LN,COL1,"Nature of Injury Code","")
. D SET(.LN,COL2,"Injury Category","")
. S LN=LN+1
. D SET(LN,COL1,"Nature of Injury Description","")
. Q
;
S ZIEN="" F S ZIEN=$O(CMPI(ZF,ZIEN)) Q:ZIEN="" D
. ;
. ; check to see if we have a valid POS pointer
. S POS=+$G(CMPI(ZF,ZIEN,.02,"I")),POSD=""
. I POS S POSD=$P($G(^IBE(353.1,POS,0)),U,2)
. I POSD'="" D
.. S POSD=$$TITLE^XLFSTR(POSD)
.. S LN=LN+1
.. D SET(LN,COL1,"DX/Facility Qual","POS")
.. D SET(.LN,COL2,"DX/Facility",$G(CMPI(ZF,ZIEN,.02,"E"))_" "_POSD)
.. Q
. ;
. ; now check for a DX
. S DX=+$G(CMPI(ZF,ZIEN,.03,"I")),DXD=""
. I DX S DXD=$P($$ICD9^IBACSV(DX),U,3)
. I DXD'="" D
.. S DXD=$$TITLE^XLFSTR(DXD)
.. S LN=LN+1
.. D SET(LN,COL1,"DX/Facility Qual","DX")
.. D SET(.LN,COL2,"DX/Facility",$G(CMPI(ZF,ZIEN,.03,"E"))_" "_DXD)
.. Q
. ;
. ; nature of injury code
. S LN=LN+1
. D SET(LN,COL1,"Nature of Injury Code",$G(CMPI(ZF,ZIEN,.05,"E")))
. D SET(.LN,COL2,"Injury Category",$G(CMPI(ZF,ZIEN,.06,"E")))
. S LN=LN+1
. D SET(LN,COL1,"Nature of Injury Description",$G(CMPI(ZF,ZIEN,.07,"E")))
. Q
;
S LN=LN+1
D SET(LN)
;
CMPIX ;
Q
;
HCSD(IBVF,IBVIENS,IBVV,IBVSUB) ; Healthcare Services Delivery multiple display
;
; IBVF = file# 2.322 or 365.02
; IBVIENS = std IENS list of internal entry numbers
; IBVV = video attributes flag
; IBVSUB = display scratch global subscript
;
N HCSD,HCSDERR,DSP,LN,ZF,HCNT,ZIEN,HCTOT,COL1,COL2
D GETS^DIQ(IBVF,IBVIENS,"7*","IEN","HCSD","HCSDERR")
S DSP=$NA(^TMP(IBVSUB,$J,"DISP")) ; scratch global display array
S LN=+$O(@DSP@(""),-1) ; last line# used in scratch global
;
; loop through and count the # of hcsd multiples
S ZF=2.3227,HCNT=0
I IBVF=365.02 S ZF=365.27 ; healthcare services delivery subfile#
S ZIEN="" F S ZIEN=$O(HCSD(ZF,ZIEN)) Q:ZIEN="" S HCNT=HCNT+1
S HCTOT=HCNT
;
I 'HCTOT G HCSDX
;
S COL1=2,COL2=40
;
; loop again to display
S HCNT=0
S ZIEN="" F S ZIEN=$O(HCSD(ZF,ZIEN)) Q:ZIEN="" D
. S HCNT=HCNT+1
. ;
. S LN=LN+1
. I HCTOT>1 D SET(LN,1,"Health Care Service Delivery ("_HCNT_" of "_HCTOT_")",,IBVV)
. I HCTOT'>1 D SET(LN,1,"Health Care Service Delivery",,IBVV)
. ;
. S LN=LN+1
. D SET(LN,COL1,"Quantity Qualifier",$P($G(^IBE(365.016,+$G(HCSD(ZF,ZIEN,.03,"I")),0)),U,2))
. D SET(.LN,COL2,"Benefit Quantity",$G(HCSD(ZF,ZIEN,.02,"E")))
. ;
. S LN=LN+1
.D SET(LN,COL1,"Unit/Basis for Measurement",$P($G(^IBE(365.029,+$G(HCSD(ZF,ZIEN,.05,"I")),0)),U,2)) ;IB*2*497
. D SET(.LN,COL2,"Sampling Frequency",$G(HCSD(ZF,ZIEN,.04,"E")))
. ;
. S LN=LN+1
. D SET(LN,COL1,"Period Count Qual",$P($G(^IBE(365.015,+$G(HCSD(ZF,ZIEN,.07,"I")),0)),U,2))
. D SET(.LN,COL2,"Period Count",$G(HCSD(ZF,ZIEN,.06,"E")))
. ;
. S LN=LN+1
. D SET(LN,COL1,"Delivery Freq. Code",$P($G(^IBE(365.025,+$G(HCSD(ZF,ZIEN,.08,"I")),0)),U,2))
. ;
. S LN=LN+1
. D SET(LN,COL1,"Delivery Pattern Time Code",$P($G(^IBE(365.036,+$G(HCSD(ZF,ZIEN,.09,"I")),0)),U,2)) ;IB*2*497
. ;
. S LN=LN+1
. D SET(LN)
. Q
;
HCSDX ;
Q
;
NTE(IBVF,IBVIENS,IBVV,IBVSUB) ; Notes display
;
; IBVF = file# 2.322 or 365.02
; IBVIENS = std IENS list of internal entry numbers
; IBVV = video attributes flag
; IBVSUB = display scratch global subscript
;
;IB*2*702/ckb - Added NOTE
N COL,DSP,LN,NOTE,NTED,NTEDERR,ZIEN
D GETS^DIQ(IBVF,IBVIENS,2,"N","NTED","NTEDERR")
S DSP=$NA(^TMP(IBVSUB,$J,"DISP")) ; scratch global display array
S LN=+$O(@DSP@(""),-1) ; last line# used in scratch global
I '$D(NTED) G NTEX
S COL=2
S LN=LN+1 D SET(LN,1,"Notes and Comments",,IBVV)
;IB*2*702/ckb - Modified to display the entire Note/Comment, not just the first 80 char's.
;S ZIEN=0 F S ZIEN=$O(NTED(IBVF,IBVIENS,2,ZIEN)) Q:'ZIEN S LN=LN+1 D SET(LN,COL,$G(NTED(IBVF,IBVIENS,2,ZIEN)))
S ZIEN=0 F S ZIEN=$O(NTED(IBVF,IBVIENS,2,ZIEN)) Q:'ZIEN D
. S NOTE=$G(NTED(IBVF,IBVIENS,2,ZIEN))
. I $L(NOTE)<80 S LN=LN+1 D SET(LN,COL,NOTE)
. I $L(NOTE)>79 S LN=LN+1 D
. . S LN=$$SETC(NOTE,LN)
S LN=LN+1
D SET(LN)
;
NTEX ;
Q
;
BRE(IBVF,IBVIENS,IBVV,IBVSUB) ; Benefit Related Entity data extract/display
;
; IBVF = file# 2.322 or 365.02
; IBVIENS = std IENS list of internal entry numbers
; IBVV = video attributes flag
; IBVSUB = display scratch global subscript
;
N BRE,BREERR,DSP,LN,ADDR,ADDR1,ADDR2,CITY,ST,ZIP,ZF,ZIEN,COL1,COL2
D GETS^DIQ(IBVF,IBVIENS,"3.01:5.03;6*","IEN","BRE","BREERR")
S DSP=$NA(^TMP(IBVSUB,$J,"DISP")) ; scratch global display array
S LN=+$O(@DSP@(""),-1) ; last line# used in scratch global
;
S COL1=2,COL2=40
;
S LN=LN+1
I '$D(BRE) G BREX
D SET(LN,1,"Benefit Related Entity",,IBVV)
;
S LN=LN+1
D SET(LN,COL1,"Entity ID Code",$P($G(^IBE(365.022,+$G(BRE(IBVF,IBVIENS,3.01,"I")),0)),U,2))
D SET(.LN,COL2,"Entity Type Qual",$P($G(^IBE(365.043,+$G(BRE(IBVF,IBVIENS,3.02,"I")),0)),U,2)) ; IB*2*497
;
S LN=LN+1
D SET(LN,COL1,"Entity ID Name",$G(BRE(IBVF,IBVIENS,3.03,"E")))
;
S LN=LN+1
D SET(LN,COL1,"ID Qualifier",$P($G(^IBE(365.023,+$G(BRE(IBVF,IBVIENS,3.05,"I")),0)),U,2))
D SET(.LN,COL2,"Entity ID Number",$G(BRE(IBVF,IBVIENS,3.04,"E")))
;
S LN=LN+1 ;IB*2*497
D SET(LN,COL1,"Entity Relationship",$P($G(^IBE(365.031,+$G(BRE(IBVF,IBVIENS,3.06,"I")),0)),U,2)) ;IB*2*497
;
S ADDR1=$G(BRE(IBVF,IBVIENS,4.01,"E"))
S ADDR2=$G(BRE(IBVF,IBVIENS,4.02,"E"))
S CITY=$G(BRE(IBVF,IBVIENS,4.03,"E"))
S ST=+$G(BRE(IBVF,IBVIENS,4.04,"I"))
S ST=$S(ST:$P($G(^DIC(5,ST,0)),U,2),1:"")
S ZIP=$G(BRE(IBVF,IBVIENS,4.05,"E"))
S ADDR=ADDR1
I ADDR2'="" S ADDR=ADDR_" "_ADDR2
;I CITY'="" S ADDR=ADDR_", "_CITY
;I ST'="" S ADDR=ADDR_","_ST
;I ZIP'="" S ADDR=ADDR_" "_ZIP
S ADDR=ADDR_" "_CITY_" "_ST_" "_ZIP ;IB*2*497 prevent orphan commas being displayed
S LN=LN+1
D SET(LN,COL1,"Entity Address",ADDR)
;
S LN=LN+1
D SET(LN,COL1,"Country Code",$G(BRE(IBVF,IBVIENS,4.06,"E")))
D SET(.LN,COL2,"Country Subdivision",$G(BRE(IBVF,IBVIENS,4.09,"E")))
;
S LN=LN+1
D SET(LN,COL1,"Location Qual",$P($G(^IBE(365.034,+$G(BRE(IBVF,IBVIENS,4.08,"I")),0)),U,2)) ;IB*2*497
D SET(.LN,COL2,"DOD Health Service Region Code",$G(BRE(IBVF,IBVIENS,4.07,"E")))
;
; now loop through and display all of the benefit related entity contact information
S ZF=2.3226
I IBVF=365.02 S ZF=365.26 ; contact information subfile#
I '$D(BRE(ZF)) S BRE(ZF,1)="" ; so the fields display once
S ZIEN="" F S ZIEN=$O(BRE(ZF,ZIEN)) Q:ZIEN="" D
. N IBDATA,IBLABEL,IBLEN
. S LN=LN+1
. D SET(LN,COL1,"Comm. Number Qual",$P($G(^IBE(365.021,+$G(BRE(ZF,ZIEN,.04,"I")),0)),U,2))
. S IBDATA=$G(BRE(ZF,ZIEN,1,"E")),IBLABEL="Entity Comm. Number"
. I $L(IBLABEL)+2+$L(IBDATA)<40 D Q
.. D SET(.LN,COL2,IBLABEL,IBDATA)
. I $L(IBLABEL)+2+$L(IBDATA)<80 D Q
.. S LN=LN+1
.. D SET(LN,COL1,IBLABEL,IBDATA)
. F D I '$L(IBDATA) Q
.. S IBLEN=80-$L(IBLABEL),LN=LN+1
.. D SET(LN,COL1,IBLABEL,$E(IBDATA,1,IBLEN))
.. S IBDATA=$E(IBDATA,IBLEN+1,$L(IBDATA)),IBLABEL=""
. Q
;
S LN=LN+1
D SET(LN)
;
S LN=LN+1
D SET(LN,1,"Benefit Related Provider Information",,IBVV)
;
S LN=LN+1
D SET(LN,COL1,"Provider Code",$P($G(^IBE(365.024,+$G(BRE(IBVF,IBVIENS,5.01,"I")),0)),U,2))
D SET(.LN,COL2,"Provider ID Qual",$P($G(^IBE(365.028,+$G(BRE(IBVF,IBVIENS,5.03,"I")),0)),U,2)) ;IB*2*497
;
S LN=LN+1
D SET(LN,COL1,"Provider ID",$G(BRE(IBVF,IBVIENS,5.02,"E")))
;
S LN=LN+1
D SET(LN)
BREX ;
Q
;
SET(LN,COL,LABEL,DATA,IBVV) ; set data into display scratch global
;
; LN must be passed by reference when COL>20 because of the special variable IBVEBCOL flag to produce a single column
;
; IBVV - video attributes flag
; 1 = reverse video
; 2 = bold
; 3 = underline
;
N STR,D1
S COL=$G(COL,1)
I $G(IBVEBCOL),COL>20 S LN=LN+1,COL=2 ; single column flag
I $G(LABEL)'="",COL>1 S LABEL=" "_LABEL,COL=COL-1
S STR=$G(@DSP@(LN,0)) ; get the current string
S D1=""
I $G(LABEL)'="" S D1=LABEL
I $D(DATA) S D1=D1_": "_$G(DATA) ; build the new display
;
S STR=$$SETSTR^VALM1(D1,STR,+COL,(81-COL)) ; insert new data
;
S @DSP@(LN,0)=STR ; set the new data back into the scratch global
;
; Add the video attributes if requested
I $G(IBVV) D
. I IBVV=1 D CNTRL^VALM10(LN,COL,$L(LABEL),IORVON,IORVOFF) ; reverse video
. I IBVV=2 D CNTRL^VALM10(LN,COL,$L(LABEL),IOINHI,IOINORM) ; bold
. I IBVV=3 D CNTRL^VALM10(LN,COL,$L(LABEL),IOUON,IOUOFF) ; underline
. Q
;
SETX ;
Q
;
;IB*2*702/ckb - Added to handle Notes/Comments that need more than 1 line to display.
SETC(DATA,LINE) ; Sets Note text
;Input:
; DATA - Note Text to set into more than 1 line
; LINE - Current Line text is being set into
;Returns:
; LINE - Updated Line text is being set into
N CLNEND,CPOS,CWLPOS,CWPOS,CWEPOS,SPOS,STLEN,XX
;
; Display the comment text 1 line at a time. The line begins with a
; space and then the text therefore the text is limited to 79 char's.
S (CPOS,SPOS)=0,CLNEND=75
S (CWLPOS,CWPOS)=1,CWEPOS=$L(DATA)
F D Q:(CWPOS>CWEPOS)
. ; Display the text from position CWPOS-CLNEND
. I 'SPOS!(SPOS>CLNEND) D Q
. . S XX=$E(DATA,CWPOS,CLNEND)
. . I $E(XX,1)=" " S XX=$E(XX,2,$L(XX)) ; removing leading spaces
. . D SET(LINE,2,XX)
. . S LINE=LINE+1,CWLPOS=1
. . S CWPOS=CLNEND+1,CLNEND=CLNEND+75
;
;Q LINE
Q (LINE-1) ;IB*732/CKB correct line quit
;
DATE(Z) ; convert date in Z in format CCYYMMDD to MM/DD/CCYY format for display
I Z?8N S Z=$E(Z,5,6)_"/"_$E(Z,7,8)_"/"_$E(Z,1,4)
Q Z
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCNES1 14493 printed Apr 09, 2024@21:07:13 Page 2
IBCNES1 ;ALB/ESG/JM - eIV elig/benefit utilities ; 01/13/2016
+1 ;;2.0;INTEGRATED BILLING;**416,438,497,549,702,732**;21-MAR-94;Build 13
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 QUIT
+5 ;
EB(IBVF,IBVIENS,IBVV,IBVSUB) ; Main Eligibility/Benefit Information
+1 ;
+2 ; IBVF = file# 2.322 or 365.02
+3 ; IBVIENS = std IENS list of internal entry numbers
+4 ; IBVV = video attributes flag
+5 ; IBVSUB = display scratch global subscript
+6 ;
+7 NEW EB,EBERR,DSP,LN,COL1,COL2,ZF,ZIEN
+8 DO GETS^DIQ(IBVF,IBVIENS,".02:.13;8*;11*","IEN","EB","EBERR")
+9 ; scratch global display array
SET DSP=$NAME(^TMP(IBVSUB,$JOB,"DISP"))
+10 ; last line# used in scratch global
SET LN=+$ORDER(@DSP@(""),-1)
+11 ;
+12 SET COL1=2
SET COL2=40
+13 ;
+14 SET LN=LN+1
+15 DO SET(LN,1,"Eligibility/Benefit Information",,IBVV)
+16 ;
+17 SET LN=LN+1
+18 DO SET(LN,COL1,"Elig/Ben Info",$PIECE($GET(^IBE(365.011,+$GET(EB(IBVF,IBVIENS,.02,"I")),0)),U,2))
+19 DO SET(.LN,COL2,"Coverage Level",$PIECE($GET(^IBE(365.012,+$GET(EB(IBVF,IBVIENS,.03,"I")),0)),U,2))
+20 ;
+21 ; now loop through and display all of the dates and date qualifiers
+22 SET ZF=2.3228
+23 ; subscriber dates subfile#
IF IBVF=365.02
SET ZF=365.28
+24 ; so the fields display once
IF '$DATA(EB(ZF))
SET EB(ZF,1)=""
+25 SET ZIEN=""
FOR
SET ZIEN=$ORDER(EB(ZF,ZIEN))
if ZIEN=""
QUIT
Begin DoDot:1
+26 NEW HLDT,DTYP,EXDT
+27 SET LN=LN+1
+28 DO SET(LN,COL1,"Date/Time Qual",$PIECE($GET(^IBE(365.026,+$GET(EB(ZF,ZIEN,.03,"I")),0)),U,2))
+29 SET HLDT=$GET(EB(ZF,ZIEN,.02,"E"))
+30 ;IB*2.0*549 changed "I" to "E"
SET DTYP=$GET(EB(ZF,ZIEN,.04,"E"))
+31 SET EXDT=$SELECT(DTYP="D8":$$DATE(HLDT),DTYP="RD8":($$DATE($PIECE(HLDT,"-",1))_"-"_$$DATE($PIECE(HLDT,"-",2))),1:HLDT)
+32 DO SET(.LN,COL2,"D/T Period",EXDT)
+33 QUIT
End DoDot:1
+34 ; loop through service type codes
+35 SET ZF=2.32292
+36 ; service types subfile#
IF IBVF=365.02
SET ZF=365.292
+37 ; so the fields display once
IF '$DATA(EB(ZF))
SET EB(ZF,1)=""
+38 SET ZIEN=""
FOR
SET ZIEN=$ORDER(EB(ZF,ZIEN))
if ZIEN=""
QUIT
SET LN=LN+1
DO SET(LN,COL1,"Service Type",$PIECE($GET(^IBE(365.013,+$GET(EB(ZF,ZIEN,.01,"I")),0)),U,2))
+39 ;
+40 SET LN=LN+1
+41 DO SET(LN,COL1,"Time Period",$PIECE($GET(^IBE(365.015,+$GET(EB(IBVF,IBVIENS,.07,"I")),0)),U,2))
+42 ;
+43 SET LN=LN+1
+44 DO SET(LN,COL1,"Insurance Type",$PIECE($GET(^IBE(365.014,+$GET(EB(IBVF,IBVIENS,.05,"I")),0)),U,2))
+45 ;
+46 SET LN=LN+1
+47 DO SET(LN,COL1,"Plan Coverage Desc",$GET(EB(IBVF,IBVIENS,.06,"E")))
+48 ;
+49 SET LN=LN+1
+50 DO SET(LN,COL1,"Benefit Amount",$GET(EB(IBVF,IBVIENS,.08,"E")))
+51 DO SET(.LN,COL2,"Benefit %",$GET(EB(IBVF,IBVIENS,.09,"E")))
+52 ;
+53 SET LN=LN+1
+54 DO SET(LN,COL1,"Quantity Qual",$PIECE($GET(^IBE(365.016,+$GET(EB(IBVF,IBVIENS,.1,"I")),0)),U,2))
+55 DO SET(.LN,COL2,"Quantity Amount",$GET(EB(IBVF,IBVIENS,.11,"E")))
+56 ;
+57 SET LN=LN+1
+58 ;IB*2*497
DO SET(LN,COL1,"Auth/Certification Required",$PIECE($GET(^IBE(365.033,+$GET(EB(IBVF,IBVIENS,.12,"I")),0)),U,2))
+59 ;IB*2*497
DO SET(.LN,COL2,"In-Plan-Network",$PIECE($GET(^IBE(365.033,+$GET(EB(IBVF,IBVIENS,.13,"I")),0)),U,2))
+60 ;
+61 SET LN=LN+1
+62 DO SET(LN)
+63 ;
EBX ;
+1 QUIT
+2 ;
CMPI(IBVF,IBVIENS,IBVV,IBVSUB) ; Composite Medical Procedure Information
+1 ;
+2 ; IBVF = file# 2.322 or 365.02
+3 ; IBVIENS = std IENS list of internal entry numbers
+4 ; IBVV = video attributes flag
+5 ; IBVSUB = display scratch global subscript
+6 ;
+7 NEW CMPI,CMPIERR,DSP,LN,COL1,COL2,PCTYP,PCODE,PCIEN,PCDESC,MODLST,FCZ,PM,ZF,ZIEN,POS,POSD,DX,DXD
+8 DO GETS^DIQ(IBVF,IBVIENS,"1.01:1.06;9*","IEN","CMPI","CMPIERR")
+9 ; scratch global display array
SET DSP=$NAME(^TMP(IBVSUB,$JOB,"DISP"))
+10 ; last line# used in scratch global
SET LN=+$ORDER(@DSP@(""),-1)
+11 ;
+12 SET COL1=2
SET COL2=40
+13 ;
+14 SET LN=LN+1
+15 IF '$DATA(CMPI)
GOTO CMPIX
+16 DO SET(LN,1,"Composite Medical Procedure Information",,IBVV)
+17 ;
+18 ; get procedure code, desc, and type information
+19 ;IB*2*497
SET PCTYP=$GET(CMPI(IBVF,IBVIENS,1.01,"E"))
+20 SET PCODE=$GET(CMPI(IBVF,IBVIENS,1.02,"E"))
+21 SET PCIEN=0
SET PCDESC=""
+22 ; cpt or hcpcs procedure codes
IF PCTYP="CJ"!(PCTYP="HC")
Begin DoDot:1
+23 if PCODE=""
QUIT
+24 SET PCIEN=+$ORDER(^ICPT("BA",PCODE_" ",0))
+25 if 'PCIEN
QUIT
+26 SET PCDESC=$PIECE($$CPT^IBACSV(PCIEN),U,2)
+27 SET PCDESC=$$TITLE^XLFSTR(PCDESC)
+28 QUIT
End DoDot:1
+29 ;
+30 ; icd-9-cm procedure codes
IF PCTYP="ID"
Begin DoDot:1
+31 if PCODE=""
QUIT
+32 SET PCIEN=+$ORDER(^ICD0("BA",PCODE_" ",0))
+33 if 'PCIEN
QUIT
+34 SET PCDESC=$PIECE($$ICD0^IBACSV(PCIEN),U,4)
+35 SET PCDESC=$$TITLE^XLFSTR(PCDESC)
+36 QUIT
End DoDot:1
+37 ;
+38 SET LN=LN+1
+39 DO SET(LN,COL1,"Prod/Serv ID Qual",$GET(CMPI(IBVF,IBVIENS,1.01,"E")))
+40 DO SET(.LN,COL2,"Procedure Code",PCODE_" "_PCDESC)
+41 ;
+42 SET LN=LN+1
+43 SET MODLST=""
+44 FOR FCZ=1.03:.01:1.06
SET PM=$GET(CMPI(IBVF,IBVIENS,FCZ,"E"))
IF PM'=""
SET MODLST=$SELECT(MODLST="":PM,1:(MODLST_", "_PM))
+45 DO SET(LN,COL1,"Procedure Modifier(s)",MODLST)
+46 ;
+47 ; now loop through and display all of the additional info (POS and DX)
+48 SET ZF=2.3229
+49 ; additional info subfile#
IF IBVF=365.02
SET ZF=365.29
+50 ;
+51 ; if no additional info (POS and DX), then display the prompts here once
+52 IF '$DATA(CMPI(ZF))
Begin DoDot:1
+53 SET LN=LN+1
+54 DO SET(LN,COL1,"DX/Facility Qual","")
+55 DO SET(.LN,COL2,"DX/Facility","")
+56 SET LN=LN+1
+57 DO SET(LN,COL1,"Nature of Injury Code","")
+58 DO SET(.LN,COL2,"Injury Category","")
+59 SET LN=LN+1
+60 DO SET(LN,COL1,"Nature of Injury Description","")
+61 QUIT
End DoDot:1
+62 ;
+63 SET ZIEN=""
FOR
SET ZIEN=$ORDER(CMPI(ZF,ZIEN))
if ZIEN=""
QUIT
Begin DoDot:1
+64 ;
+65 ; check to see if we have a valid POS pointer
+66 SET POS=+$GET(CMPI(ZF,ZIEN,.02,"I"))
SET POSD=""
+67 IF POS
SET POSD=$PIECE($GET(^IBE(353.1,POS,0)),U,2)
+68 IF POSD'=""
Begin DoDot:2
+69 SET POSD=$$TITLE^XLFSTR(POSD)
+70 SET LN=LN+1
+71 DO SET(LN,COL1,"DX/Facility Qual","POS")
+72 DO SET(.LN,COL2,"DX/Facility",$GET(CMPI(ZF,ZIEN,.02,"E"))_" "_POSD)
+73 QUIT
End DoDot:2
+74 ;
+75 ; now check for a DX
+76 SET DX=+$GET(CMPI(ZF,ZIEN,.03,"I"))
SET DXD=""
+77 IF DX
SET DXD=$PIECE($$ICD9^IBACSV(DX),U,3)
+78 IF DXD'=""
Begin DoDot:2
+79 SET DXD=$$TITLE^XLFSTR(DXD)
+80 SET LN=LN+1
+81 DO SET(LN,COL1,"DX/Facility Qual","DX")
+82 DO SET(.LN,COL2,"DX/Facility",$GET(CMPI(ZF,ZIEN,.03,"E"))_" "_DXD)
+83 QUIT
End DoDot:2
+84 ;
+85 ; nature of injury code
+86 SET LN=LN+1
+87 DO SET(LN,COL1,"Nature of Injury Code",$GET(CMPI(ZF,ZIEN,.05,"E")))
+88 DO SET(.LN,COL2,"Injury Category",$GET(CMPI(ZF,ZIEN,.06,"E")))
+89 SET LN=LN+1
+90 DO SET(LN,COL1,"Nature of Injury Description",$GET(CMPI(ZF,ZIEN,.07,"E")))
+91 QUIT
End DoDot:1
+92 ;
+93 SET LN=LN+1
+94 DO SET(LN)
+95 ;
CMPIX ;
+1 QUIT
+2 ;
HCSD(IBVF,IBVIENS,IBVV,IBVSUB) ; Healthcare Services Delivery multiple display
+1 ;
+2 ; IBVF = file# 2.322 or 365.02
+3 ; IBVIENS = std IENS list of internal entry numbers
+4 ; IBVV = video attributes flag
+5 ; IBVSUB = display scratch global subscript
+6 ;
+7 NEW HCSD,HCSDERR,DSP,LN,ZF,HCNT,ZIEN,HCTOT,COL1,COL2
+8 DO GETS^DIQ(IBVF,IBVIENS,"7*","IEN","HCSD","HCSDERR")
+9 ; scratch global display array
SET DSP=$NAME(^TMP(IBVSUB,$JOB,"DISP"))
+10 ; last line# used in scratch global
SET LN=+$ORDER(@DSP@(""),-1)
+11 ;
+12 ; loop through and count the # of hcsd multiples
+13 SET ZF=2.3227
SET HCNT=0
+14 ; healthcare services delivery subfile#
IF IBVF=365.02
SET ZF=365.27
+15 SET ZIEN=""
FOR
SET ZIEN=$ORDER(HCSD(ZF,ZIEN))
if ZIEN=""
QUIT
SET HCNT=HCNT+1
+16 SET HCTOT=HCNT
+17 ;
+18 IF 'HCTOT
GOTO HCSDX
+19 ;
+20 SET COL1=2
SET COL2=40
+21 ;
+22 ; loop again to display
+23 SET HCNT=0
+24 SET ZIEN=""
FOR
SET ZIEN=$ORDER(HCSD(ZF,ZIEN))
if ZIEN=""
QUIT
Begin DoDot:1
+25 SET HCNT=HCNT+1
+26 ;
+27 SET LN=LN+1
+28 IF HCTOT>1
DO SET(LN,1,"Health Care Service Delivery ("_HCNT_" of "_HCTOT_")",,IBVV)
+29 IF HCTOT'>1
DO SET(LN,1,"Health Care Service Delivery",,IBVV)
+30 ;
+31 SET LN=LN+1
+32 DO SET(LN,COL1,"Quantity Qualifier",$PIECE($GET(^IBE(365.016,+$GET(HCSD(ZF,ZIEN,.03,"I")),0)),U,2))
+33 DO SET(.LN,COL2,"Benefit Quantity",$GET(HCSD(ZF,ZIEN,.02,"E")))
+34 ;
+35 SET LN=LN+1
+36 ;IB*2*497
DO SET(LN,COL1,"Unit/Basis for Measurement",$PIECE($GET(^IBE(365.029,+$GET(HCSD(ZF,ZIEN,.05,"I")),0)),U,2))
+37 DO SET(.LN,COL2,"Sampling Frequency",$GET(HCSD(ZF,ZIEN,.04,"E")))
+38 ;
+39 SET LN=LN+1
+40 DO SET(LN,COL1,"Period Count Qual",$PIECE($GET(^IBE(365.015,+$GET(HCSD(ZF,ZIEN,.07,"I")),0)),U,2))
+41 DO SET(.LN,COL2,"Period Count",$GET(HCSD(ZF,ZIEN,.06,"E")))
+42 ;
+43 SET LN=LN+1
+44 DO SET(LN,COL1,"Delivery Freq. Code",$PIECE($GET(^IBE(365.025,+$GET(HCSD(ZF,ZIEN,.08,"I")),0)),U,2))
+45 ;
+46 SET LN=LN+1
+47 ;IB*2*497
DO SET(LN,COL1,"Delivery Pattern Time Code",$PIECE($GET(^IBE(365.036,+$GET(HCSD(ZF,ZIEN,.09,"I")),0)),U,2))
+48 ;
+49 SET LN=LN+1
+50 DO SET(LN)
+51 QUIT
End DoDot:1
+52 ;
HCSDX ;
+1 QUIT
+2 ;
NTE(IBVF,IBVIENS,IBVV,IBVSUB) ; Notes display
+1 ;
+2 ; IBVF = file# 2.322 or 365.02
+3 ; IBVIENS = std IENS list of internal entry numbers
+4 ; IBVV = video attributes flag
+5 ; IBVSUB = display scratch global subscript
+6 ;
+7 ;IB*2*702/ckb - Added NOTE
+8 NEW COL,DSP,LN,NOTE,NTED,NTEDERR,ZIEN
+9 DO GETS^DIQ(IBVF,IBVIENS,2,"N","NTED","NTEDERR")
+10 ; scratch global display array
SET DSP=$NAME(^TMP(IBVSUB,$JOB,"DISP"))
+11 ; last line# used in scratch global
SET LN=+$ORDER(@DSP@(""),-1)
+12 IF '$DATA(NTED)
GOTO NTEX
+13 SET COL=2
+14 SET LN=LN+1
DO SET(LN,1,"Notes and Comments",,IBVV)
+15 ;IB*2*702/ckb - Modified to display the entire Note/Comment, not just the first 80 char's.
+16 ;S ZIEN=0 F S ZIEN=$O(NTED(IBVF,IBVIENS,2,ZIEN)) Q:'ZIEN S LN=LN+1 D SET(LN,COL,$G(NTED(IBVF,IBVIENS,2,ZIEN)))
+17 SET ZIEN=0
FOR
SET ZIEN=$ORDER(NTED(IBVF,IBVIENS,2,ZIEN))
if 'ZIEN
QUIT
Begin DoDot:1
+18 SET NOTE=$GET(NTED(IBVF,IBVIENS,2,ZIEN))
+19 IF $LENGTH(NOTE)<80
SET LN=LN+1
DO SET(LN,COL,NOTE)
+20 IF $LENGTH(NOTE)>79
SET LN=LN+1
Begin DoDot:2
+21 SET LN=$$SETC(NOTE,LN)
End DoDot:2
End DoDot:1
+22 SET LN=LN+1
+23 DO SET(LN)
+24 ;
NTEX ;
+1 QUIT
+2 ;
BRE(IBVF,IBVIENS,IBVV,IBVSUB) ; Benefit Related Entity data extract/display
+1 ;
+2 ; IBVF = file# 2.322 or 365.02
+3 ; IBVIENS = std IENS list of internal entry numbers
+4 ; IBVV = video attributes flag
+5 ; IBVSUB = display scratch global subscript
+6 ;
+7 NEW BRE,BREERR,DSP,LN,ADDR,ADDR1,ADDR2,CITY,ST,ZIP,ZF,ZIEN,COL1,COL2
+8 DO GETS^DIQ(IBVF,IBVIENS,"3.01:5.03;6*","IEN","BRE","BREERR")
+9 ; scratch global display array
SET DSP=$NAME(^TMP(IBVSUB,$JOB,"DISP"))
+10 ; last line# used in scratch global
SET LN=+$ORDER(@DSP@(""),-1)
+11 ;
+12 SET COL1=2
SET COL2=40
+13 ;
+14 SET LN=LN+1
+15 IF '$DATA(BRE)
GOTO BREX
+16 DO SET(LN,1,"Benefit Related Entity",,IBVV)
+17 ;
+18 SET LN=LN+1
+19 DO SET(LN,COL1,"Entity ID Code",$PIECE($GET(^IBE(365.022,+$GET(BRE(IBVF,IBVIENS,3.01,"I")),0)),U,2))
+20 ; IB*2*497
DO SET(.LN,COL2,"Entity Type Qual",$PIECE($GET(^IBE(365.043,+$GET(BRE(IBVF,IBVIENS,3.02,"I")),0)),U,2))
+21 ;
+22 SET LN=LN+1
+23 DO SET(LN,COL1,"Entity ID Name",$GET(BRE(IBVF,IBVIENS,3.03,"E")))
+24 ;
+25 SET LN=LN+1
+26 DO SET(LN,COL1,"ID Qualifier",$PIECE($GET(^IBE(365.023,+$GET(BRE(IBVF,IBVIENS,3.05,"I")),0)),U,2))
+27 DO SET(.LN,COL2,"Entity ID Number",$GET(BRE(IBVF,IBVIENS,3.04,"E")))
+28 ;
+29 ;IB*2*497
SET LN=LN+1
+30 ;IB*2*497
DO SET(LN,COL1,"Entity Relationship",$PIECE($GET(^IBE(365.031,+$GET(BRE(IBVF,IBVIENS,3.06,"I")),0)),U,2))
+31 ;
+32 SET ADDR1=$GET(BRE(IBVF,IBVIENS,4.01,"E"))
+33 SET ADDR2=$GET(BRE(IBVF,IBVIENS,4.02,"E"))
+34 SET CITY=$GET(BRE(IBVF,IBVIENS,4.03,"E"))
+35 SET ST=+$GET(BRE(IBVF,IBVIENS,4.04,"I"))
+36 SET ST=$SELECT(ST:$PIECE($GET(^DIC(5,ST,0)),U,2),1:"")
+37 SET ZIP=$GET(BRE(IBVF,IBVIENS,4.05,"E"))
+38 SET ADDR=ADDR1
+39 IF ADDR2'=""
SET ADDR=ADDR_" "_ADDR2
+40 ;I CITY'="" S ADDR=ADDR_", "_CITY
+41 ;I ST'="" S ADDR=ADDR_","_ST
+42 ;I ZIP'="" S ADDR=ADDR_" "_ZIP
+43 ;IB*2*497 prevent orphan commas being displayed
SET ADDR=ADDR_" "_CITY_" "_ST_" "_ZIP
+44 SET LN=LN+1
+45 DO SET(LN,COL1,"Entity Address",ADDR)
+46 ;
+47 SET LN=LN+1
+48 DO SET(LN,COL1,"Country Code",$GET(BRE(IBVF,IBVIENS,4.06,"E")))
+49 DO SET(.LN,COL2,"Country Subdivision",$GET(BRE(IBVF,IBVIENS,4.09,"E")))
+50 ;
+51 SET LN=LN+1
+52 ;IB*2*497
DO SET(LN,COL1,"Location Qual",$PIECE($GET(^IBE(365.034,+$GET(BRE(IBVF,IBVIENS,4.08,"I")),0)),U,2))
+53 DO SET(.LN,COL2,"DOD Health Service Region Code",$GET(BRE(IBVF,IBVIENS,4.07,"E")))
+54 ;
+55 ; now loop through and display all of the benefit related entity contact information
+56 SET ZF=2.3226
+57 ; contact information subfile#
IF IBVF=365.02
SET ZF=365.26
+58 ; so the fields display once
IF '$DATA(BRE(ZF))
SET BRE(ZF,1)=""
+59 SET ZIEN=""
FOR
SET ZIEN=$ORDER(BRE(ZF,ZIEN))
if ZIEN=""
QUIT
Begin DoDot:1
+60 NEW IBDATA,IBLABEL,IBLEN
+61 SET LN=LN+1
+62 DO SET(LN,COL1,"Comm. Number Qual",$PIECE($GET(^IBE(365.021,+$GET(BRE(ZF,ZIEN,.04,"I")),0)),U,2))
+63 SET IBDATA=$GET(BRE(ZF,ZIEN,1,"E"))
SET IBLABEL="Entity Comm. Number"
+64 IF $LENGTH(IBLABEL)+2+$LENGTH(IBDATA)<40
Begin DoDot:2
+65 DO SET(.LN,COL2,IBLABEL,IBDATA)
End DoDot:2
QUIT
+66 IF $LENGTH(IBLABEL)+2+$LENGTH(IBDATA)<80
Begin DoDot:2
+67 SET LN=LN+1
+68 DO SET(LN,COL1,IBLABEL,IBDATA)
End DoDot:2
QUIT
+69 FOR
Begin DoDot:2
+70 SET IBLEN=80-$LENGTH(IBLABEL)
SET LN=LN+1
+71 DO SET(LN,COL1,IBLABEL,$EXTRACT(IBDATA,1,IBLEN))
+72 SET IBDATA=$EXTRACT(IBDATA,IBLEN+1,$LENGTH(IBDATA))
SET IBLABEL=""
End DoDot:2
IF '$LENGTH(IBDATA)
QUIT
+73 QUIT
End DoDot:1
+74 ;
+75 SET LN=LN+1
+76 DO SET(LN)
+77 ;
+78 SET LN=LN+1
+79 DO SET(LN,1,"Benefit Related Provider Information",,IBVV)
+80 ;
+81 SET LN=LN+1
+82 DO SET(LN,COL1,"Provider Code",$PIECE($GET(^IBE(365.024,+$GET(BRE(IBVF,IBVIENS,5.01,"I")),0)),U,2))
+83 ;IB*2*497
DO SET(.LN,COL2,"Provider ID Qual",$PIECE($GET(^IBE(365.028,+$GET(BRE(IBVF,IBVIENS,5.03,"I")),0)),U,2))
+84 ;
+85 SET LN=LN+1
+86 DO SET(LN,COL1,"Provider ID",$GET(BRE(IBVF,IBVIENS,5.02,"E")))
+87 ;
+88 SET LN=LN+1
+89 DO SET(LN)
BREX ;
+1 QUIT
+2 ;
SET(LN,COL,LABEL,DATA,IBVV) ; set data into display scratch global
+1 ;
+2 ; LN must be passed by reference when COL>20 because of the special variable IBVEBCOL flag to produce a single column
+3 ;
+4 ; IBVV - video attributes flag
+5 ; 1 = reverse video
+6 ; 2 = bold
+7 ; 3 = underline
+8 ;
+9 NEW STR,D1
+10 SET COL=$GET(COL,1)
+11 ; single column flag
IF $GET(IBVEBCOL)
IF COL>20
SET LN=LN+1
SET COL=2
+12 IF $GET(LABEL)'=""
IF COL>1
SET LABEL=" "_LABEL
SET COL=COL-1
+13 ; get the current string
SET STR=$GET(@DSP@(LN,0))
+14 SET D1=""
+15 IF $GET(LABEL)'=""
SET D1=LABEL
+16 ; build the new display
IF $DATA(DATA)
SET D1=D1_": "_$GET(DATA)
+17 ;
+18 ; insert new data
SET STR=$$SETSTR^VALM1(D1,STR,+COL,(81-COL))
+19 ;
+20 ; set the new data back into the scratch global
SET @DSP@(LN,0)=STR
+21 ;
+22 ; Add the video attributes if requested
+23 IF $GET(IBVV)
Begin DoDot:1
+24 ; reverse video
IF IBVV=1
DO CNTRL^VALM10(LN,COL,$LENGTH(LABEL),IORVON,IORVOFF)
+25 ; bold
IF IBVV=2
DO CNTRL^VALM10(LN,COL,$LENGTH(LABEL),IOINHI,IOINORM)
+26 ; underline
IF IBVV=3
DO CNTRL^VALM10(LN,COL,$LENGTH(LABEL),IOUON,IOUOFF)
+27 QUIT
End DoDot:1
+28 ;
SETX ;
+1 QUIT
+2 ;
+3 ;IB*2*702/ckb - Added to handle Notes/Comments that need more than 1 line to display.
SETC(DATA,LINE) ; Sets Note text
+1 ;Input:
+2 ; DATA - Note Text to set into more than 1 line
+3 ; LINE - Current Line text is being set into
+4 ;Returns:
+5 ; LINE - Updated Line text is being set into
+6 NEW CLNEND,CPOS,CWLPOS,CWPOS,CWEPOS,SPOS,STLEN,XX
+7 ;
+8 ; Display the comment text 1 line at a time. The line begins with a
+9 ; space and then the text therefore the text is limited to 79 char's.
+10 SET (CPOS,SPOS)=0
SET CLNEND=75
+11 SET (CWLPOS,CWPOS)=1
SET CWEPOS=$LENGTH(DATA)
+12 FOR
Begin DoDot:1
+13 ; Display the text from position CWPOS-CLNEND
+14 IF 'SPOS!(SPOS>CLNEND)
Begin DoDot:2
+15 SET XX=$EXTRACT(DATA,CWPOS,CLNEND)
+16 ; removing leading spaces
IF $EXTRACT(XX,1)=" "
SET XX=$EXTRACT(XX,2,$LENGTH(XX))
+17 DO SET(LINE,2,XX)
+18 SET LINE=LINE+1
SET CWLPOS=1
+19 SET CWPOS=CLNEND+1
SET CLNEND=CLNEND+75
End DoDot:2
QUIT
End DoDot:1
if (CWPOS>CWEPOS)
QUIT
+20 ;
+21 ;Q LINE
+22 ;IB*732/CKB correct line quit
QUIT (LINE-1)
+23 ;
DATE(Z) ; convert date in Z in format CCYYMMDD to MM/DD/CCYY format for display
+1 IF Z?8N
SET Z=$EXTRACT(Z,5,6)_"/"_$EXTRACT(Z,7,8)_"/"_$EXTRACT(Z,1,4)
+2 QUIT Z
+3 ;
