DGPTCO1.m

DGPTCO1 ;ALB/MJK - Census Status Report ; 5/2/05 2:41pm

 ;;5.3;PIMS;**136,383,432,696,729,1015,1016**;JUN 30, 2012;Build 20

 ;

EN D CHKCUR W ! D DATE

 S DIC("A")="Generate PTF Census Status Report for Census date: ",DIC="^DG(45.86,",DIC(0)="AEMQ" S:Y]"" DIC("B")=Y

 D ^DIC K DIC G ENQ:Y<0

 S DGCN=+Y,DGCDT=+$P(Y,U,2)_".9" K DGCHOICE

 D DIV^DGPTCO2 G ENQ:'$D(DGCHOICE("DIV"))

 D STATUS^DGPTCO2 G ENQ:'$D(DGCHOICE("STATUS"))

 S %ZIS="NQ" D ^%ZIS K %ZIS G ENQ:POP D DOQ G ENQ:POP S DGIOP=ION_";"_IOM_";"_IOSL

 I 'DGQ D START G ENQ

 S ZTRTN="START^DGPTCO1",ZTIO=DGIOP,ZTDESC="Census Status Report"

 F X="DGCHOICE(","DGCDT","DGCN","DGIOP" S ZTSAVE(X)=""

 D ^%ZTLOAD D ^%ZISC

ENQ K DGQ,DHIT,DIOEND,DGC,DGCN,DGCDT,DGIOP,DGCHOICE,DIS

 Q

 ;

START ; -- produce report

 ;Lock global to prevent duplicate entries in Census Workfile

 L +^DG(45.85,"DGPT CENSUS REGEN WORKFILE"):5 I '$T D   Q

 .N DGPTMSG

 .D BLDMSG^DGPTCR

 .I $E(IOST,1,2)'="C-" D SNDMSG^DGPTCR,ENQ Q

 .N DGPTLINE

 .S DGPTLINE=0

 .F  S DGPTLINE=$O(DGPTMSG(DGPTLINE)) Q:'DGPTLINE  W !,?5,DGPTMSG(DGPTLINE,0)

 .Q

 I '$D(^DG(45.85,"ACENSUS",DGCN)) D REGEN^DGPTCR

 S DIC="^DG(45.85,",(BY,FLDS)="[DGPT WORKFILE]",L=0,FR=DGCN_",,@",TO=DGCN_",,"

 I DGCHOICE("STATUS")'="All" S (FR,TO)=DGCN_",,"_DGCHOICE("STATUS")

 S DIS(0)="D DIS^DGPTCO1",DHIT="D DHIT^DGPTCO1",DIOEND="D DIOEND^DGPTCO1"

 S Y=$P(DGCDT,".") X ^DD("DD") S DHD="Census Status Report for "_Y

 S IOP=DGIOP K DGC

 D EN1^DIP,ENQ

 L -^DG(45.85,"DGPT CENSUS REGEN WORKFILE")

END Q

 ;

DIOEND ; -- logic called at end of rpt for totals

 I $E(IOST)="C" S DIR(0)="E" D ^DIR K DIR G DIOENDQ:X="^"

 N D,S,Z S D="",Z="zzzz",$P(DGLN,"-",81)="" D NOW^%DTC S Y=% X ^DD("DD")

 W @IOF,?30,"Census Status Report",?59,Y,!!?26,"Division Summary Statistics",!

 ;

 F I=0:0 S D=$O(DGC(D)) Q:D=""  D DIV S S="" F J=0:0 S S=$O(DGC(D,S)) Q:S=""  S C=DGC(D,S) D PRT I $O(DGC(D,S))=Z D TOT Q

 W !,DGLN,!

 I $E(IOST)="C" S DIR(0)="E" D ^DIR K DIR

DIOENDQ K C,DGLN Q

 ;

DIV ;

 W !,DGLN

 I D="TOT" W !!?5,"OVERALL STATISTICS:" Q

 W:$D(^DG(40.8,+D,0)) !?5,$P(^(0),U),":"

 Q

 ;

