- DGBTEE ;ALB/SCK - BENEFICIARY TRAVEL ENTER/EDIT; 12/3/92@1600 ; 7/2/14 1:17pm
- ;;1.0;Beneficiary Travel;**2,14,20,21,25,30,39**;September 25, 2001;Build 6
- Q
- SCREEN ;
- ;
- I '$D(^DGBT(392,DGBTDT,"D"))&('$D(^DGBT(392,DGBTDT,"T"))) S DGBTSP2M=1 D STUFF^DGBTE1 K DGBTSP2M ;dbe patch DGBT*1.0*25 - added for conversion from SP to M during claim edit
- D SCREEN^DGBTEE1 Q:$G(DGBTTOUT)=-1!($G(DGBTTOUT)=1) Q:'$D(^DGBT(392,DGBTDT,0))
- ; The following section of code moved to DGBTEE2 for space problems
- D STUFF^DGBTEE2
- MILES ; get miles between dep. and dest. using function call to DGBTUTL
- ;
- K X,DGBTREC S (DGBTOWRT,DGBTML,DGBTMLT)=""
- I DGBTFR4]""&((DGBTACCT=4)!(DGBTACCT=5)) I $D(^DGBT(392.1,"ACS",DGBTFR4,+DGBTADDR(5))) D ;*39 - updated to use residential address
- . S X=$O(^(+DGBTADDR(5),0)) ; naked ref. refers to file #392.1, "ACS", city. Full reference on line MILES+2^DGBTEE, ^DGBTE(392.1,"ACS",DGBTFR4,+DGBTADDR(5) ;*39 - updated to use residential address
- . ; function $$miles passes city's record# and div name to function, mileage value is returned
- . I X'="" S DGBTREC=X,DGBTML=$$MILES^DGBTUTL(DGBTREC,DGBTDV1),DGBTOWRT="ROUND TRIP" K X
- S (DGBTMAL,DGBTFAB,DGBTME,DGBTCP,DGBTFLAG,DGBTDCV,DGBTDE,DGBTDCM,DGBTDPV,DGBTDPM)=0
- DIE1 ; stuff from,to address, meals, ferry's/bridges
- ;
- Q:'$D(^DGBT(392,DGBTDT,0))
- ;
- S DIE="^DGBT(392,",DA=DGBTDT,DR=$S($G(DGBTACCT)=4:"42//"_$G(DGBTAP),$G(DGBTACCT)=5:"43;S DGBTCP=X;42//"_$G(DGBTAP),1:"44")
- D ^DIE I X=""!(X="^") S DGBTTOUT=-1 Q
- ;
- S DR="21////^S X=DGBTFR1;22////^S X=DGBTFR2;23////^S X=DGBTFR3;24////^S X=DGBTFR4;25////^S X=DGBTTO1;26////^S X=DGBTTO2;27////^S X=DGBTTO3;28////^S X=DGBTTO4" ;;34////^S X=DGBTMAL;35////^S X=DGBTFAB"
- D ^DIE I X=""!(X="^") S DGBTTOUT=-1 Q
- ;
- I DGBTACCT=4!(DGBTACCT=5) D
- . W !!,"Please enter mileage obtained from BT Dashboard ..."
- .S DGBTRMK=$S($D(DGBTREC):$$DICLKUP^DGBTUTL(DGBTREC,DGBTDV1,4),1:"") I $D(DGBTDEF),DGBTDEF S DGBTRMK="DEFAULT MILEAGE USED"
- .I DGBTRMK]"" W !,*7,"MILEAGE REMARKS: ",DGBTRMK,!
- ;
- EDIT ; display trip type, mileage
- I ($G(DGBTACCT)=4)!($G(DGBTACCT)=5) D Q:$G(DGBTTOUT)=-1 ;20
- .I $G(CHZFLG) N OTRIPTYP S OTRIPTYP=$$GET1^DIQ(392,DGBTDT,31,"I")
- .S DR="32//"_DGBTML_";S DGBTML=X;31//"_DGBTOWRT_";S DGBTOWRT=X;" D ^DIE I X=""!(X="^") S DGBTTOUT=-1 Q ;20
- .I ($G(CHZFLG))&($G(OTRIPTYP)'=$$GET1^DIQ(392,DGBTDT,31,"I"))&($G(MONTOT)'="") D
- ..N NTRIPTYP S NTRIPTYP=$$GET1^DIQ(392,DGBTDT,31,"I")
- ..I (OTRIPTYP=1)&(NTRIPTYP=2) D Q
- ...S $P(MONTOT,U)=$P(MONTOT,U)+1
- ...S $P(MONTOT,U,2)=$P(MONTOT,U,2)-1
- ...S $P(MONTOT,U,3)=$P(MONTOT,U,3)+1
- ..I (OTRIPTYP=2)&(NTRIPTYP=1) D Q
- ...S $P(MONTOT,U)=$P(MONTOT,U)-1
- ...S $P(MONTOT,U,2)=$P(MONTOT,U,2)+1
- ...S $P(MONTOT,U,3)=$P(MONTOT,U,3)-1
- .S DGBTCCT=$$GET1^DIQ(392,DGBTDT,54,"I")
- .S DIR(0)="Y",DIR("B")=$S($G(DGBTCCT)'="":"YES",1:"NO"),DIR("A")="COMMON CARRIER USED" D ^DIR K DIR I $D(DIRUT) S DGBTTOUT=-1 Q ;20
- .I 'Y,$D(^DGBT(392,DGBTDT,"C")) S $P(^DGBT(392,DGBTDT,"A"),"^",4)="" F I="B","C" K ^DGBT(392,DGBTDT,I)
- .I Y D ;20
- ..K DA,DR,DIE,Y S DIE="^DGBT(392,",DA=DGBTDT,DR="44COMMON CARRIER MODE~R" D ^DIE I $D(Y) S DGBTTOUT=-1 Q ;20
- ..K DA,DR,DIE,Y S DIE="^DGBT(392,",DA=DGBTDT I $$UP^XLFSTR($$GET1^DIQ(392,DGBTDT,44))["BUS" S DR="52R" D ^DIE I $D(Y) S DGBTTOUT=-1 Q ;20
- ..K DA,DR,DIE,Y I $$GET1^DIQ(392,DGBTDT,52)="PASS" S DIE="^DGBT(392,",DA=DGBTDT,DR="53R" D ^DIE I $D(Y) S DGBTTOUT=-1 Q ;20
- ..N %DT S %DT(0)="-NOW" ;prevents future dates Coder CR 53 for DG*1.0*20
- ..K DA,DR,DIE,Y S DIE="^DGBT(392,",DA=DGBTDT,DR="54//"_$P(DGBTDTE,"@",1)_";55;55.1" D ^DIE I $D(Y) S DGBTTOUT=-1 Q ;20 PAVEL - DGBT*1*20
- S:DGBTACCT=5&(DGBTCP=1) DGBTMR=DGBTMR1 S DGBTMLT=DGBTOWRT*DGBTML*DGBTMR,DGBTMLT=$J(DGBTMLT,0,2),DR="33///"_DGBTMLT
- D ^DIE I X=""!(X="^") S DGBTTOUT=-1 Q
- I $G(^DGBT(392,DGBTDTI,"C"))="" K ^DGBT(392,DGBTDTI,"C"),DGBTVAR("C")
- ;
- DIE2 ; stuff eligibility data, SC%, acct. type
- ;
- S DIE("NO^")="12345" S:'$D(DGBTCD) DGBTCD=""
- I 'DGBTCORE D
- . S DR="3////"_DGBTELIG_";4////"_DGBTSCP_";5///"_DGBTCD_";6////"_DGBTACTN_";I DGBTACCT=4!(DGBTACCT=5) S Y=""@1"";41;7;@1;I DGBTMLFB=0 S Y=""@2"";34//0;W:'X X S DGBTMAL=X;35//0;W:'X X S DGBTFAB=X;@2"
- I DGBTCORE D
- . S DR(1,392,1)="3////"_DGBTELIG_";4////"_DGBTSCP_";5///"_DGBTCD_";6////"_DGBTACTN_";I DGBTACCT=4!(DGBTACCT=5) S Y=""@1"";41;"
- . S DR(1,392,2)="@3;14;S DGBTCSL=$$AFTER^DGBTCSL(392,D0,X,$G(DGBTPRV)) S:DGBTCSL<1 Y=""@3"" W:DGBTCSL<1 "" Required"" K DGBTPRV,DGBTCSL;@1;I DGBTMLFB=0 S Y=""@2"";34//0;S DGBTMAL=X;35//0;S DGBTFAB=X;@2"
- ;
- ;DIE3 ; get most econ. cost
- ;
- D ^DIE K DR I $G(DTOUT)!(X="^") S DGBTTOUT=-1 Q
- ;
- ;check for common carrier
- S DGBTMAF=$G(DGBTFAB)+$G(DGBTMAL)
- S (DGBTCC,DGBTCCAMT,DGBTCCREQ,DGBTCCMODE,DGBTMETC)=0
- S DGBTDCM=$P(MONTOT,"^",4)
- S DGBTDCM=$S(DGBTMLT-DGBTDCM'>0:DGBTMLT,1:DGBTDCM)
- I $D(^DGBT(392,DGBTDTI,"C")) D
- .S DGBTCC=$D(^DGBT(392,DGBTDTI,"C")) ;was common carrier used
- .S DGBTCCAMT=$$GET1^DIQ(392,DGBTDTI,55) ; amount of common carrier
- .S DGBTCCREQ=$$GET1^DIQ(392,DGBTDTI,55.1),DGBTCCREQ=$S(DGBTCCREQ="YES":1,1:0) ;common carrier required - 1=yes,0=no
- .S DGBTCCMODE=$$GET1^DIQ(392,DGBTDTI,44,"I") ;common carrier mode of transportation
- .S DGBTMETC=$G(DGBTME)+$G(DGBTMAL) ;$S($D(DGBTMAL):DGBTMAL,1:0) ;most enco + meals and lodging S DGBTDCM=$P(MONTOT,"^",4) S DGBTDCM=$P(MONTOT,"^",4) S DGBTMAF=$S(DGBTMLFB:DGBTMAL+DGBTFAB,1:0),DGBTMETC=DGBTME+$S($D(DGBTMAL):DGBTMAL,1:0)
- ;
- ;if CC not required reset most econ to 0
- I $G(DGBTCCREQ) D
- .S FDA(392,DGBTDTI_",",8)=0
- .D FILE^DIE(,"FDA")
- S:$D(DGBTREC) DGBTME=$$DICLKUP^DGBTUTL(DGBTREC,DGBTDV1,3) S:DGBTME="" DGBTME=0 S DR="8//"_DGBTME_";W:'X X S DGBTME=X" D ^DIE I X=""!(X="^") S DGBTTOUT=-1 G EXIT
- TCOST ; calculate total cost and monthly cum. deductible
- MLFB ;
- ;
- N OWAIV
- S OWAIV=$P(MONTOT,U,5)
- S MONTOT=$$ADDTO(.MONTOT)
- I DGBTACCT'=4&(DGBTACCT'=5) S DGBTPA=DGBTMAF+DGBTME G CONT
- I $D(DGBTMLT) D
- .I DGBTMLT+DGBTMAF'>DGBTMETC S DGBTTC=DGBTMLT+DGBTMAF Q
- .I DGBTMLT+DGBTMAF>DGBTMETC&(DGBTME>0) S DGBTTC=DGBTMETC Q
- .I DGBTME'>0 S DGBTTC=DGBTMLT+DGBTMAF Q
- .E S DGBTTC=DGBTMETC
- I $G(DGBTCCREQ) S DGBTTC=$G(DGBTTC)+DGBTCCAMT
- I DGBTACCT=5 S DGBTDE=0 S DGBTPA=$S((DGBTMLT+DGBTMAF)'=0:DGBTTC,1:DGBTMETC) ;G CONT
- ; the following section of code moved to DGBTEE2 for space reasons
- I DGBTACCT'=5 D
- .N DGBTDCVX,XY
- .I $G(CHZFLG) N ODED S ODED=$$GET1^DIQ(392,DGBTDT,9)
- .D DED^DGBTEE2
- .I $P($G(MONTOT),"^",5)'["Y" S DGBTDCV=DGBTDCV1
- .;add by Pavel for patch 20
- .I $G(DGBTCC),$G(DGBTCCREQ),'$G(DGBTMLT) S DGBTDCV=0
- .I $G(DGBTCC),'$G(DGBTCCREQ),$G(DGBTMLT)'>0 S DGBTDCV=0
- .I $G(DGBTCC),'$G(DGBTCCREQ),$G(DGBTME)'>0
- .I $G(DGBTCC),'$G(DGBTCCREQ),$G(DGBTME)>0,$G(DGBTME)'>$G(DGBTMLT) S DGBTDCV=0
- .I $G(DGBTCC),$G(DGBTCCREQ),$G(DGBTDE)'<$G(DGBTMLT) S DGBTDE=DGBTMLT
- .I '$G(DGBTCC),'$G(DGBTCCREQ),$G(DGBTMLT)'>0 S DGBTDCV=0
- .I '$G(DGBTCC),DGBTMLT>DGBTDPV S (DGBTDCV,DGBTDE)=DGBTDPV
- .I ($G(CHZFLG))&($$GET1^DIQ(392,DGBTDT,9)=0)&($P($G(MONTOT),U,5)["Y") S (DGBTDCV,DGBTE)=0
- .;dbe patch DGBT*1.0*25 - modified the next line to use the total deductible for the month, MONTOT piece 4
- .I (+$P($G(MONTOT),U,4)<18)&((+$P($G(MONTOT),U,4)+DGBTDCV)>18)&(OWAIV'["Y")&('$G(CHZFLG)) S DGBTDCV=18-$P(MONTOT,U,4),$P(MONTOT,U,5)="NO" ; RFE 12/5/12
- .I (+$G(CHZFLG)&(($P($G(MONTOT),U,7)+DGBTDCV)>18)) S DGBTDCV=18-$P(MONTOT,U,7),$P(MONTOT,U,5)="NO" ; RFE 12/5/12 ;*30
- .I (+$P($G(MONTOT),U,1)>6)!(+$P($G(MONTOT),U,4)>18)!($P($G(MONTOT),U,5)["Y")&('$G(CHZFLG)) S DGBTDCV=0 ; Added ELSE RFE 12/5/12
- .I $$DENIED(DGBTDT) S DGBTDCV=0
- .I $G(CHZFLG)=0 S ($P(MONTOT,U,4),$P(MONTOT,U,7))=$P(MONTOT,U,4)+DGBTDCV
- .S DGBTOTHER=$$GET1^DIQ(392,DGBTDT,43.1,"I")
- .I $G(DGBTNSC) S DGBTDCV=0
- .I $G(DGBTOTHER)=11 S DGBTDCV=0
- .I $G(DGBTOTHER)=12 S DGBTDCV=0
- .I $G(DGBTOTHER)=13 S DGBTDCV=0
- .S XY=$S(DGBTDCV>99:"99.00",1:DGBTDCV)
- .N FDA
- .S FDA(392,DGBTDT_",",9)=XY ;Input transform for field 9 is set to max 99
- .S FDA(392,DGBTDT_",",56)="M"
- .D FILE^DIE(,"FDA")
- .W !,"DEDUCTIBLE AMOUNT: "_DGBTDCV_"// "_XY ;," ",$S($G(DGBTREF):"",1:$G(DGBTDCVX))
- .S DGBTDCV=XY
- .S DGBTDE=DGBTDCV
- .I ($G(CHZFLG))&($G(ODED)'=DGBTDE)&($G(MONTOT)'="") D
- ..S $P(MONTOT,U,4)=$P(MONTOT,U,4)+DGBTDE
- ..S $P(MONTOT,U,4)=$P(MONTOT,U,4)-ODED
- CONT ;
- D CONT^DGBTCE1 Q
- EXIT ;
- K DGBTDV1,DGBTRMK Q
- ;
- DENIED(DGBTDT) ;check for a denied claim
- ;
- N DENIED
- S DENIED=$$GET1^DIQ(392,DGBTDT,45.2,"I")
- ;
- Q DENIED
- ADDTO(MONTOT) ;this will add the current trip to the total trips for the month.
- ;
- N TRIPTYP
- I CHZFLG=1 Q MONTOT
- I $D(^DGBT(392,DGBTDT,"M")),$P(^("M"),"^")=1 S TRIPTYP=1
- E S TRIPTYP=2
- I TRIPTYP=1 S $P(MONTOT,"^",1)=$P(MONTOT,"^",1)+1
- I TRIPTYP=2 S $P(MONTOT,"^",1)=$S($P(MONTOT,"^",1)<6:$P(MONTOT,"^",1)+1,1:$P(MONTOT,"^",1)+2)
- ;S $P(MONTOT,"^",1)=$S(TRIPTYP=1:$P(MONTOT,"^",1)+1,1:$P(MONTOT,"^",1)+2) ;add current trip to total for month
- I TRIPTYP=1 S $P(MONTOT,U,2)=$P(MONTOT,U,2)+1
- I TRIPTYP=2 S $P(MONTOT,U,3)=$P(MONTOT,U,3)+1
- S $P(MONTOT,"^",6)=$S(TRIPTYP=1:$P(MONTOT,"^",6)+1,1:$P(MONTOT,"^",6)+2)
- I ($P(MONTOT,U,5)'["Y")&($P(MONTOT,U)>6) S $P(MONTOT,U,5)="YES"
- I ($P(MONTOT,U,5)'["Y")&($P(MONTOT,U,2)>18) S $P(MONTOT,U,5)="YES"
- Q MONTOT
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGBTEE 9291 printed Feb 18, 2025@23:07:04 Page 2
- DGBTEE ;ALB/SCK - BENEFICIARY TRAVEL ENTER/EDIT; 12/3/92@1600 ; 7/2/14 1:17pm
- +1 ;;1.0;Beneficiary Travel;**2,14,20,21,25,30,39**;September 25, 2001;Build 6
- +2 QUIT
- SCREEN ;
- +1 ;
- +2 ;dbe patch DGBT*1.0*25 - added for conversion from SP to M during claim edit
- IF '$DATA(^DGBT(392,DGBTDT,"D"))&('$DATA(^DGBT(392,DGBTDT,"T")))
- SET DGBTSP2M=1
- DO STUFF^DGBTE1
- KILL DGBTSP2M
- +3 DO SCREEN^DGBTEE1
- if $GET(DGBTTOUT)=-1!($GET(DGBTTOUT)=1)
- QUIT
- if '$DATA(^DGBT(392,DGBTDT,0))
- QUIT
- +4 ; The following section of code moved to DGBTEE2 for space problems
- +5 DO STUFF^DGBTEE2
- MILES ; get miles between dep. and dest. using function call to DGBTUTL
- +1 ;
- +2 KILL X,DGBTREC
- SET (DGBTOWRT,DGBTML,DGBTMLT)=""
- +3 ;*39 - updated to use residential address
- IF DGBTFR4]""&((DGBTACCT=4)!(DGBTACCT=5))
- IF $DATA(^DGBT(392.1,"ACS",DGBTFR4,+DGBTADDR(5)))
- Begin DoDot:1
- +4 ; naked ref. refers to file #392.1, "ACS", city. Full reference on line MILES+2^DGBTEE, ^DGBTE(392.1,"ACS",DGBTFR4,+DGBTADDR(5) ;*39 - updated to use residential address
- SET X=$ORDER(^(+DGBTADDR(5),0))
- +5 ; function $$miles passes city's record# and div name to function, mileage value is returned
- +6 IF X'=""
- SET DGBTREC=X
- SET DGBTML=$$MILES^DGBTUTL(DGBTREC,DGBTDV1)
- SET DGBTOWRT="ROUND TRIP"
- KILL X
- End DoDot:1
- +7 SET (DGBTMAL,DGBTFAB,DGBTME,DGBTCP,DGBTFLAG,DGBTDCV,DGBTDE,DGBTDCM,DGBTDPV,DGBTDPM)=0
- DIE1 ; stuff from,to address, meals, ferry's/bridges
- +1 ;
- +2 if '$DATA(^DGBT(392,DGBTDT,0))
- QUIT
- +3 ;
- +4 SET DIE="^DGBT(392,"
- SET DA=DGBTDT
- SET DR=$SELECT($GET(DGBTACCT)=4:"42//"_$GET(DGBTAP),$GET(DGBTACCT)=5:"43;S DGBTCP=X;42//"_$GET(DGBTAP),1:"44")
- +5 DO ^DIE
- IF X=""!(X="^")
- SET DGBTTOUT=-1
- QUIT
- +6 ;
- +7 ;;34////^S X=DGBTMAL;35////^S X=DGBTFAB"
- SET DR="21////^S X=DGBTFR1;22////^S X=DGBTFR2;23////^S X=DGBTFR3;24////^S X=DGBTFR4;25////^S X=DGBTTO1;26////^S X=DGBTTO2;27////^S X=DGBTTO3;28////^S X=DGBTTO4"
- +8 DO ^DIE
- IF X=""!(X="^")
- SET DGBTTOUT=-1
- QUIT
- +9 ;
- +10 IF DGBTACCT=4!(DGBTACCT=5)
- Begin DoDot:1
- +11 WRITE !!,"Please enter mileage obtained from BT Dashboard ..."
- +12 SET DGBTRMK=$SELECT($DATA(DGBTREC):$$DICLKUP^DGBTUTL(DGBTREC,DGBTDV1,4),1:"")
- IF $DATA(DGBTDEF)
- IF DGBTDEF
- SET DGBTRMK="DEFAULT MILEAGE USED"
- +13 IF DGBTRMK]""
- WRITE !,*7,"MILEAGE REMARKS: ",DGBTRMK,!
- End DoDot:1
- +14 ;
- EDIT ; display trip type, mileage
- +1 ;20
- IF ($GET(DGBTACCT)=4)!($GET(DGBTACCT)=5)
- Begin DoDot:1
- +2 IF $GET(CHZFLG)
- NEW OTRIPTYP
- SET OTRIPTYP=$$GET1^DIQ(392,DGBTDT,31,"I")
- +3 ;20
- SET DR="32//"_DGBTML_";S DGBTML=X;31//"_DGBTOWRT_";S DGBTOWRT=X;"
- DO ^DIE
- IF X=""!(X="^")
- SET DGBTTOUT=-1
- QUIT
- +4 IF ($GET(CHZFLG))&($GET(OTRIPTYP)'=$$GET1^DIQ(392,DGBTDT,31,"I"))&($GET(MONTOT)'="")
- Begin DoDot:2
- +5 NEW NTRIPTYP
- SET NTRIPTYP=$$GET1^DIQ(392,DGBTDT,31,"I")
- +6 IF (OTRIPTYP=1)&(NTRIPTYP=2)
- Begin DoDot:3
- +7 SET $PIECE(MONTOT,U)=$PIECE(MONTOT,U)+1
- +8 SET $PIECE(MONTOT,U,2)=$PIECE(MONTOT,U,2)-1
- +9 SET $PIECE(MONTOT,U,3)=$PIECE(MONTOT,U,3)+1
- End DoDot:3
- QUIT
- +10 IF (OTRIPTYP=2)&(NTRIPTYP=1)
- Begin DoDot:3
- +11 SET $PIECE(MONTOT,U)=$PIECE(MONTOT,U)-1
- +12 SET $PIECE(MONTOT,U,2)=$PIECE(MONTOT,U,2)+1
- +13 SET $PIECE(MONTOT,U,3)=$PIECE(MONTOT,U,3)-1
- End DoDot:3
- QUIT
- End DoDot:2
- +14 SET DGBTCCT=$$GET1^DIQ(392,DGBTDT,54,"I")
- +15 ;20
- SET DIR(0)="Y"
- SET DIR("B")=$SELECT($GET(DGBTCCT)'="":"YES",1:"NO")
- SET DIR("A")="COMMON CARRIER USED"
- DO ^DIR
- KILL DIR
- IF $DATA(DIRUT)
- SET DGBTTOUT=-1
- QUIT
- +16 IF 'Y
- IF $DATA(^DGBT(392,DGBTDT,"C"))
- SET $PIECE(^DGBT(392,DGBTDT,"A"),"^",4)=""
- FOR I="B","C"
- KILL ^DGBT(392,DGBTDT,I)
- +17 ;20
- IF Y
- Begin DoDot:2
- +18 ;20
- KILL DA,DR,DIE,Y
- SET DIE="^DGBT(392,"
- SET DA=DGBTDT
- SET DR="44COMMON CARRIER MODE~R"
- DO ^DIE
- IF $DATA(Y)
- SET DGBTTOUT=-1
- QUIT
- +19 ;20
- KILL DA,DR,DIE,Y
- SET DIE="^DGBT(392,"
- SET DA=DGBTDT
- IF $$UP^XLFSTR($$GET1^DIQ(392,DGBTDT,44))["BUS"
- SET DR="52R"
- DO ^DIE
- IF $DATA(Y)
- SET DGBTTOUT=-1
- QUIT
- +20 ;20
- KILL DA,DR,DIE,Y
- IF $$GET1^DIQ(392,DGBTDT,52)="PASS"
- SET DIE="^DGBT(392,"
- SET DA=DGBTDT
- SET DR="53R"
- DO ^DIE
- IF $DATA(Y)
- SET DGBTTOUT=-1
- QUIT
- +21 ;prevents future dates Coder CR 53 for DG*1.0*20
- NEW %DT
- SET %DT(0)="-NOW"
- +22 ;20 PAVEL - DGBT*1*20
- KILL DA,DR,DIE,Y
- SET DIE="^DGBT(392,"
- SET DA=DGBTDT
- SET DR="54//"_$PIECE(DGBTDTE,"@",1)_";55;55.1"
- DO ^DIE
- IF $DATA(Y)
- SET DGBTTOUT=-1
- QUIT
- End DoDot:2
- End DoDot:1
- if $GET(DGBTTOUT)=-1
- QUIT
- +23 if DGBTACCT=5&(DGBTCP=1)
- SET DGBTMR=DGBTMR1
- SET DGBTMLT=DGBTOWRT*DGBTML*DGBTMR
- SET DGBTMLT=$JUSTIFY(DGBTMLT,0,2)
- SET DR="33///"_DGBTMLT
- +24 DO ^DIE
- IF X=""!(X="^")
- SET DGBTTOUT=-1
- QUIT
- +25 IF $GET(^DGBT(392,DGBTDTI,"C"))=""
- KILL ^DGBT(392,DGBTDTI,"C"),DGBTVAR("C")
- +26 ;
- DIE2 ; stuff eligibility data, SC%, acct. type
- +1 ;
- +2 SET DIE("NO^")="12345"
- if '$DATA(DGBTCD)
- SET DGBTCD=""
- +3 IF 'DGBTCORE
- Begin DoDot:1
- +4 SET DR="3////"_DGBTELIG_";4////"_DGBTSCP_";5///"_DGBTCD_";6////"_DGBTACTN_";I DGBTACCT=4!(DGBTACCT=5) S Y=""@1"";41;7;@1;I DGBTMLFB=0 S Y=""@2"";34//0;W:'X X S DGBTMAL=X;35//0;W:'X X S DGBTFAB=X;@2"
- End DoDot:1
- +5 IF DGBTCORE
- Begin DoDot:1
- +6 SET DR(1,392,1)="3////"_DGBTELIG_";4////"_DGBTSCP_";5///"_DGBTCD_";6////"_DGBTACTN_";I DGBTACCT=4!(DGBTACCT=5) S Y=""@1"";41;"
- +7 SET DR(1,392,2)="@3;14;S DGBTCSL=$$AFTER^DGBTCSL(392,D0,X,$G(DGBTPRV)) S:DGBTCSL<1 Y=""@3"" W:DGBTCSL<1 "" Required"" K DGBTPRV,DGBTCSL;@1;I DGBTMLFB=0 S Y=""@2"";34//0;S DGBTMAL=X;35//0;S DGBTFAB=X;@2"
- End DoDot:1
- +8 ;
- +9 ;DIE3 ; get most econ. cost
- +10 ;
- +11 DO ^DIE
- KILL DR
- IF $GET(DTOUT)!(X="^")
- SET DGBTTOUT=-1
- QUIT
- +12 ;
- +13 ;check for common carrier
- +14 SET DGBTMAF=$GET(DGBTFAB)+$GET(DGBTMAL)
- +15 SET (DGBTCC,DGBTCCAMT,DGBTCCREQ,DGBTCCMODE,DGBTMETC)=0
- +16 SET DGBTDCM=$PIECE(MONTOT,"^",4)
- +17 SET DGBTDCM=$SELECT(DGBTMLT-DGBTDCM'>0:DGBTMLT,1:DGBTDCM)
- +18 IF $DATA(^DGBT(392,DGBTDTI,"C"))
- Begin DoDot:1
- +19 ;was common carrier used
- SET DGBTCC=$DATA(^DGBT(392,DGBTDTI,"C"))
- +20 ; amount of common carrier
- SET DGBTCCAMT=$$GET1^DIQ(392,DGBTDTI,55)
- +21 ;common carrier required - 1=yes,0=no
- SET DGBTCCREQ=$$GET1^DIQ(392,DGBTDTI,55.1)
- SET DGBTCCREQ=$SELECT(DGBTCCREQ="YES":1,1:0)
- +22 ;common carrier mode of transportation
- SET DGBTCCMODE=$$GET1^DIQ(392,DGBTDTI,44,"I")
- +23 ;$S($D(DGBTMAL):DGBTMAL,1:0) ;most enco + meals and lodging S DGBTDCM=$P(MONTOT,"^",4) S DGBTDCM=$P(MONTOT,"^",4) S DGBTMAF=$S(DGBTMLFB:DGBTMAL+DGBTFAB,1:0),DGBTMETC=DGBTME+$S($D(DGBTMAL):DGBTMAL,1:0)
- SET DGBTMETC=$GET(DGBTME)+$GET(DGBTMAL)
- End DoDot:1
- +24 ;
- +25 ;if CC not required reset most econ to 0
- +26 IF $GET(DGBTCCREQ)
- Begin DoDot:1
- +27 SET FDA(392,DGBTDTI_",",8)=0
- +28 DO FILE^DIE(,"FDA")
- End DoDot:1
- +29 if $DATA(DGBTREC)
- SET DGBTME=$$DICLKUP^DGBTUTL(DGBTREC,DGBTDV1,3)
- if DGBTME=""
- SET DGBTME=0
- SET DR="8//"_DGBTME_";W:'X X S DGBTME=X"
- DO ^DIE
- IF X=""!(X="^")
- SET DGBTTOUT=-1
- GOTO EXIT
- TCOST ; calculate total cost and monthly cum. deductible
- MLFB ;
- +1 ;
- +2 NEW OWAIV
- +3 SET OWAIV=$PIECE(MONTOT,U,5)
- +4 SET MONTOT=$$ADDTO(.MONTOT)
- +5 IF DGBTACCT'=4&(DGBTACCT'=5)
- SET DGBTPA=DGBTMAF+DGBTME
- GOTO CONT
- +6 IF $DATA(DGBTMLT)
- Begin DoDot:1
- +7 IF DGBTMLT+DGBTMAF'>DGBTMETC
- SET DGBTTC=DGBTMLT+DGBTMAF
- QUIT
- +8 IF DGBTMLT+DGBTMAF>DGBTMETC&(DGBTME>0)
- SET DGBTTC=DGBTMETC
- QUIT
- +9 IF DGBTME'>0
- SET DGBTTC=DGBTMLT+DGBTMAF
- QUIT
- +10 IF '$TEST
- SET DGBTTC=DGBTMETC
- End DoDot:1
- +11 IF $GET(DGBTCCREQ)
- SET DGBTTC=$GET(DGBTTC)+DGBTCCAMT
- +12 ;G CONT
- IF DGBTACCT=5
- SET DGBTDE=0
- SET DGBTPA=$SELECT((DGBTMLT+DGBTMAF)'=0:DGBTTC,1:DGBTMETC)
- +13 ; the following section of code moved to DGBTEE2 for space reasons
- +14 IF DGBTACCT'=5
- Begin DoDot:1
- +15 NEW DGBTDCVX,XY
- +16 IF $GET(CHZFLG)
- NEW ODED
- SET ODED=$$GET1^DIQ(392,DGBTDT,9)
- +17 DO DED^DGBTEE2
- +18 IF $PIECE($GET(MONTOT),"^",5)'["Y"
- SET DGBTDCV=DGBTDCV1
- +19 ;add by Pavel for patch 20
- +20 IF $GET(DGBTCC)
- IF $GET(DGBTCCREQ)
- IF '$GET(DGBTMLT)
- SET DGBTDCV=0
- +21 IF $GET(DGBTCC)
- IF '$GET(DGBTCCREQ)
- IF $GET(DGBTMLT)'>0
- SET DGBTDCV=0
- +22 IF $GET(DGBTCC)
- IF '$GET(DGBTCCREQ)
- IF $GET(DGBTME)'>0
- +23 IF $GET(DGBTCC)
- IF '$GET(DGBTCCREQ)
- IF $GET(DGBTME)>0
- IF $GET(DGBTME)'>$GET(DGBTMLT)
- SET DGBTDCV=0
- +24 IF $GET(DGBTCC)
- IF $GET(DGBTCCREQ)
- IF $GET(DGBTDE)'<$GET(DGBTMLT)
- SET DGBTDE=DGBTMLT
- +25 IF '$GET(DGBTCC)
- IF '$GET(DGBTCCREQ)
- IF $GET(DGBTMLT)'>0
- SET DGBTDCV=0
- +26 IF '$GET(DGBTCC)
- IF DGBTMLT>DGBTDPV
- SET (DGBTDCV,DGBTDE)=DGBTDPV
- +27 IF ($GET(CHZFLG))&($$GET1^DIQ(392,DGBTDT,9)=0)&($PIECE($GET(MONTOT),U,5)["Y")
- SET (DGBTDCV,DGBTE)=0
- +28 ;dbe patch DGBT*1.0*25 - modified the next line to use the total deductible for the month, MONTOT piece 4
- +29 ; RFE 12/5/12
- IF (+$PIECE($GET(MONTOT),U,4)<18)&((+$PIECE($GET(MONTOT),U,4)+DGBTDCV)>18)&(OWAIV'["Y")&('$GET(CHZFLG))
- SET DGBTDCV=18-$PIECE(MONTOT,U,4)
- SET $PIECE(MONTOT,U,5)="NO"
- +30 ; RFE 12/5/12 ;*30
- IF (+$GET(CHZFLG)&(($PIECE($GET(MONTOT),U,7)+DGBTDCV)>18))
- SET DGBTDCV=18-$PIECE(MONTOT,U,7)
- SET $PIECE(MONTOT,U,5)="NO"
- +31 ; Added ELSE RFE 12/5/12
- IF (+$PIECE($GET(MONTOT),U,1)>6)!(+$PIECE($GET(MONTOT),U,4)>18)!($PIECE($GET(MONTOT),U,5)["Y")&('$GET(CHZFLG))
- SET DGBTDCV=0
- +32 IF $$DENIED(DGBTDT)
- SET DGBTDCV=0
- +33 IF $GET(CHZFLG)=0
- SET ($PIECE(MONTOT,U,4),$PIECE(MONTOT,U,7))=$PIECE(MONTOT,U,4)+DGBTDCV
- +34 SET DGBTOTHER=$$GET1^DIQ(392,DGBTDT,43.1,"I")
- +35 IF $GET(DGBTNSC)
- SET DGBTDCV=0
- +36 IF $GET(DGBTOTHER)=11
- SET DGBTDCV=0
- +37 IF $GET(DGBTOTHER)=12
- SET DGBTDCV=0
- +38 IF $GET(DGBTOTHER)=13
- SET DGBTDCV=0
- +39 SET XY=$SELECT(DGBTDCV>99:"99.00",1:DGBTDCV)
- +40 NEW FDA
- +41 ;Input transform for field 9 is set to max 99
- SET FDA(392,DGBTDT_",",9)=XY
- +42 SET FDA(392,DGBTDT_",",56)="M"
- +43 DO FILE^DIE(,"FDA")
- +44 ;," ",$S($G(DGBTREF):"",1:$G(DGBTDCVX))
- WRITE !,"DEDUCTIBLE AMOUNT: "_DGBTDCV_"// "_XY
- +45 SET DGBTDCV=XY
- +46 SET DGBTDE=DGBTDCV
- +47 IF ($GET(CHZFLG))&($GET(ODED)'=DGBTDE)&($GET(MONTOT)'="")
- Begin DoDot:2
- +48 SET $PIECE(MONTOT,U,4)=$PIECE(MONTOT,U,4)+DGBTDE
- +49 SET $PIECE(MONTOT,U,4)=$PIECE(MONTOT,U,4)-ODED
- End DoDot:2
- End DoDot:1
- CONT ;
- +1 DO CONT^DGBTCE1
- QUIT
- EXIT ;
- +1 KILL DGBTDV1,DGBTRMK
- QUIT
- +2 ;
- DENIED(DGBTDT) ;check for a denied claim
- +1 ;
- +2 NEW DENIED
- +3 SET DENIED=$$GET1^DIQ(392,DGBTDT,45.2,"I")
- +4 ;
- +5 QUIT DENIED
- ADDTO(MONTOT) ;this will add the current trip to the total trips for the month.
- +1 ;
- +2 NEW TRIPTYP
- +3 IF CHZFLG=1
- QUIT MONTOT
- +4 IF $DATA(^DGBT(392,DGBTDT,"M"))
- IF $PIECE(^("M"),"^")=1
- SET TRIPTYP=1
- +5 IF '$TEST
- SET TRIPTYP=2
- +6 IF TRIPTYP=1
- SET $PIECE(MONTOT,"^",1)=$PIECE(MONTOT,"^",1)+1
- +7 IF TRIPTYP=2
- SET $PIECE(MONTOT,"^",1)=$SELECT($PIECE(MONTOT,"^",1)<6:$PIECE(MONTOT,"^",1)+1,1:$PIECE(MONTOT,"^",1)+2)
- +8 ;S $P(MONTOT,"^",1)=$S(TRIPTYP=1:$P(MONTOT,"^",1)+1,1:$P(MONTOT,"^",1)+2) ;add current trip to total for month
- +9 IF TRIPTYP=1
- SET $PIECE(MONTOT,U,2)=$PIECE(MONTOT,U,2)+1
- +10 IF TRIPTYP=2
- SET $PIECE(MONTOT,U,3)=$PIECE(MONTOT,U,3)+1
- +11 SET $PIECE(MONTOT,"^",6)=$SELECT(TRIPTYP=1:$PIECE(MONTOT,"^",6)+1,1:$PIECE(MONTOT,"^",6)+2)
- +12 IF ($PIECE(MONTOT,U,5)'["Y")&($PIECE(MONTOT,U)>6)
- SET $PIECE(MONTOT,U,5)="YES"
- +13 IF ($PIECE(MONTOT,U,5)'["Y")&($PIECE(MONTOT,U,2)>18)
- SET $PIECE(MONTOT,U,5)="YES"
- +14 QUIT MONTOT
- +15 ;