- IBCU2 ;ALB/MRL - BILLING UTILITY ROUTINE (CONTINUED) ;01 JUN 88 12:00
- ;;2.0;INTEGRATED BILLING;**137,287,432**;21-MAR-94;Build 192
- ;;Per VHA Directive 2004-038, this routine should not be modified.
- ;
- ;MAP TO DGCRU2
- ;
- TC D TCL
- N DA,X,Y
- F DGJ=0:0 S DGJ=$O(^DD(399,201,1,DGJ)) Q:'DGJ I $D(^DD(399,201,1,DGJ,DGXRF)) S DA=DGI(1),X=DGTCX1 X ^(DGXRF)
- K DGI,DGJ,DGXRF,DGTCX,DGTCX1,DGTCX2
- Q
- ;
- TCL S (DGTCX,DGTCX2)=0 F DGTCX1=0:0 S DGTCX1=$O(^DGCR(399,DA(1),"RC",DGTCX1)) Q:'DGTCX1 I $D(^DGCR(399,DA(1),"RC",DGTCX1,0)),DGTCX1'=DA S DGTCX=DGTCX+$P(^(0),"^",4)
- I DGXRF=1 S DGTCX1=DGTCX+X
- E S DGTCX1=DGTCX
- S $P(^DGCR(399,DA(1),"U1"),"^",1)=DGTCX1,DGI=DA,DGI(1)=DA(1),DGTCX=X
- Q
- ;
- TC1 F DGJ1=0:0 S DGJ1=$O(^DD(399.042,.04,1,DGJ1)) Q:'DGJ1 I $D(^DD(399.042,.04,1,DGJ1,DGXRF1)) S X=DGTCX11 X ^(DGXRF1)
- S X=DGTCX11 K DGJ1,DGXRF11,DGTCX11
- Q
- ;
- FY ;S DGTCX1=$S($D(^DGCR(399,DA,"U1")):^("U1"),1:0) I +X>+DGTCX1 W !?4,*7,"Exceeds 'Total Charges' for this bill." K X Q
- ;W !?4,"Edit revenue codes/from-to dates if appropriate." K X Q
- Q
- ;
- 21 ;set logic for CHARGES subfield x-ref (399.042;.02)
- I $P(^DGCR(399,DA(1),"RC",DA,0),"^",3)="" S $P(^DGCR(399,DA(1),"RC",DA,0),"^",3)=$S($P(^DGCR(399,DA(1),0),"^",5)<3:$P(^("U"),"^",15),$D(^DGCR(399,DA(1),"OP",0)):$P(^(0),"^",4),1:1)
- ; DEM;432 - Changed Z*Z1 to $FN(Z*Z1,"",2) for inclusion of decimal point.
- S Z=X,Z1=$P(^DGCR(399,DA(1),"RC",DA,0),"^",3) S DGTCX11=$FN(Z*Z1,"",2),$P(^(0),"^",4)=DGTCX11,DGXRF1=1 D TC1
- Q
- ;
- 22 ;kill logic for CHARGES subfield x-ref (399.042;.02)
- ; DEM;432 - Changed Z*Z1 to $FN(Z*Z1,"",2) for inclusion of decimal point.
- S Z=X,Z1=$P(^DGCR(399,DA(1),"RC",DA,0),"^",3) S DGTCX11=$FN(Z*Z1,"",2),$P(^(0),"^",4)=DGTCX11,DGXRF1=2 D TC1
- Q
- ;
- 31 ;set logic for UNITS OF SERVICE subfield x-ref (399.042;.03)
- ; DEM;432 - Changed Z*Z1 to $FN(Z*Z1,"",2) for inclusion of decimal point.
- S Z=X,Z1=$P(^DGCR(399,DA(1),"RC",DA,0),"^",2) S DGTCX11=$FN(Z*Z1,"",2),$P(^(0),"^",4)=DGTCX11,DGXRF1=1 D TC1
- Q
- ;
- 32 ;kill logic for UNITS OF SERVICE subfield x-ref (399.042;.03)
- ; DEM;432 - Changed Z*Z1 to $FN(Z*Z1,"",2) for inclusion of decimal point.
- S Z=X,Z1=$P(^DGCR(399,DA(1),"RC",DA,0),"^",2) S DGTCX11=$FN(Z*Z1,"",2),$P(^(0),"^",4)=DGTCX11,DGXRF1=2 D TC1
- Q
- ;
- FMDATES(PROMPT) ; ask for date range
- N %DT,X,Y,DT1,DT2,IB1,IB2 S DT1="",IB1="START WITH DATE ENTERED: ",IB2="GO TO DATE ENTERED: "
- I $G(PROMPT)'="" S IB1="START WITH "_PROMPT_": ",IB2="GO TO "_PROMPT_": "
- S %DT="AEX",%DT("A")=IB1 D ^%DT K %DT I Y<0!($P(Y,".",1)'?7N) G FMDQ
- S (%DT(0),DT2)=$P(Y,".",1) I DT2'>DT S %DT("B")="TODAY"
- S %DT="AEX",%DT("A")=IB2 D ^%DT K %DT I Y<0!($P(Y,".",1)'?7N) G FMDQ
- S DT1=DT2_"^"_$P(Y,".",1)
- FMDQ Q DT1
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCU2 2730 printed Jan 18, 2025@03:21:49 Page 2
- IBCU2 ;ALB/MRL - BILLING UTILITY ROUTINE (CONTINUED) ;01 JUN 88 12:00
- +1 ;;2.0;INTEGRATED BILLING;**137,287,432**;21-MAR-94;Build 192
- +2 ;;Per VHA Directive 2004-038, this routine should not be modified.
- +3 ;
- +4 ;MAP TO DGCRU2
- +5 ;
- TC DO TCL
- +1 NEW DA,X,Y
- +2 FOR DGJ=0:0
- SET DGJ=$ORDER(^DD(399,201,1,DGJ))
- if 'DGJ
- QUIT
- IF $DATA(^DD(399,201,1,DGJ,DGXRF))
- SET DA=DGI(1)
- SET X=DGTCX1
- XECUTE ^(DGXRF)
- +3 KILL DGI,DGJ,DGXRF,DGTCX,DGTCX1,DGTCX2
- +4 QUIT
- +5 ;
- TCL SET (DGTCX,DGTCX2)=0
- FOR DGTCX1=0:0
- SET DGTCX1=$ORDER(^DGCR(399,DA(1),"RC",DGTCX1))
- if 'DGTCX1
- QUIT
- IF $DATA(^DGCR(399,DA(1),"RC",DGTCX1,0))
- IF DGTCX1'=DA
- SET DGTCX=DGTCX+$PIECE(^(0),"^",4)
- +1 IF DGXRF=1
- SET DGTCX1=DGTCX+X
- +2 IF '$TEST
- SET DGTCX1=DGTCX
- +3 SET $PIECE(^DGCR(399,DA(1),"U1"),"^",1)=DGTCX1
- SET DGI=DA
- SET DGI(1)=DA(1)
- SET DGTCX=X
- +4 QUIT
- +5 ;
- TC1 FOR DGJ1=0:0
- SET DGJ1=$ORDER(^DD(399.042,.04,1,DGJ1))
- if 'DGJ1
- QUIT
- IF $DATA(^DD(399.042,.04,1,DGJ1,DGXRF1))
- SET X=DGTCX11
- XECUTE ^(DGXRF1)
- +1 SET X=DGTCX11
- KILL DGJ1,DGXRF11,DGTCX11
- +2 QUIT
- +3 ;
- FY ;S DGTCX1=$S($D(^DGCR(399,DA,"U1")):^("U1"),1:0) I +X>+DGTCX1 W !?4,*7,"Exceeds 'Total Charges' for this bill." K X Q
- +1 ;W !?4,"Edit revenue codes/from-to dates if appropriate." K X Q
- +2 QUIT
- +3 ;
- 21 ;set logic for CHARGES subfield x-ref (399.042;.02)
- +1 IF $PIECE(^DGCR(399,DA(1),"RC",DA,0),"^",3)=""
- SET $PIECE(^DGCR(399,DA(1),"RC",DA,0),"^",3)=$SELECT($PIECE(^DGCR(399,DA(1),0),"^",5)<3:$PIECE(^("U"),"^",15),$DATA(^DGCR(399,DA(1),"OP",0)):$PIECE(^(0),"^",4),1:1)
- +2 ; DEM;432 - Changed Z*Z1 to $FN(Z*Z1,"",2) for inclusion of decimal point.
- +3 SET Z=X
- SET Z1=$PIECE(^DGCR(399,DA(1),"RC",DA,0),"^",3)
- SET DGTCX11=$FNUMBER(Z*Z1,"",2)
- SET $PIECE(^(0),"^",4)=DGTCX11
- SET DGXRF1=1
- DO TC1
- +4 QUIT
- +5 ;
- 22 ;kill logic for CHARGES subfield x-ref (399.042;.02)
- +1 ; DEM;432 - Changed Z*Z1 to $FN(Z*Z1,"",2) for inclusion of decimal point.
- +2 SET Z=X
- SET Z1=$PIECE(^DGCR(399,DA(1),"RC",DA,0),"^",3)
- SET DGTCX11=$FNUMBER(Z*Z1,"",2)
- SET $PIECE(^(0),"^",4)=DGTCX11
- SET DGXRF1=2
- DO TC1
- +3 QUIT
- +4 ;
- 31 ;set logic for UNITS OF SERVICE subfield x-ref (399.042;.03)
- +1 ; DEM;432 - Changed Z*Z1 to $FN(Z*Z1,"",2) for inclusion of decimal point.
- +2 SET Z=X
- SET Z1=$PIECE(^DGCR(399,DA(1),"RC",DA,0),"^",2)
- SET DGTCX11=$FNUMBER(Z*Z1,"",2)
- SET $PIECE(^(0),"^",4)=DGTCX11
- SET DGXRF1=1
- DO TC1
- +3 QUIT
- +4 ;
- 32 ;kill logic for UNITS OF SERVICE subfield x-ref (399.042;.03)
- +1 ; DEM;432 - Changed Z*Z1 to $FN(Z*Z1,"",2) for inclusion of decimal point.
- +2 SET Z=X
- SET Z1=$PIECE(^DGCR(399,DA(1),"RC",DA,0),"^",2)
- SET DGTCX11=$FNUMBER(Z*Z1,"",2)
- SET $PIECE(^(0),"^",4)=DGTCX11
- SET DGXRF1=2
- DO TC1
- +3 QUIT
- +4 ;
- FMDATES(PROMPT) ; ask for date range
- +1 NEW %DT,X,Y,DT1,DT2,IB1,IB2
- SET DT1=""
- SET IB1="START WITH DATE ENTERED: "
- SET IB2="GO TO DATE ENTERED: "
- +2 IF $GET(PROMPT)'=""
- SET IB1="START WITH "_PROMPT_": "
- SET IB2="GO TO "_PROMPT_": "
- +3 SET %DT="AEX"
- SET %DT("A")=IB1
- DO ^%DT
- KILL %DT
- IF Y<0!($PIECE(Y,".",1)'?7N)
- GOTO FMDQ
- +4 SET (%DT(0),DT2)=$PIECE(Y,".",1)
- IF DT2'>DT
- SET %DT("B")="TODAY"
- +5 SET %DT="AEX"
- SET %DT("A")=IB2
- DO ^%DT
- KILL %DT
- IF Y<0!($PIECE(Y,".",1)'?7N)
- GOTO FMDQ
- +6 SET DT1=DT2_"^"_$PIECE(Y,".",1)
- FMDQ QUIT DT1
- +1 ;