TOT ;

 W !?10,$S(D="TOT":"Grand Total: ",1:"Division Total: "),?30,$J(DGC(D,Z),4)

 Q

 ;

PRT ;

 W !?10,S,": ",?30,$J(C,4)

 S:D'="TOT" DGC("TOT",S)=$S($D(DGC("TOT",S)):DGC("TOT",S),1:0)+C,DGC("TOT",Z)=$S($D(DGC("TOT",Z)):DGC("TOT",Z),1:0)+C

 Q

 ;

DIS ; -- $T logic for each entry

 N X S X=^DG(45.85,D0,0)

 I DGCHOICE("DIV")=1 G DISQ

 I $D(DGCHOICE("DIV",$S($D(^DIC(42,+$P(X,U,6),0)):+$P(^(0),U,11),1:0)))

DISQ Q

 ;

DHIT ; -- logic called for each entry printed cum stats; DGC(div,status)

 N D,S,Z S Z="zzzz" D STATUS

 S S=X,D=$S($D(^DIC(42,+$P(^DG(45.85,D0,0),U,6),0)):+$P(^(0),U,11),1:0)

 S DGC(D,S)=$S($D(DGC(D,S)):DGC(D,S),1:0)+1,DGC(D,Z)=$S($D(DGC(D,Z)):DGC(D,Z),1:0)+1

 Q

 ;

FIND ; -- find CENSUS rec#

 ;  input: D0 := ifn of 45.85

 ; output: X  := status ; DGCI := census ifn ; PTF := ptf ifn

 ;

 S DGCI="",X=0,Y=$S($D(^DG(45.85,D0,0)):^(0),1:"")

 G FINDQ:'Y S PTF=+$P(Y,U,12)

 F DGCI=0:0 S DGCI=$O(^DGPT("ACENSUS",PTF,DGCI)) Q:'DGCI  I $D(^DGPT(DGCI,0)),$P(^(0),U,13)=+$P(Y,U,4) S X=+$P(^(0),U,6) Q

FINDQ Q

 ;

STATUS ; -- compute CENSUS status

 D FIND S X=$P($P($P(^DD(45,6,0),U,3),X_":",2),";")

 K DGCI,PTF,Y Q

 ;

CREC ; -- compute CENSUS rec#

 D FIND S X=DGCI

 K DGCI,PTF,Y Q

 ;

DATE ; -- calculate default census date

 S Y=$S($D(^DG(45.86,+$O(^DG(45.86,"AC",1,0)),0)):+^(0),1:"")

 X:Y]"" ^DD("DD")

 Q

DOQ ;-- check if output device is queued. if not ask 

 S DGQ=0

 I $D(IO("Q")) S DGQ=1 G DOQT

 I IO=IO(0) G DOQT

 S DIR(0)="Y",DIR("A")="DO YOU WANT YOUR OUTPUT QUEUED",DIR("B")="YES"

 D ^DIR

 I Y S DGQ=1

DOQT ;

 K Y,DIR

 Q

CHKCUR ; -- checks if new PTF Census Date record is needed

 N DGIEN,DGCLOSE,DGACT,ERR

 S DGIEN=$S($D(^DG(45.86,+$O(^DG(45.86,"AC",1,0)),0)):+^(0),1:"")

 S DGIEN=$O(^DG(45.86,"B",+$G(DGIEN),0))

 S ERR=0

 I 'DGIEN S ERR=1 D ERR Q

 ; look at last census closeout date

 S DGCLOSE=$P($G(^DG(45.86,DGIEN,0)),U,2)

 I 'DGCLOSE S ERR=1 D ERR Q

 I $P($G(^DG(45.86,DGIEN,0)),U)<3070930 D

 . I $E(DGCLOSE,6,7)'=19 S ERR=1

 I $P($G(^DG(45.86,DGIEN,0)),U)>3070930&($P($G(^DG(45.86,DGIEN,0)),U)<=3101231) D

 . I $E(DGCLOSE,6,7)'=14 S ERR=1

 I $P($G(^DG(45.86,DGIEN,0)),U)>3101231 D

 . I $E(DGCLOSE,6,7)'="07" S ERR=1

 S DGACT=$P($G(^DG(45.86,DGIEN,0)),U,4)

 I 'DGACT S ERR=1

 I ERR D ERR Q

 I DT>DGCLOSE D ADDREC

 Q

