- 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
