BQIIPRVG ;VNGT/HS/ALA-IPC Revenue Generated ; 04 May 2011 10:59 AM
;;2.4;ICARE MANAGEMENT SYSTEM;;Apr 01, 2015;Build 41
;
;
EN(BQDATE) ;EP
NEW BQMON,BQDTE,BEGDT,ENDT,EDAY,ID,PROV,BQTOTV,BQTOTP,FAC
NEW FC,TVIS,TPD,CL,QFL,CRST
S QFL=0
S CRST=$P($G(^BQI(90508,1,11)),U,2) S:CRST="" CRST=1
S CRST="0"_CRST
;
I $G(BQDATE)'="" D
. S BEGDT=$E(BQDATE,1,5)_"01",CYR=$E(BQDATE,1,3),BQMON=$E(BQDATE,4,5)
. I $L(BQMON)=1 S BQMON="0"_BQMON
. S EDAY="31^"_($$LEAP^XLFDT2(CYR)+28)_"^31^30^31^30^31^31^30^31^30^31"
. S ENDT=$E(BQDATE,1,5)_$P(EDAY,U,+BQMON)
;
I $G(BQDATE)="" D Q:QFL
. I $E(DT,6,7)'=CRST S QFL=1 Q
. S BQMON=$E(DT,4,5)-1,CYR=$E(DT,1,3),PYR=CYR-1
. I $L(BQMON)=1 S BQMON="0"_BQMON
. S BQDTE=$P($T(BQM+BQMON),";;",2)
. S BEGDT=@($P(BQDTE,U,2))_$P(BQDTE,U,1)_"01"
. S EDAY="31^"_($$LEAP^XLFDT2(CYR)+28)_"^31^30^31^30^31^31^30^31^30^31"
. S ENDT=@($P(BQDTE,U,2))_$P(BQDTE,U,1)_$P(EDAY,U,+$P(BQDTE,U,1))
. S BQDATE=$S(BQMON="01":PYR,1:CYR)_BQMON_"00"
;
S ID="IPC_REVG"
;
S PROV="",BQTOTV=0,BQTOTP=0
F S PROV=$O(^AUPNPAT("AK",PROV)) Q:PROV="" D
. I $P(^VA(200,PROV,0),U,13)'="" Q
. D PRV(PROV)
. D STORP^BQIIPUTL(PROV,ID,BQDATE,TVIS,TPD)
;
S FAC=$$HME^BQIGPUTL()
D STORF^BQIIPUTL(FAC,ID,BQDATE,BQTOTV,BQTOTP)
Q
; Set over all for facility
NEW DA,DIC,FAC,DLAYGO,MSRN
S FAC=$P(^BQI(90508,1,0),U,1)
I '$D(^BQIFAC(FAC,30,0)) S ^BQIFAC(FAC,30,0)="^90505.63^^"
S DA(1)=FAC,DIC(0)="LMNZ",DLAYGO=90505.63,X=ID,DIC="^BQIFAC("_DA(1)_",30,"
D ^DIC I Y=-1 K DO,DD D FILE^DICN
S MSRN=+Y
I '$D(^BQIFAC(FAC,30,MSRN,1,0)) S ^BQIFAC(FAC,30,MSRN,1,0)="^90505.631D^^"
S DA(2)=FAC,DA(1)=MSRN,DIC(0)="LMNZ",DLAYGO=90505.631,X=BQDATE
S DIC="^BQIFAC("_DA(2)_",30,"_DA(1)_",1,"
D ^DIC I Y=-1 K DO,DD D FILE^DICN
S DA=+Y
S $P(^BQIFAC(FAC,30,MSRN,1,DA,0),U,2,3)=BQTOTP_U_BQTOTV
;
K BARP,BAR,BARQ,BARY,BQTOTV,BQTOTP
Q
;
PRV(PROV) ;EP
I $T(COMPUTE^BARDRST)="" D Q
. S TVIS=0,BQTOTV=BQTOTV+TVIS
. S TPD=0,BQTOTP=BQTOTP+TPD
K BARP,BAR,BARQ,BARY
S BARP("RTN")="BARDRST"
S BAR("LOC")="VISIT"
S BAR("LVL")=3
S BAR("OPT")="STA"
S BAR("PAY")=""
S BAR("RTYP")=0
S BAR("STATUS")=0
S BARQ("NS")="BAR"
S BARQ("RC")="COMPUTE^BARDRST"
S BARQ("RP")="PRT^BQIIPRVG"
S BARQ("RX")="POUT^BARRUTL"
S BARY("DT")="V"
S BARY("DT",1)=BEGDT
S BARY("DT",2)=ENDT
S BARY("PRV")=PROV
S BARY("SORT")="C"
D COMPUTE^BARDRST
S FC=1
S TVIS=0,TPD=0
F S FC=$O(BAR(FC)) Q:'FC D
. S CL=""
. F S CL=$O(BAR(FC,CL)) Q:CL="" D
.. S TVIS=TVIS+$P(BAR(FC,CL),U,1),BQTOTV=BQTOTV+TVIS
.. S TPD=TPD+$P(BAR(FC,CL),U,4),BQTOTP=BQTOTP+TPD
K BARP,BAR,BARQ,BARY
Q
;
PRT ;
Q
;
STORP ; Store for provider
NEW DA,DIC,MSRN,DLAYGO,X
I '$D(^BQIPROV(PROV,30,0)) S ^BQIPROV(PROV,30,0)="^90505.43^^"
S DA(1)=PROV,DIC(0)="LMNZ",DLAYGO=90505.43,X=ID,DIC="^BQIPROV("_DA(1)_",30,"
D ^DIC I Y=-1 K DO,DD D FILE^DICN
S MSRN=+Y
I '$D(^BQIPROV(PROV,30,MSRN,1,0)) S ^BQIPROV(PROV,30,MSRN,1,0)="^90505.431D^^"
S DA(2)=PROV,DA(1)=MSRN,DIC(0)="LMNZ",DLAYGO=90505.431,X=BQDATE
S DIC="^BQIPROV("_DA(2)_",30,"_DA(1)_",1,"
D ^DIC I Y=-1 K DO,DD D FILE^DICN
S DA=+Y
S $P(^BQIPROV(PROV,30,MSRN,1,DA,0),U,2,3)=TPD_U_TVIS
K TVIS,TPD
Q
;
BQM ;
;;09^PYR
;;10^PYR
;;11^PYR
;;12^PYR
;;01^CYR
;;02^CYR
;;03^CYR
;;04^CYR
;;05^CYR
;;06^CYR
;;07^CYR
;;08^CYR
BQIIPRVG ;VNGT/HS/ALA-IPC Revenue Generated ; 04 May 2011 10:59 AM
+1 ;;2.4;ICARE MANAGEMENT SYSTEM;;Apr 01, 2015;Build 41
+2 ;
+3 ;
EN(BQDATE) ;EP
+1 NEW BQMON,BQDTE,BEGDT,ENDT,EDAY,ID,PROV,BQTOTV,BQTOTP,FAC
+2 NEW FC,TVIS,TPD,CL,QFL,CRST
+3 SET QFL=0
+4 SET CRST=$PIECE($GET(^BQI(90508,1,11)),U,2)
IF CRST=""
SET CRST=1
+5 SET CRST="0"_CRST
+6 ;
+7 IF $GET(BQDATE)'=""
Begin DoDot:1
+8 SET BEGDT=$EXTRACT(BQDATE,1,5)_"01"
SET CYR=$EXTRACT(BQDATE,1,3)
SET BQMON=$EXTRACT(BQDATE,4,5)
+9 IF $LENGTH(BQMON)=1
SET BQMON="0"_BQMON
+10 SET EDAY="31^"_($$LEAP^XLFDT2(CYR)+28)_"^31^30^31^30^31^31^30^31^30^31"
+11 SET ENDT=$EXTRACT(BQDATE,1,5)_$PIECE(EDAY,U,+BQMON)
End DoDot:1
+12 ;
+13 IF $GET(BQDATE)=""
Begin DoDot:1
+14 IF $EXTRACT(DT,6,7)'=CRST
SET QFL=1
QUIT
+15 SET BQMON=$EXTRACT(DT,4,5)-1
SET CYR=$EXTRACT(DT,1,3)
SET PYR=CYR-1
+16 IF $LENGTH(BQMON)=1
SET BQMON="0"_BQMON
+17 SET BQDTE=$PIECE($TEXT(BQM+BQMON),";;",2)
+18 SET BEGDT=@($PIECE(BQDTE,U,2))_$PIECE(BQDTE,U,1)_"01"
+19 SET EDAY="31^"_($$LEAP^XLFDT2(CYR)+28)_"^31^30^31^30^31^31^30^31^30^31"
+20 SET ENDT=@($PIECE(BQDTE,U,2))_$PIECE(BQDTE,U,1)_$PIECE(EDAY,U,+$PIECE(BQDTE,U,1))
+21 SET BQDATE=$SELECT(BQMON="01":PYR,1:CYR)_BQMON_"00"
End DoDot:1
IF QFL
QUIT
+22 ;
+23 SET ID="IPC_REVG"
+24 ;
+25 SET PROV=""
SET BQTOTV=0
SET BQTOTP=0
+26 FOR
SET PROV=$ORDER(^AUPNPAT("AK",PROV))
IF PROV=""
QUIT
Begin DoDot:1
+27 IF $PIECE(^VA(200,PROV,0),U,13)'=""
QUIT
+28 DO PRV(PROV)
+29 DO STORP^BQIIPUTL(PROV,ID,BQDATE,TVIS,TPD)
End DoDot:1
+30 ;
+31 SET FAC=$$HME^BQIGPUTL()
+32 DO STORF^BQIIPUTL(FAC,ID,BQDATE,BQTOTV,BQTOTP)
+33 QUIT
+34 ; Set over all for facility
+35 NEW DA,DIC,FAC,DLAYGO,MSRN
+36 SET FAC=$PIECE(^BQI(90508,1,0),U,1)
+37 IF '$DATA(^BQIFAC(FAC,30,0))
SET ^BQIFAC(FAC,30,0)="^90505.63^^"
+38 SET DA(1)=FAC
SET DIC(0)="LMNZ"
SET DLAYGO=90505.63
SET X=ID
SET DIC="^BQIFAC("_DA(1)_",30,"
+39 DO ^DIC
IF Y=-1
KILL DO,DD
DO FILE^DICN
+40 SET MSRN=+Y
+41 IF '$DATA(^BQIFAC(FAC,30,MSRN,1,0))
SET ^BQIFAC(FAC,30,MSRN,1,0)="^90505.631D^^"
+42 SET DA(2)=FAC
SET DA(1)=MSRN
SET DIC(0)="LMNZ"
SET DLAYGO=90505.631
SET X=BQDATE
+43 SET DIC="^BQIFAC("_DA(2)_",30,"_DA(1)_",1,"
+44 DO ^DIC
IF Y=-1
KILL DO,DD
DO FILE^DICN
+45 SET DA=+Y
+46 SET $PIECE(^BQIFAC(FAC,30,MSRN,1,DA,0),U,2,3)=BQTOTP_U_BQTOTV
+47 ;
+48 KILL BARP,BAR,BARQ,BARY,BQTOTV,BQTOTP
+49 QUIT
+50 ;
PRV(PROV) ;EP
+1 IF $TEXT(COMPUTE^BARDRST)=""
Begin DoDot:1
+2 SET TVIS=0
SET BQTOTV=BQTOTV+TVIS
+3 SET TPD=0
SET BQTOTP=BQTOTP+TPD
End DoDot:1
QUIT
+4 KILL BARP,BAR,BARQ,BARY
+5 SET BARP("RTN")="BARDRST"
+6 SET BAR("LOC")="VISIT"
+7 SET BAR("LVL")=3
+8 SET BAR("OPT")="STA"
+9 SET BAR("PAY")=""
+10 SET BAR("RTYP")=0
+11 SET BAR("STATUS")=0
+12 SET BARQ("NS")="BAR"
+13 SET BARQ("RC")="COMPUTE^BARDRST"
+14 SET BARQ("RP")="PRT^BQIIPRVG"
+15 SET BARQ("RX")="POUT^BARRUTL"
+16 SET BARY("DT")="V"
+17 SET BARY("DT",1)=BEGDT
+18 SET BARY("DT",2)=ENDT
+19 SET BARY("PRV")=PROV
+20 SET BARY("SORT")="C"
+21 DO COMPUTE^BARDRST
+22 SET FC=1
+23 SET TVIS=0
SET TPD=0
+24 FOR
SET FC=$ORDER(BAR(FC))
IF 'FC
QUIT
Begin DoDot:1
+25 SET CL=""
+26 FOR
SET CL=$ORDER(BAR(FC,CL))
IF CL=""
QUIT
Begin DoDot:2
+27 SET TVIS=TVIS+$PIECE(BAR(FC,CL),U,1)
SET BQTOTV=BQTOTV+TVIS
+28 SET TPD=TPD+$PIECE(BAR(FC,CL),U,4)
SET BQTOTP=BQTOTP+TPD
End DoDot:2
End DoDot:1
+29 KILL BARP,BAR,BARQ,BARY
+30 QUIT
+31 ;
PRT ;
+1 QUIT
+2 ;
STORP ; Store for provider
+1 NEW DA,DIC,MSRN,DLAYGO,X
+2 IF '$DATA(^BQIPROV(PROV,30,0))
SET ^BQIPROV(PROV,30,0)="^90505.43^^"
+3 SET DA(1)=PROV
SET DIC(0)="LMNZ"
SET DLAYGO=90505.43
SET X=ID
SET DIC="^BQIPROV("_DA(1)_",30,"
+4 DO ^DIC
IF Y=-1
KILL DO,DD
DO FILE^DICN
+5 SET MSRN=+Y
+6 IF '$DATA(^BQIPROV(PROV,30,MSRN,1,0))
SET ^BQIPROV(PROV,30,MSRN,1,0)="^90505.431D^^"
+7 SET DA(2)=PROV
SET DA(1)=MSRN
SET DIC(0)="LMNZ"
SET DLAYGO=90505.431
SET X=BQDATE
+8 SET DIC="^BQIPROV("_DA(2)_",30,"_DA(1)_",1,"
+9 DO ^DIC
IF Y=-1
KILL DO,DD
DO FILE^DICN
+10 SET DA=+Y
+11 SET $PIECE(^BQIPROV(PROV,30,MSRN,1,DA,0),U,2,3)=TPD_U_TVIS
+12 KILL TVIS,TPD
+13 QUIT
+14 ;
BQM ;
+1 ;;09^PYR
+2 ;;10^PYR
+3 ;;11^PYR
+4 ;;12^PYR
+5 ;;01^CYR
+6 ;;02^CYR
+7 ;;03^CYR
+8 ;;04^CYR
+9 ;;05^CYR
+10 ;;06^CYR
+11 ;;07^CYR
+12 ;;08^CYR