ADDREC ; -- add new record

 N DA,DIE,DR,DGYR,DGMONTH,DGSTRT,DGENDT,ERR,FDA,IEN696,ERR696

 ; first inactivate last record

 S DA=DGIEN,DIE="^DG(45.86,",DR=".04////0" D ^DIE

 S DGYR=$E(DGCLOSE,1,3)

 ; create new record depending on last closeout date (month)

 S DGMONTH=$E(DGCLOSE,4,5)

 I DGMONTH>"00",DGMONTH<"04" S DGSTRT=DGYR_"0101",DGENDT=DGYR_"0331",DGCLOSE=DGYR_"0407"

 I DGMONTH>"03",DGMONTH<"07" S DGSTRT=DGYR_"0401",DGENDT=DGYR_"0630",DGCLOSE=DGYR_"0707"

 I DGMONTH>"06",DGMONTH<"10" S DGSTRT=DGYR_"0701",DGENDT=DGYR_"0930",DGCLOSE=DGYR_"1007"

 I DGMONTH>"09",DGMONTH<"13" S DGSTRT=DGYR_"1001",DGENDT=DGYR_"1231",DGYR=DGYR+1,DGCLOSE=DGYR_"0107"

 S FDA(696,45.86,"?+1,",.01)=DGENDT

 S FDA(696,45.86,"?+1,",.02)=DGCLOSE

 S FDA(696,45.86,"?+1,",.03)=2970331

 S FDA(696,45.86,"?+1,",.04)=1

 S FDA(696,45.86,"?+1,",.05)=DGSTRT

 D UPDATE^DIE("","FDA(696)","IEN696","ERR696")

 I $D(ERR696) S ERR=1 D ERR

 Q

ERR ;

 D BMES^XPDUTL("Problem with PTF CENSUS DATE File (#45.86).")

 D BMES^XPDUTL("Please notify your Supervisor !!.")

 Q

 ;

DGPTCO1   ;ALB/MJK - Census Status Report ; 5/2/05 2:41pm

 +1       ;;5.3;PIMS;**136,383,432,696,729,1015,1016**;JUN 30, 2012;Build 20

 +2       ;

EN         DO CHKCUR

           WRITE !

           DO DATE

 +1        SET DIC("A")="Generate PTF Census Status Report for Census date: "

           SET DIC="^DG(45.86,"

           SET DIC(0)="AEMQ"

           IF Y]""

               SET DIC("B")=Y

 +2        DO ^DIC

           KILL DIC

           IF Y<0

               GOTO ENQ

 +3        SET DGCN=+Y

           SET DGCDT=+$PIECE(Y,U,2)_".9"

           KILL DGCHOICE

 +4        DO DIV^DGPTCO2

           IF '$DATA(DGCHOICE("DIV"))

               GOTO ENQ

 +5        DO STATUS^DGPTCO2

           IF '$DATA(DGCHOICE("STATUS"))

               GOTO ENQ

 +6        SET %ZIS="NQ"

           DO ^%ZIS

           KILL %ZIS

           IF POP

               GOTO ENQ

           DO DOQ

           IF POP

               GOTO ENQ

           SET DGIOP=ION_";"_IOM_";"_IOSL

 +7        IF 'DGQ

               DO START

               GOTO ENQ

 +8        SET ZTRTN="START^DGPTCO1"

           SET ZTIO=DGIOP

           SET ZTDESC="Census Status Report"

 +9        FOR X="DGCHOICE(","DGCDT","DGCN","DGIOP"

               SET ZTSAVE(X)=""

 +10       DO ^%ZTLOAD

           DO ^%ZISC

