- IBCEF12 ;EDE/JWS - OUTPUT FORMATTER SPECIFIC DENTAL FUNCTIONS ;30-JAN-96
- ;;2.0;INTEGRATED BILLING;**592**;21-MAR-94;Build 58
- ;;Per VA Directive 6402, this routine should not be modified.
- ;
- ;JWS;IB*2.0*592;US131
- TNUM(IBIFN) ; Extract code for 364.5 field 383 N-TOOTH NUMBER
- N IB,IB1
- K ^TMP("IBXSAVE",$J,"TO")
- ;IA# 3820
- S IB=0 F S IB=$O(^DGCR(399,IBIFN,"DEN1",IB)) Q:'IB S IB1=^(IB,0),^TMP("IBXSAVE",$J,"TO",IBIFN,IB)=IB1_U_"JP"
- Q
- ;
- DEN ; Output formatter Format Code for file DEN, field 2
- ;JWS;IB*2.0*592;US131
- N A,Z,Q,IBZ K IBXSAVE("OUTPT")
- D SET1^IBCEF1(IBXIEN,.A,.IBZ,.IBXDATA,.IBXNOREQ)
- S (Q,Z)=0 ;,Q=$G(@A)
- F S Z=$O(IBZ(Z)) S:'Z @A=Q Q:'Z M IBXSAVE("OUTPT",Z)=IBZ(Z) S Q=Q+1,IBXDATA(Z)=Q D:Z>1 ID^IBCEF2(Z,"DEN ") D SVITM^IBCEF2(.IBXSAVE,Z)
- Q
- ;
- DEN1 ; Output formatter Format Code for file DEN1, field 2
- ;JWS;IB*2.0*592;US131
- N A,Z,Q,IBZ K IBXSAVE("OUTPT")
- D SET1^IBCEF1(IBXIEN,.A,.IBZ,.IBXDATA,.IBXNOREQ)
- S (Q,Z)=0 ;,Q=$G(@A)
- F S Z=$O(IBZ(Z)) S:'Z @A=Q Q:'Z M IBXSAVE("OUTPT",Z)=IBZ(Z) S Q=Q+1,IBXDATA(Z)=Q D:Z>1 ID^IBCEF2(Z,"DEN1") D SVITM^IBCEF2(.IBXSAVE,Z)
- Q
- ;
- DEN2 ; Output formatter Format Code for file DEN2, fields 2
- ;JWS;IB*2.0*592;US131
- N A,Z,Z1,CT
- D SET1^IBCEF1(IBXIEN,.A,.IBZ,.IBXDATA,.IBXNOREQ)
- S (CT,Z)=0 ;,Q=$G(@A)
- F S Z=$O(IBZ(Z)) Q:'Z D
- . S Z1=0 F S Z1=$O(IBXSAVE("OUTPT",Z,"DEN1",Z1)) Q:'Z1 D I CT=1,$P($G(IBXSAVE("OUTPT",Z)),U,9)'=1 Q
- .. S CT=CT+1 D ID^IBCEF2(CT,"DEN2")
- .. S IBXDATA(CT)=Z
- .. D SETGBL^IBCEFG(IBXPG,CT,2,Z,.IBXSIZE)
- K IBXDATA
- Q
- ;
- DEN23 ; Output formatter format code for file DEN2, field 3 (8,186.2,1,3)
- ;JWS;IB*2.0*592;US131
- N Z,Z0,CT
- S (CT,Z)=0
- F S Z=$O(IBXSAVE("OUTPT",Z)) Q:'Z D
- . S Z0=0 F S Z0=$O(IBXSAVE("OUTPT",Z,"DEN1",Z0)) Q:'Z0 D
- .. S CT=CT+1
- .. S IBXDATA(CT)="JP"
- .. D SETGBL^IBCEFG(IBXPG,CT,3,"JP",.IBXSIZE)
- K IBXDATA
- Q
- ;
- DEN24 ; Output formatter Format Code for file DEN2, field 4
- ;JWS;IB*2.0*592;US131
- N Z,ZO,CT K IBXSAVE("DONE")
- S (CT,Z)=0
- F S Z=$O(IBXSAVE("OUTPT",Z)) Q:'Z D
- . S Z0=0 F S Z0=$O(IBXSAVE("OUTPT",Z,"DEN1",Z0)) Q:'Z0 D
- .. S CT=CT+1
- .. I $D(IBXSAVE("DONE",Z,Z0)) Q
- .. S IBXSAVE("DONE",Z,Z0)=""
- .. ;IA# 2056
- .. S IBXDATA(CT)=$$GET1^DIQ(356.022,$P(IBXSAVE("OUTPT",Z,"DEN1",Z0,0),U),.01)
- .. D SETGBL^IBCEFG(IBXPG,CT,4,IBXDATA(CT),.IBXSIZE)
- K IBXDATA
- Q
- ;
- DEN25 ; Output formatter Format Code for file DEN2, field 5
- ;JWS;IB*2.0*592;US131
- N Z,ZO,CT K IBXSAVE("DONE")
- S (CT,Z)=0
- F S Z=$O(IBXSAVE("OUTPT",Z)) Q:'Z D
- . S Z0=0 F S Z0=$O(IBXSAVE("OUTPT",Z,"DEN1",Z0)) Q:'Z0 D
- .. S CT=CT+1
- .. I $D(IBXSAVE("DONE",Z,Z0)) Q
- .. S IBXSAVE("DONE",Z,Z0)=""
- .. S IBXDATA(CT)=$P(IBXSAVE("OUTPT",Z,"DEN1",Z0,0),U,2)
- .. D SETGBL^IBCEFG(IBXPG,CT,5,IBXDATA(CT),.IBXSIZE)
- K IBXDATA
- Q
- ;
- DEN26 ; Output formatter Format Code for file DEN2, field 6
- ;JWS;IB*2.0*592;US131
- N Z,ZO,CT K IBXSAVE("DONE")
- S (CT,Z)=0
- F S Z=$O(IBXSAVE("OUTPT",Z)) Q:'Z D
- . S Z0=0 F S Z0=$O(IBXSAVE("OUTPT",Z,"DEN1",Z0)) Q:'Z0 D
- .. S CT=CT+1
- .. I $D(IBXSAVE("DONE",Z,Z0)) Q
- .. S IBXSAVE("DONE",Z,Z0)=""
- .. S IBXDATA(CT)=$P(IBXSAVE("OUTPT",Z,"DEN1",Z0,0),U,3)
- .. D SETGBL^IBCEFG(IBXPG,CT,6,IBXDATA(CT),.IBXSIZE)
- K IBXDATA
- Q
- ;
- DEN27 ; Output formatter Format Code for file DEN2, field 7
- ;JWS;IB*2.0*592;US131
- N Z,ZO,CT K IBXSAVE("DONE")
- S (CT,Z)=0
- F S Z=$O(IBXSAVE("OUTPT",Z)) Q:'Z D
- . S Z0=0 F S Z0=$O(IBXSAVE("OUTPT",Z,"DEN1",Z0)) Q:'Z0 D
- .. S CT=CT+1
- .. I $D(IBXSAVE("DONE",Z,Z0)) Q
- .. S IBXSAVE("DONE",Z,Z0)=""
- .. S IBXDATA(CT)=$P(IBXSAVE("OUTPT",Z,"DEN1",Z0,0),U,4)
- .. D SETGBL^IBCEFG(IBXPG,CT,7,IBXDATA(CT),.IBXSIZE)
- K IBXDATA
- Q
- ;
- DEN28 ; Output formatter Format Code for file DEN2, field 8
- ;JWS;IB*2.0*592;US131
- N Z,ZO,CT K IBXSAVE("DONE")
- S (CT,Z)=0
- F S Z=$O(IBXSAVE("OUTPT",Z)) Q:'Z D
- . S Z0=0 F S Z0=$O(IBXSAVE("OUTPT",Z,"DEN1",Z0)) Q:'Z0 D
- .. S CT=CT+1
- .. I $D(IBXSAVE("DONE",Z,Z0)) Q
- .. S IBXSAVE("DONE",Z,Z0)=""
- .. S IBXDATA(CT)=$P(IBXSAVE("OUTPT",Z,"DEN1",Z0,0),U,5)
- .. D SETGBL^IBCEFG(IBXPG,CT,8,IBXDATA(CT),.IBXSIZE)
- K IBXDATA
- Q
- ;
- DEN29 ; Output formatter Format Code for file DEN2, field 9
- ;JWS;IB*2.0*592;US131
- N Z,ZO,CT K IBXSAVE("DONE")
- S (CT,Z)=0
- F S Z=$O(IBXSAVE("OUTPT",Z)) Q:'Z D
- . S Z0=0 F S Z0=$O(IBXSAVE("OUTPT",Z,"DEN1",Z0)) Q:'Z0 D
- .. S CT=CT+1
- .. I $D(IBXSAVE("DONE",Z,Z0)) Q
- .. S IBXSAVE("DONE",Z,Z0)=""
- .. S IBXDATA(CT)=$P(IBXSAVE("OUTPT",Z,"DEN1",Z0,0),U,6)
- .. D SETGBL^IBCEFG(IBXPG,CT,9,IBXDATA(CT),.IBXSIZE)
- K IBXDATA
- Q
- ;
- TRANS ; Output formatter Format Code for file DN1, field 6
- ;JWS;IB*2.0*592;US131; IA# 2056
- I $$GET1^DIQ(399,IBXIEN_",",93)'="",$$GET1^DIQ(399,IBXIEN_",",94)'="" K IBXDATA
- S IBXDATA=$E($G(IBXDATA)) I IBXDATA'="Y" K IBXDATA
- Q
- ;
- SRVDT ; Output formatter Format Code for file DEN, field 4 Service date
- ;JWS;IB*2.0*592;US131
- ;;S IBXNOREQ=$$NFT^IBCEF1(7,IBXIEN)
- N Z,IBCDT
- S IBCDT=$$GET1^DIQ(399,IBXIEN_",",.03,"I"),IBCDT=$$FMTHL7^XLFDT(IBCDT)
- S Z=0
- F S Z=$O(IBXSAVE("OUTPT",Z)) Q:'Z D
- . I $P($G(IBXSAVE("OUTPT",Z,"DEN")),U,11)'="" Q ;treatment start date
- . I $P($G(IBXSAVE("OUTPT",Z,"DEN")),U,12)'="" Q ;treatment completion date
- . I $P($G(IBXSAVE("OUTPT",Z)),U)=IBCDT Q ;if procedure date is same as event date, don't send
- . I $P($G(IBXSAVE("OUTPT",Z)),U)'="" S IBXDATA(Z)=$P(IBXSAVE("OUTPT",Z),U)
- . Q
- Q
- ;
- SRVDTQ ; Output formatter Format Code for file DEN, field 3 Date/Time Qualifier
- ;JWS;IB*2.0*592;US131
- N Z,IBCDT
- S IBCDT=$$GET1^DIQ(399,IBXIEN_",",.03,"I"),IBCDT=$$FMTHL7^XLFDT(IBCDT)
- S Z=0
- F S Z=$O(IBXSAVE("OUTPT",Z)) Q:'Z D
- . I $P($G(IBXSAVE("OUTPT",Z,"DEN")),U,11)'="" Q ;treatment start date
- . I $P($G(IBXSAVE("OUTPT",Z,"DEN")),U,12)'="" Q ;treatment completion date
- . I $P($G(IBXSAVE("OUTPT",Z)),U)=IBCDT Q ;if procedure date is same as event date, don't send
- . I $P($G(IBXSAVE("OUTPT",Z)),U)'="" S IBXDATA(Z)=472
- Q
- ;
- PROC ; Output formatter Format Code for file DEN1, field 3 Procedure Count
- N Z S Z=0
- F S Z=$O(IBXSAVE("OUTPT",Z)) Q:'Z D
- . S IBXDATA(Z)=$P($G(IBXSAVE("OUTPT",Z)),U,9)
- . I IBXDATA(Z)=1 S IBXDATA(Z)="" ;number of units (default=1, therefore must be blank if =1)
- . Q
- Q
- ;
- POS ; Output formatter Format Code for File DEN, field 13 Place of Service
- N IBZ,W,DEFPOS,POS,HOF,Z
- ;perform logic to obtain CL1-33 Place of Service (Claim Level) to compare to line level
- D F^IBCEF("N-HCFA SERVICE LINE CALLABLE","IBZ",,IBXIEN)
- S DEFPOS="",W=0
- F S W=$O(IBZ(W)) Q:'W S POS=$P($G(IBZ(W)),U,3),HOF=(POS=11!(POS=12)) S:DEFPOS=""!HOF DEFPOS=POS Q:HOF
- ;
- S Z=0 F S Z=$O(IBXSAVE("OUTPT",Z)) Q:'Z I $P(IBXSAVE("OUTPT",Z),U,3)'="",$P(IBXSAVE("OUTPT",Z),U,3)'=DEFPOS S IBXDATA(Z)=$P(IBXSAVE("OUTPT",Z),U,3)
- Q
- ;
- OIT ; Output formatter Format Code for File OI1, field 8 Other Insurance Type
- I $$FT^IBCEF(IBXIEN)'=7 Q
- I A'=3 S IBXDATA(Z)=""
- Q
- ;
- CHK(IBIEN) ;DIC("S") screen for OCCURRENCE CODE 399.041, .01 field
- N IBCHK
- I $D(IBIFN) S IBIEN=IBIFN
- I $$FT^IBCEF(IBIEN)'=7 Q 1
- S IBCHK=$P($G(^DGCR(399.1,Y,0)),"^",2)
- I $F(",01,02,03,04,05,",","_IBCHK_",") Q 1
- Q 0
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCEF12 7164 printed Feb 18, 2025@23:36:23 Page 2
- IBCEF12 ;EDE/JWS - OUTPUT FORMATTER SPECIFIC DENTAL FUNCTIONS ;30-JAN-96
- +1 ;;2.0;INTEGRATED BILLING;**592**;21-MAR-94;Build 58
- +2 ;;Per VA Directive 6402, this routine should not be modified.
- +3 ;
- +4 ;JWS;IB*2.0*592;US131
- TNUM(IBIFN) ; Extract code for 364.5 field 383 N-TOOTH NUMBER
- +1 NEW IB,IB1
- +2 KILL ^TMP("IBXSAVE",$JOB,"TO")
- +3 ;IA# 3820
- +4 SET IB=0
- FOR
- SET IB=$ORDER(^DGCR(399,IBIFN,"DEN1",IB))
- if 'IB
- QUIT
- SET IB1=^(IB,0)
- SET ^TMP("IBXSAVE",$JOB,"TO",IBIFN,IB)=IB1_U_"JP"
- +5 QUIT
- +6 ;
- DEN ; Output formatter Format Code for file DEN, field 2
- +1 ;JWS;IB*2.0*592;US131
- +2 NEW A,Z,Q,IBZ
- KILL IBXSAVE("OUTPT")
- +3 DO SET1^IBCEF1(IBXIEN,.A,.IBZ,.IBXDATA,.IBXNOREQ)
- +4 ;,Q=$G(@A)
- SET (Q,Z)=0
- +5 FOR
- SET Z=$ORDER(IBZ(Z))
- if 'Z
- SET @A=Q
- if 'Z
- QUIT
- MERGE IBXSAVE("OUTPT",Z)=IBZ(Z)
- SET Q=Q+1
- SET IBXDATA(Z)=Q
- if Z>1
- DO ID^IBCEF2(Z,"DEN ")
- DO SVITM^IBCEF2(.IBXSAVE,Z)
- +6 QUIT
- +7 ;
- DEN1 ; Output formatter Format Code for file DEN1, field 2
- +1 ;JWS;IB*2.0*592;US131
- +2 NEW A,Z,Q,IBZ
- KILL IBXSAVE("OUTPT")
- +3 DO SET1^IBCEF1(IBXIEN,.A,.IBZ,.IBXDATA,.IBXNOREQ)
- +4 ;,Q=$G(@A)
- SET (Q,Z)=0
- +5 FOR
- SET Z=$ORDER(IBZ(Z))
- if 'Z
- SET @A=Q
- if 'Z
- QUIT
- MERGE IBXSAVE("OUTPT",Z)=IBZ(Z)
- SET Q=Q+1
- SET IBXDATA(Z)=Q
- if Z>1
- DO ID^IBCEF2(Z,"DEN1")
- DO SVITM^IBCEF2(.IBXSAVE,Z)
- +6 QUIT
- +7 ;
- DEN2 ; Output formatter Format Code for file DEN2, fields 2
- +1 ;JWS;IB*2.0*592;US131
- +2 NEW A,Z,Z1,CT
- +3 DO SET1^IBCEF1(IBXIEN,.A,.IBZ,.IBXDATA,.IBXNOREQ)
- +4 ;,Q=$G(@A)
- SET (CT,Z)=0
- +5 FOR
- SET Z=$ORDER(IBZ(Z))
- if 'Z
- QUIT
- Begin DoDot:1
- +6 SET Z1=0
- FOR
- SET Z1=$ORDER(IBXSAVE("OUTPT",Z,"DEN1",Z1))
- if 'Z1
- QUIT
- Begin DoDot:2
- +7 SET CT=CT+1
- DO ID^IBCEF2(CT,"DEN2")
- +8 SET IBXDATA(CT)=Z
- +9 DO SETGBL^IBCEFG(IBXPG,CT,2,Z,.IBXSIZE)
- End DoDot:2
- IF CT=1
- IF $PIECE($GET(IBXSAVE("OUTPT",Z)),U,9)'=1
- QUIT
- End DoDot:1
- +10 KILL IBXDATA
- +11 QUIT
- +12 ;
- DEN23 ; Output formatter format code for file DEN2, field 3 (8,186.2,1,3)
- +1 ;JWS;IB*2.0*592;US131
- +2 NEW Z,Z0,CT
- +3 SET (CT,Z)=0
- +4 FOR
- SET Z=$ORDER(IBXSAVE("OUTPT",Z))
- if 'Z
- QUIT
- Begin DoDot:1
- +5 SET Z0=0
- FOR
- SET Z0=$ORDER(IBXSAVE("OUTPT",Z,"DEN1",Z0))
- if 'Z0
- QUIT
- Begin DoDot:2
- +6 SET CT=CT+1
- +7 SET IBXDATA(CT)="JP"
- +8 DO SETGBL^IBCEFG(IBXPG,CT,3,"JP",.IBXSIZE)
- End DoDot:2
- End DoDot:1
- +9 KILL IBXDATA
- +10 QUIT
- +11 ;
- DEN24 ; Output formatter Format Code for file DEN2, field 4
- +1 ;JWS;IB*2.0*592;US131
- +2 NEW Z,ZO,CT
- KILL IBXSAVE("DONE")
- +3 SET (CT,Z)=0
- +4 FOR
- SET Z=$ORDER(IBXSAVE("OUTPT",Z))
- if 'Z
- QUIT
- Begin DoDot:1
- +5 SET Z0=0
- FOR
- SET Z0=$ORDER(IBXSAVE("OUTPT",Z,"DEN1",Z0))
- if 'Z0
- QUIT
- Begin DoDot:2
- +6 SET CT=CT+1
- +7 IF $DATA(IBXSAVE("DONE",Z,Z0))
- QUIT
- +8 SET IBXSAVE("DONE",Z,Z0)=""
- +9 ;IA# 2056
- +10 SET IBXDATA(CT)=$$GET1^DIQ(356.022,$PIECE(IBXSAVE("OUTPT",Z,"DEN1",Z0,0),U),.01)
- +11 DO SETGBL^IBCEFG(IBXPG,CT,4,IBXDATA(CT),.IBXSIZE)
- End DoDot:2
- End DoDot:1
- +12 KILL IBXDATA
- +13 QUIT
- +14 ;
- DEN25 ; Output formatter Format Code for file DEN2, field 5
- +1 ;JWS;IB*2.0*592;US131
- +2 NEW Z,ZO,CT
- KILL IBXSAVE("DONE")
- +3 SET (CT,Z)=0
- +4 FOR
- SET Z=$ORDER(IBXSAVE("OUTPT",Z))
- if 'Z
- QUIT
- Begin DoDot:1
- +5 SET Z0=0
- FOR
- SET Z0=$ORDER(IBXSAVE("OUTPT",Z,"DEN1",Z0))
- if 'Z0
- QUIT
- Begin DoDot:2
- +6 SET CT=CT+1
- +7 IF $DATA(IBXSAVE("DONE",Z,Z0))
- QUIT
- +8 SET IBXSAVE("DONE",Z,Z0)=""
- +9 SET IBXDATA(CT)=$PIECE(IBXSAVE("OUTPT",Z,"DEN1",Z0,0),U,2)
- +10 DO SETGBL^IBCEFG(IBXPG,CT,5,IBXDATA(CT),.IBXSIZE)
- End DoDot:2
- End DoDot:1
- +11 KILL IBXDATA
- +12 QUIT
- +13 ;
- DEN26 ; Output formatter Format Code for file DEN2, field 6
- +1 ;JWS;IB*2.0*592;US131
- +2 NEW Z,ZO,CT
- KILL IBXSAVE("DONE")
- +3 SET (CT,Z)=0
- +4 FOR
- SET Z=$ORDER(IBXSAVE("OUTPT",Z))
- if 'Z
- QUIT
- Begin DoDot:1
- +5 SET Z0=0
- FOR
- SET Z0=$ORDER(IBXSAVE("OUTPT",Z,"DEN1",Z0))
- if 'Z0
- QUIT
- Begin DoDot:2
- +6 SET CT=CT+1
- +7 IF $DATA(IBXSAVE("DONE",Z,Z0))
- QUIT
- +8 SET IBXSAVE("DONE",Z,Z0)=""
- +9 SET IBXDATA(CT)=$PIECE(IBXSAVE("OUTPT",Z,"DEN1",Z0,0),U,3)
- +10 DO SETGBL^IBCEFG(IBXPG,CT,6,IBXDATA(CT),.IBXSIZE)
- End DoDot:2
- End DoDot:1
- +11 KILL IBXDATA
- +12 QUIT
- +13 ;
- DEN27 ; Output formatter Format Code for file DEN2, field 7
- +1 ;JWS;IB*2.0*592;US131
- +2 NEW Z,ZO,CT
- KILL IBXSAVE("DONE")
- +3 SET (CT,Z)=0
- +4 FOR
- SET Z=$ORDER(IBXSAVE("OUTPT",Z))
- if 'Z
- QUIT
- Begin DoDot:1
- +5 SET Z0=0
- FOR
- SET Z0=$ORDER(IBXSAVE("OUTPT",Z,"DEN1",Z0))
- if 'Z0
- QUIT
- Begin DoDot:2
- +6 SET CT=CT+1
- +7 IF $DATA(IBXSAVE("DONE",Z,Z0))
- QUIT
- +8 SET IBXSAVE("DONE",Z,Z0)=""
- +9 SET IBXDATA(CT)=$PIECE(IBXSAVE("OUTPT",Z,"DEN1",Z0,0),U,4)
- +10 DO SETGBL^IBCEFG(IBXPG,CT,7,IBXDATA(CT),.IBXSIZE)
- End DoDot:2
- End DoDot:1
- +11 KILL IBXDATA
- +12 QUIT
- +13 ;
- DEN28 ; Output formatter Format Code for file DEN2, field 8
- +1 ;JWS;IB*2.0*592;US131
- +2 NEW Z,ZO,CT
- KILL IBXSAVE("DONE")
- +3 SET (CT,Z)=0
- +4 FOR
- SET Z=$ORDER(IBXSAVE("OUTPT",Z))
- if 'Z
- QUIT
- Begin DoDot:1
- +5 SET Z0=0
- FOR
- SET Z0=$ORDER(IBXSAVE("OUTPT",Z,"DEN1",Z0))
- if 'Z0
- QUIT
- Begin DoDot:2
- +6 SET CT=CT+1
- +7 IF $DATA(IBXSAVE("DONE",Z,Z0))
- QUIT
- +8 SET IBXSAVE("DONE",Z,Z0)=""
- +9 SET IBXDATA(CT)=$PIECE(IBXSAVE("OUTPT",Z,"DEN1",Z0,0),U,5)
- +10 DO SETGBL^IBCEFG(IBXPG,CT,8,IBXDATA(CT),.IBXSIZE)
- End DoDot:2
- End DoDot:1
- +11 KILL IBXDATA
- +12 QUIT
- +13 ;
- DEN29 ; Output formatter Format Code for file DEN2, field 9
- +1 ;JWS;IB*2.0*592;US131
- +2 NEW Z,ZO,CT
- KILL IBXSAVE("DONE")
- +3 SET (CT,Z)=0
- +4 FOR
- SET Z=$ORDER(IBXSAVE("OUTPT",Z))
- if 'Z
- QUIT
- Begin DoDot:1
- +5 SET Z0=0
- FOR
- SET Z0=$ORDER(IBXSAVE("OUTPT",Z,"DEN1",Z0))
- if 'Z0
- QUIT
- Begin DoDot:2
- +6 SET CT=CT+1
- +7 IF $DATA(IBXSAVE("DONE",Z,Z0))
- QUIT
- +8 SET IBXSAVE("DONE",Z,Z0)=""
- +9 SET IBXDATA(CT)=$PIECE(IBXSAVE("OUTPT",Z,"DEN1",Z0,0),U,6)
- +10 DO SETGBL^IBCEFG(IBXPG,CT,9,IBXDATA(CT),.IBXSIZE)
- End DoDot:2
- End DoDot:1
- +11 KILL IBXDATA
- +12 QUIT
- +13 ;
- TRANS ; Output formatter Format Code for file DN1, field 6
- +1 ;JWS;IB*2.0*592;US131; IA# 2056
- +2 IF $$GET1^DIQ(399,IBXIEN_",",93)'=""
- IF $$GET1^DIQ(399,IBXIEN_",",94)'=""
- KILL IBXDATA
- +3 SET IBXDATA=$EXTRACT($GET(IBXDATA))
- IF IBXDATA'="Y"
- KILL IBXDATA
- +4 QUIT
- +5 ;
- SRVDT ; Output formatter Format Code for file DEN, field 4 Service date
- +1 ;JWS;IB*2.0*592;US131
- +2 ;;S IBXNOREQ=$$NFT^IBCEF1(7,IBXIEN)
- +3 NEW Z,IBCDT
- +4 SET IBCDT=$$GET1^DIQ(399,IBXIEN_",",.03,"I")
- SET IBCDT=$$FMTHL7^XLFDT(IBCDT)
- +5 SET Z=0
- +6 FOR
- SET Z=$ORDER(IBXSAVE("OUTPT",Z))
- if 'Z
- QUIT
- Begin DoDot:1
- +7 ;treatment start date
- IF $PIECE($GET(IBXSAVE("OUTPT",Z,"DEN")),U,11)'=""
- QUIT
- +8 ;treatment completion date
- IF $PIECE($GET(IBXSAVE("OUTPT",Z,"DEN")),U,12)'=""
- QUIT
- +9 ;if procedure date is same as event date, don't send
- IF $PIECE($GET(IBXSAVE("OUTPT",Z)),U)=IBCDT
- QUIT
- +10 IF $PIECE($GET(IBXSAVE("OUTPT",Z)),U)'=""
- SET IBXDATA(Z)=$PIECE(IBXSAVE("OUTPT",Z),U)
- +11 QUIT
- End DoDot:1
- +12 QUIT
- +13 ;
- SRVDTQ ; Output formatter Format Code for file DEN, field 3 Date/Time Qualifier
- +1 ;JWS;IB*2.0*592;US131
- +2 NEW Z,IBCDT
- +3 SET IBCDT=$$GET1^DIQ(399,IBXIEN_",",.03,"I")
- SET IBCDT=$$FMTHL7^XLFDT(IBCDT)
- +4 SET Z=0
- +5 FOR
- SET Z=$ORDER(IBXSAVE("OUTPT",Z))
- if 'Z
- QUIT
- Begin DoDot:1
- +6 ;treatment start date
- IF $PIECE($GET(IBXSAVE("OUTPT",Z,"DEN")),U,11)'=""
- QUIT
- +7 ;treatment completion date
- IF $PIECE($GET(IBXSAVE("OUTPT",Z,"DEN")),U,12)'=""
- QUIT
- +8 ;if procedure date is same as event date, don't send
- IF $PIECE($GET(IBXSAVE("OUTPT",Z)),U)=IBCDT
- QUIT
- +9 IF $PIECE($GET(IBXSAVE("OUTPT",Z)),U)'=""
- SET IBXDATA(Z)=472
- End DoDot:1
- +10 QUIT
- +11 ;
- PROC ; Output formatter Format Code for file DEN1, field 3 Procedure Count
- +1 NEW Z
- SET Z=0
- +2 FOR
- SET Z=$ORDER(IBXSAVE("OUTPT",Z))
- if 'Z
- QUIT
- Begin DoDot:1
- +3 SET IBXDATA(Z)=$PIECE($GET(IBXSAVE("OUTPT",Z)),U,9)
- +4 ;number of units (default=1, therefore must be blank if =1)
- IF IBXDATA(Z)=1
- SET IBXDATA(Z)=""
- +5 QUIT
- End DoDot:1
- +6 QUIT
- +7 ;
- POS ; Output formatter Format Code for File DEN, field 13 Place of Service
- +1 NEW IBZ,W,DEFPOS,POS,HOF,Z
- +2 ;perform logic to obtain CL1-33 Place of Service (Claim Level) to compare to line level
- +3 DO F^IBCEF("N-HCFA SERVICE LINE CALLABLE","IBZ",,IBXIEN)
- +4 SET DEFPOS=""
- SET W=0
- +5 FOR
- SET W=$ORDER(IBZ(W))
- if 'W
- QUIT
- SET POS=$PIECE($GET(IBZ(W)),U,3)
- SET HOF=(POS=11!(POS=12))
- if DEFPOS=""!HOF
- SET DEFPOS=POS
- if HOF
- QUIT
- +6 ;
- +7 SET Z=0
- FOR
- SET Z=$ORDER(IBXSAVE("OUTPT",Z))
- if 'Z
- QUIT
- IF $PIECE(IBXSAVE("OUTPT",Z),U,3)'=""
- IF $PIECE(IBXSAVE("OUTPT",Z),U,3)'=DEFPOS
- SET IBXDATA(Z)=$PIECE(IBXSAVE("OUTPT",Z),U,3)
- +8 QUIT
- +9 ;
- OIT ; Output formatter Format Code for File OI1, field 8 Other Insurance Type
- +1 IF $$FT^IBCEF(IBXIEN)'=7
- QUIT
- +2 IF A'=3
- SET IBXDATA(Z)=""
- +3 QUIT
- +4 ;
- CHK(IBIEN) ;DIC("S") screen for OCCURRENCE CODE 399.041, .01 field
- +1 NEW IBCHK
- +2 IF $DATA(IBIFN)
- SET IBIEN=IBIFN
- +3 IF $$FT^IBCEF(IBIEN)'=7
- QUIT 1
- +4 SET IBCHK=$PIECE($GET(^DGCR(399.1,Y,0)),"^",2)
- +5 IF $FIND(",01,02,03,04,05,",","_IBCHK_",")
- QUIT 1
- +6 QUIT 0
- +7 ;