DGPTCO1 ;ALB/MJK - Census Status Report ; 5/2/05 2:41pm
;;5.3;Registration;**136,383,432,696,729,839**;Aug 13, 1993;Build 3
;
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
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPTCO1 5468 printed Sep 23, 2025@20:27:43 Page 2
DGPTCO1 ;ALB/MJK - Census Status Report ; 5/2/05 2:41pm
+1 ;;5.3;Registration;**136,383,432,696,729,839**;Aug 13, 1993;Build 3
+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 ;