ENQ        KILL DGQ,DHIT,DIOEND,DGC,DGCN,DGCDT,DGIOP,DGCHOICE,DIS

 +1        QUIT 

 +2       ;

START     ; -- produce report

 +1       ;Lock global to prevent duplicate entries in Census Workfile

 +2        LOCK +^DG(45.85,"DGPT CENSUS REGEN WORKFILE"):5

           IF '$TEST

               Begin DoDot:1

 +3                NEW DGPTMSG

 +4                DO BLDMSG^DGPTCR

 +5                IF $EXTRACT(IOST,1,2)'="C-"

                       DO SNDMSG^DGPTCR

                       DO ENQ

                       QUIT 

 +6                NEW DGPTLINE

 +7                SET DGPTLINE=0

 +8                FOR 

                       SET DGPTLINE=$ORDER(DGPTMSG(DGPTLINE))

                       IF 'DGPTLINE

                           QUIT 

                       WRITE !,?5,DGPTMSG(DGPTLINE,0)

 +9                QUIT 

               End DoDot:1

               QUIT 

 +10       IF '$DATA(^DG(45.85,"ACENSUS",DGCN))

               DO REGEN^DGPTCR

 +11       SET DIC="^DG(45.85,"

           SET (BY,FLDS)="[DGPT WORKFILE]"

           SET L=0

           SET FR=DGCN_",,@"

           SET TO=DGCN_",,"

 +12       IF DGCHOICE("STATUS")'="All"

               SET (FR,TO)=DGCN_",,"_DGCHOICE("STATUS")

 +13       SET DIS(0)="D DIS^DGPTCO1"

           SET DHIT="D DHIT^DGPTCO1"

           SET DIOEND="D DIOEND^DGPTCO1"

 +14       SET Y=$PIECE(DGCDT,".")

           XECUTE ^DD("DD")

           SET DHD="Census Status Report for "_Y

 +15       SET IOP=DGIOP

           KILL DGC

 +16       DO EN1^DIP

           DO ENQ

 +17       LOCK -^DG(45.85,"DGPT CENSUS REGEN WORKFILE")

END        QUIT 

 +1       ;

DIOEND    ; -- logic called at end of rpt for totals

 +1        IF $EXTRACT(IOST)="C"

               SET DIR(0)="E"

               DO ^DIR

               KILL DIR

               IF X="^"

                   GOTO DIOENDQ

 +2        NEW D,S,Z

           SET D=""

           SET Z="zzzz"

           SET $PIECE(DGLN,"-",81)=""

           DO NOW^%DTC

           SET Y=%

           XECUTE ^DD("DD")

 +3        WRITE @IOF,?30,"Census Status Report",?59,Y,!!?26,"Division Summary Statistics",!

 +4       ;

 +5        FOR I=0:0

               SET D=$ORDER(DGC(D))

               IF D=""

                   QUIT 

               DO DIV

               SET S=""

               FOR J=0:0

                   SET S=$ORDER(DGC(D,S))

                   IF S=""

                       QUIT 

                   SET C=DGC(D,S)

                   DO PRT

                   IF $ORDER(DGC(D,S))=Z

                       DO TOT

                       QUIT 

 +6        WRITE !,DGLN,!

 +7        IF $EXTRACT(IOST)="C"

               SET DIR(0)="E"

               DO ^DIR

               KILL DIR

DIOENDQ    KILL C,DGLN

           QUIT 

 +1       ;

DIV       ;

 +1        WRITE !,DGLN

 +2        IF D="TOT"

               WRITE !!?5,"OVERALL STATISTICS:"

               QUIT 

 +3        IF $DATA(^DG(40.8,+D,0))

               WRITE !?5,$PIECE(^(0),U),":"

 +4        QUIT 

 +5       ;

TOT       ;

 +1        WRITE !?10,$SELECT(D="TOT":"Grand Total: ",1:"Division Total: "),?30,$JUSTIFY(DGC(D,Z),4)

 +2        QUIT 

 +3       ;

