DGPTC ;ALB/MJK - Census Main Options; 15 APR 90 ; 5/11/01 1:15pm
;;5.3;Registration;**383,643,702**;Aug 13, 1993
;
D DT^DICRW S X="DGPTC",DIK="^DOPT("""_X_""","
G A:$D(^DOPT(X,10))
S ^DOPT(X,0)="Census Main Options^1N^"
F I=1:1 S Y=$T(@I) Q:Y="" S ^DOPT(X,I,0)=$P(Y,";",3,99)
D IXALL^DIK
;
A W !! S DIC="^DOPT(""DGPTC"",",DIC(0)="IQEAM"
D ^DIC Q:Y<0 D @+Y G A
;
1 ;;Load/Edit PTF Record
G ^DGPTF
;
2 ;;Release Closed Census Record
S Y=2 D RTY^DGPTUTL,^DGPTFREL
Q
;
3 ;;Open Closed Census Record
S Y=2 D RTY^DGPTUTL,HEL^DGPTFDEL
K DGADM,DGDOM,DGNHCU,MASD,MASDEV,PARA,DG,DGHEM Q
;
4 ;;Transmit Census Records
D CLOSE G Q4:'Y
S Y=2 D RTY^DGPTUTL,^DGPTFTR
Q4 K DGCN,DGCN0 Q
;
5 ;;Re-Open Released/Transmitted Records
S Y=2 D RTY^DGPTUTL,DREL^DGPTFDEL
Q
;
6 ;;Census Outputs
G ^DGPTCO
;
7 ;;Census Date Parameters
D CHKCUR^DGPTCO1
K DGDASH W ! D DATE^DGPTCO1 S:Y]"" DIC("B")=Y
S DIC="^DG(45.86,",DIC(0)="AELMQ" D ^DIC K DIC G Q7:Y<0
S (D0,DGCN)=+Y D PAR
;S DA=DGCN,DIE="^DG(45.86,",DR="[DGPT CENSUS DATE]" D ^DIE K DIE,DR,DQ,DE
;I '$D(Y) S D0=DGCN D PAR W !!
Q7 K DGCN,D0,DA Q
;
8 ;;Regenerate Census WorkFile
D GEN^DGPTCR
Q
;
9 ;;Send 099 Transmission for Census Record
D CLOSE G Q9:'Y
S Y=2 D RTY^DGPTUTL,EN^DGPTF099
Q9 K DGCN,DGCN0 Q
;
10 ;;Close Census Reord
W ! S DIC="^DGPT(",DIC(0)="AEMZQ",DIC("S")="I '$P(^(0),U,6),$P(^(0),U,11)=1"
D ^DIC K DIC G Q10:Y<0
S (DGPTF,PTF)=+Y,DFN=+Y(0) D PM^DGPTUTL,CEN^DGPTC1
I '$D(DGCST) W !!,*7," >>>> Census transactions are not required for this PTF record." G 10
I DGCST W !!,*7," >>>> This PTF record is already closed for census. (Census #",$S($D(DGCI):DGCI,1:""),")" G 10
D UPDT^DGPTUTL:'$P(Y(0),U,4) S DGPTFE=$P(^DGPT(PTF,0),U,4)
S Y=+$S($D(^DG(45.86,+DGCN,0)):+^(0),1:"") D FMT^DGPTUTL
S Y=2 D RTY^DGPTUTL
D CLS^DGPTC1
I 'DGCST W !!," >>>> Not able to close for census. Please use 'Load/Edit' option to edit PTF."
D Q1^DGPTF G 10
Q10 K DG1,DGL,DGADM,DGPTFMT,DFN,PTF,DGPTFE,DGRTY,DGRTY0,DGPTF D KVAR^DGPTC1 Q
;
CLOSE ; -- can we xmit?
D CEN^DGPTUTL S Y=1
I 'DGCN W !!?5,*7,"There is currently no active census being conducted." S Y=0 G CLOSEQ
I DT>$P(DGCN0,U,2) S Y=$P(DGCN0,U,2) X ^DD("DD") W !!?5,*7,"Census Close date has passed (",Y,").",!?5,"No transmissions allowed." S Y=0 G CLOSEQ
CLOSEQ Q
;
PAR ; census date parameter profile
; input: D0 := ifn of ^DG(45.86)
S X="DGPTXCP" X ^%ZOSF("TEST") G PARQ:'$T
K DGDASH,DXS S $P(DGDASH,"-",81)="",IOP="HOME" D ^%ZIS K IOP
W @IOF,*13,$E(DGDASH,1,28)," Quick Parameter Profile ",$E(DGDASH,1,27)
D ^DGPTXCP W !,DGDASH
PARQ K DGDASH,DXS Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPTC 2672 printed Sep 23, 2025@20:27:39 Page 2
DGPTC ;ALB/MJK - Census Main Options; 15 APR 90 ; 5/11/01 1:15pm
+1 ;;5.3;Registration;**383,643,702**;Aug 13, 1993
+2 ;
+3 DO DT^DICRW
SET X="DGPTC"
SET DIK="^DOPT("""_X_""","
+4 if $DATA(^DOPT(X,10))
GOTO A
+5 SET ^DOPT(X,0)="Census Main Options^1N^"
+6 FOR I=1:1
SET Y=$TEXT(@I)
if Y=""
QUIT
SET ^DOPT(X,I,0)=$PIECE(Y,";",3,99)
+7 DO IXALL^DIK
+8 ;
A WRITE !!
SET DIC="^DOPT(""DGPTC"","
SET DIC(0)="IQEAM"
+1 DO ^DIC
if Y<0
QUIT
DO @+Y
GOTO A
+2 ;
1 ;;Load/Edit PTF Record
+1 GOTO ^DGPTF
+2 ;
2 ;;Release Closed Census Record
+1 SET Y=2
DO RTY^DGPTUTL
DO ^DGPTFREL
+2 QUIT
+3 ;
3 ;;Open Closed Census Record
+1 SET Y=2
DO RTY^DGPTUTL
DO HEL^DGPTFDEL
+2 KILL DGADM,DGDOM,DGNHCU,MASD,MASDEV,PARA,DG,DGHEM
QUIT
+3 ;
4 ;;Transmit Census Records
+1 DO CLOSE
if 'Y
GOTO Q4
+2 SET Y=2
DO RTY^DGPTUTL
DO ^DGPTFTR
Q4 KILL DGCN,DGCN0
QUIT
+1 ;
5 ;;Re-Open Released/Transmitted Records
+1 SET Y=2
DO RTY^DGPTUTL
DO DREL^DGPTFDEL
+2 QUIT
+3 ;
6 ;;Census Outputs
+1 GOTO ^DGPTCO
+2 ;
7 ;;Census Date Parameters
+1 DO CHKCUR^DGPTCO1
+2 KILL DGDASH
WRITE !
DO DATE^DGPTCO1
if Y]""
SET DIC("B")=Y
+3 SET DIC="^DG(45.86,"
SET DIC(0)="AELMQ"
DO ^DIC
KILL DIC
if Y<0
GOTO Q7
+4 SET (D0,DGCN)=+Y
DO PAR
+5 ;S DA=DGCN,DIE="^DG(45.86,",DR="[DGPT CENSUS DATE]" D ^DIE K DIE,DR,DQ,DE
+6 ;I '$D(Y) S D0=DGCN D PAR W !!
Q7 KILL DGCN,D0,DA
QUIT
+1 ;
8 ;;Regenerate Census WorkFile
+1 DO GEN^DGPTCR
+2 QUIT
+3 ;
9 ;;Send 099 Transmission for Census Record
+1 DO CLOSE
if 'Y
GOTO Q9
+2 SET Y=2
DO RTY^DGPTUTL
DO EN^DGPTF099
Q9 KILL DGCN,DGCN0
QUIT
+1 ;
10 ;;Close Census Reord
+1 WRITE !
SET DIC="^DGPT("
SET DIC(0)="AEMZQ"
SET DIC("S")="I '$P(^(0),U,6),$P(^(0),U,11)=1"
+2 DO ^DIC
KILL DIC
if Y<0
GOTO Q10
+3 SET (DGPTF,PTF)=+Y
SET DFN=+Y(0)
DO PM^DGPTUTL
DO CEN^DGPTC1
+4 IF '$DATA(DGCST)
WRITE !!,*7," >>>> Census transactions are not required for this PTF record."
GOTO 10
+5 IF DGCST
WRITE !!,*7," >>>> This PTF record is already closed for census. (Census #",$SELECT($DATA(DGCI):DGCI,1:""),")"
GOTO 10
+6 if '$PIECE(Y(0),U,4)
DO UPDT^DGPTUTL
SET DGPTFE=$PIECE(^DGPT(PTF,0),U,4)
+7 SET Y=+$SELECT($DATA(^DG(45.86,+DGCN,0)):+^(0),1:"")
DO FMT^DGPTUTL
+8 SET Y=2
DO RTY^DGPTUTL
+9 DO CLS^DGPTC1
+10 IF 'DGCST
WRITE !!," >>>> Not able to close for census. Please use 'Load/Edit' option to edit PTF."
+11 DO Q1^DGPTF
GOTO 10
Q10 KILL DG1,DGL,DGADM,DGPTFMT,DFN,PTF,DGPTFE,DGRTY,DGRTY0,DGPTF
DO KVAR^DGPTC1
QUIT
+1 ;
CLOSE ; -- can we xmit?
+1 DO CEN^DGPTUTL
SET Y=1
+2 IF 'DGCN
WRITE !!?5,*7,"There is currently no active census being conducted."
SET Y=0
GOTO CLOSEQ
+3 IF DT>$PIECE(DGCN0,U,2)
SET Y=$PIECE(DGCN0,U,2)
XECUTE ^DD("DD")
WRITE !!?5,*7,"Census Close date has passed (",Y,").",!?5,"No transmissions allowed."
SET Y=0
GOTO CLOSEQ
CLOSEQ QUIT
+1 ;
PAR ; census date parameter profile
+1 ; input: D0 := ifn of ^DG(45.86)
+2 SET X="DGPTXCP"
XECUTE ^%ZOSF("TEST")
if '$TEST
GOTO PARQ
+3 KILL DGDASH,DXS
SET $PIECE(DGDASH,"-",81)=""
SET IOP="HOME"
DO ^%ZIS
KILL IOP
+4 WRITE @IOF,*13,$EXTRACT(DGDASH,1,28)," Quick Parameter Profile ",$EXTRACT(DGDASH,1,27)
+5 DO ^DGPTXCP
WRITE !,DGDASH
PARQ KILL DGDASH,DXS
QUIT