PRT       ;

 +1        WRITE !?10,S,": ",?30,$JUSTIFY(C,4)

 +2        IF D'="TOT"

               SET DGC("TOT",S)=$SELECT($DATA(DGC("TOT",S)):DGC("TOT",S),1:0)+C

               SET DGC("TOT",Z)=$SELECT($DATA(DGC("TOT",Z)):DGC("TOT",Z),1:0)+C

 +3        QUIT 

 +4       ;

DIS       ; -- $T logic for each entry

 +1        NEW X

           SET X=^DG(45.85,D0,0)

 +2        IF DGCHOICE("DIV")=1

               GOTO DISQ

 +3        IF $DATA(DGCHOICE("DIV",$SELECT($DATA(^DIC(42,+$PIECE(X,U,6),0)):+$PIECE(^(0),U,11),1:0)))

DISQ       QUIT 

 +1       ;

DHIT      ; -- logic called for each entry printed cum stats; DGC(div,status)

 +1        NEW D,S,Z

           SET Z="zzzz"

           DO STATUS

 +2        SET S=X

           SET D=$SELECT($DATA(^DIC(42,+$PIECE(^DG(45.85,D0,0),U,6),0)):+$PIECE(^(0),U,11),1:0)

 +3        SET DGC(D,S)=$SELECT($DATA(DGC(D,S)):DGC(D,S),1:0)+1

           SET DGC(D,Z)=$SELECT($DATA(DGC(D,Z)):DGC(D,Z),1:0)+1

 +4        QUIT 

 +5       ;

FIND      ; -- find CENSUS rec#

 +1       ;  input: D0 := ifn of 45.85

 +2       ; output: X  := status ; DGCI := census ifn ; PTF := ptf ifn

 +3       ;

 +4        SET DGCI=""

           SET X=0

           SET Y=$SELECT($DATA(^DG(45.85,D0,0)):^(0),1:"")

 +5        IF 'Y

               GOTO FINDQ

           SET PTF=+$PIECE(Y,U,12)

 +6        FOR DGCI=0:0

               SET DGCI=$ORDER(^DGPT("ACENSUS",PTF,DGCI))

               IF 'DGCI

                   QUIT 

               IF $DATA(^DGPT(DGCI,0))

                   IF $PIECE(^(0),U,13)=+$PIECE(Y,U,4)

                       SET X=+$PIECE(^(0),U,6)

                       QUIT 

FINDQ      QUIT 

 +1       ;

STATUS    ; -- compute CENSUS status

 +1        DO FIND

           SET X=$PIECE($PIECE($PIECE(^DD(45,6,0),U,3),X_":",2),";")

 +2        KILL DGCI,PTF,Y

           QUIT 

 +3       ;

CREC      ; -- compute CENSUS rec#

 +1        DO FIND

           SET X=DGCI

 +2        KILL DGCI,PTF,Y

           QUIT 

 +3       ;

DATE      ; -- calculate default census date

 +1        SET Y=$SELECT($DATA(^DG(45.86,+$ORDER(^DG(45.86,"AC",1,0)),0)):+^(0),1:"")

 +2        IF Y]""

               XECUTE ^DD("DD")

 +3        QUIT 

DOQ       ;-- check if output device is queued. if not ask 

 +1        SET DGQ=0

 +2        IF $DATA(IO("Q"))

               SET DGQ=1

               GOTO DOQT

 +3        IF IO=IO(0)

               GOTO DOQT

 +4        SET DIR(0)="Y"

           SET DIR("A")="DO YOU WANT YOUR OUTPUT QUEUED"

           SET DIR("B")="YES"

 +5        DO ^DIR

 +6        IF Y

               SET DGQ=1

DOQT      ;

 +1        KILL Y,DIR

 +2        QUIT 

CHKCUR    ; -- checks if new PTF Census Date record is needed

 +1        NEW DGIEN,DGCLOSE,DGACT,ERR

 +2        SET DGIEN=$SELECT($DATA(^DG(45.86,+$ORDER(^DG(45.86,"AC",1,0)),0)):+^(0),1:"")

 +3        SET DGIEN=$ORDER(^DG(45.86,"B",+$GET(DGIEN),0))

 +4        SET ERR=0

 +5        IF 'DGIEN

               SET ERR=1

               DO ERR

               QUIT 

 +6       ; look at last census closeout date

 +7        SET DGCLOSE=$PIECE($GET(^DG(45.86,DGIEN,0)),U,2)

 +8        IF 'DGCLOSE

               SET ERR=1

               DO ERR

               QUIT 

 +9        IF $PIECE($GET(^DG(45.86,DGIEN,0)),U)<3070930

               Begin DoDot:1

 +10               IF $EXTRACT(DGCLOSE,6,7)'=19

                       SET ERR=1

               End DoDot:1

 +11       IF $PIECE($GET(^DG(45.86,DGIEN,0)),U)>3070930&($PIECE($GET(^DG(45.86,DGIEN,0)),U)<=3101231)

               Begin DoDot:1

 +12               IF $EXTRACT(DGCLOSE,6,7)'=14

                       SET ERR=1

               End DoDot:1

 +13       IF $PIECE($GET(^DG(45.86,DGIEN,0)),U)>3101231

               Begin DoDot:1

 +14               IF $EXTRACT(DGCLOSE,6,7)'="07"

                       SET ERR=1

               End DoDot:1

 +15       SET DGACT=$PIECE($GET(^DG(45.86,DGIEN,0)),U,4)

 +16       IF 'DGACT

               SET ERR=1

 +17       IF ERR

               DO ERR

               QUIT 

 +18       IF DT>DGCLOSE

               DO ADDREC

 +19       QUIT 

ADDREC    ; -- add new record

 +1        NEW DA,DIE,DR,DGYR,DGMONTH,DGSTRT,DGENDT,ERR,FDA,IEN696,ERR696

 +2       ; first inactivate last record

 +3        SET DA=DGIEN

           SET DIE="^DG(45.86,"

           SET DR=".04////0"

           DO ^DIE

 +4        SET DGYR=$EXTRACT(DGCLOSE,1,3)

 +5       ; create new record depending on last closeout date (month)

 +6        SET DGMONTH=$EXTRACT(DGCLOSE,4,5)

 +7        IF DGMONTH>"00"

               IF DGMONTH<"04"

                   SET DGSTRT=DGYR_"0101"

                   SET DGENDT=DGYR_"0331"

                   SET DGCLOSE=DGYR_"0407"

 +8        IF DGMONTH>"03"

               IF DGMONTH<"07"

                   SET DGSTRT=DGYR_"0401"

                   SET DGENDT=DGYR_"0630"

                   SET DGCLOSE=DGYR_"0707"

 +9        IF DGMONTH>"06"

               IF DGMONTH<"10"

                   SET DGSTRT=DGYR_"0701"

                   SET DGENDT=DGYR_"0930"

                   SET DGCLOSE=DGYR_"1007"

 +10       IF DGMONTH>"09"

               IF DGMONTH<"13"

                   SET DGSTRT=DGYR_"1001"

                   SET DGENDT=DGYR_"1231"

                   SET DGYR=DGYR+1

                   SET DGCLOSE=DGYR_"0107"

 +11       SET FDA(696,45.86,"?+1,",.01)=DGENDT

 +12       SET FDA(696,45.86,"?+1,",.02)=DGCLOSE

 +13       SET FDA(696,45.86,"?+1,",.03)=2970331

 +14       SET FDA(696,45.86,"?+1,",.04)=1

 +15       SET FDA(696,45.86,"?+1,",.05)=DGSTRT

 +16       DO UPDATE^DIE("","FDA(696)","IEN696","ERR696")

 +17       IF $DATA(ERR696)

               SET ERR=1

               DO ERR

 +18       QUIT 

ERR       ;

 +1        DO BMES^XPDUTL("Problem with PTF CENSUS DATE File (#45.86).")

 +2        DO BMES^XPDUTL("Please notify your Supervisor !!.")

 +3        QUIT 

 +4       ;