DGPTC1 ;ALN/MJK/PLT - Census Record Processing ;4/14/15 4:14pm
;;5.3;Registration;**37,413,643,701,850,905,884**;Aug 13, 1993;Build 31
;;Per VA Directive 6402, this routine should not be modified.
;
CEN ; -- determine if PTF rec is current Census rec
; input: PTF := ptf rec #
; DGPMCA := corres. adm (non-fee)
; DGPMAN := 0th node of corrs adm "
;output: DGCI := census rec #
; DGCST := census rec status
; DGCN := census date entry to 45.86
;
K DGCST,DGCI,DGCN,DGCN0,DGFEE
S DGFEE=0
G CENQ:'$D(^DGPT(PTF,0)) N DFN S DGPTF0=^(0),DFN=+DGPTF0
D CEN^DGPTUTL I DGCN0=""!(DT'>DGCN0) K DGCN G CENQ
S DGT=$P(DGCN0,U)_".9" I '$P(DGPTF0,U,4) D WARD I 'Y K DGCN G CENQ
;if Fee Basis quit if admit > census date or admit < census date if disch
I $P(DGPTF0,U,4)=1,$P(DGPTF0,U,2)>DGT G CENQ
I $P(DGPTF0,U,4)=1,+$P($G(^DGPT(PTF,70)),U),$P(DGPTF0,U,2)<DGT G CENQ
I $P(DGPTF0,U,4)=1 D FEE G CENQ
S DGCST=0,DGCI=""
F S DGCI=$O(^DGPT("ACENSUS",PTF,DGCI)) Q:'DGCI I $D(^DGPT(DGCI,0)),$P(^(0),U,13)=DGCN S DGCST=$P(^(0),U,6) Q:DGCST'=0 D Q
.S DGCI=$$RDGCI(DGCI),DGCST=1
CENQ K DGCN0,DGA1,DGT,X,DGPTF0,DGFEE Q
;
KVAR K DGCN,DGCI,DGCST Q
;
FEE ;
S DGCST=0,DGCI="",DGFEE=1
F S DGCI=$O(^DGPT("ACENSUS",PTF,DGCI)) Q:'DGCI I $D(^DGPT(DGCI,0)),$P(^(0),U,13)=DGCN S DGCST=$P(^(0),U,6) Q:DGCST'=0 D Q
. S DGCI=$$RDGCI(DGCI),DGCST=+$P(^DGPT(DGCI,0),U,6)
Q
ACT ; -- census actions with input of X
Q:'$D(X)
S Y=2 D RTY^DGPTUTL
I X="L" D CLS G ACTQ
I X="P" D OPEN G ACTQ
I X="E" S DGPTFLE=1,DGPTIFN=DGCI D EN^DGPTFREL K DGRTY,DGRTY0 G ^DGPTF
ACTQ K DGRTY,DGRTY0 G EN1^DGPTF4
;
RDGCI(DGCI) ;-- eliminating 'OPEN' status census record and duplicates
S DGDL=DGCI,DGCIR="" D
.F S DGCIR=$O(^DGPT("ACENSUS",PTF,DGCIR),-1) Q:DGCIR<DGDL D
..I $D(^DGPT(DGCIR,0)),$P(^(0),U,13)=DGCN S:DGCI=DGDL DGCI=DGCIR D
...I DGCIR<DGCI S DGPTIFN=DGCIR,DGRTY=2 D KDGP^DGPTFDEL,KDGPT^DGPTFDEL
Q DGCI
;
CLS ;
S DGFEE=0
I $P(^DGPT(DGPTF,0),U,4)'=1 W !,"Updating TRANSFER DRGs..." S DGADM=$P(^DGPT(PTF,0),U,2) D SUDO1^DGPTSUDO
S J=PTF,DGERR=-1,T2=^DG(45.86,DGCN,0)+.9,T1=$P(^(0),U,5)
S DGPTFMTX=DGPTFMT S Y=T2 D FMT^DGPTUTL
W !,"Performing edit checks..."
;-- init for Austin Edits
K ^TMP("AEDIT",$J),^TMP("AERROR",$J) S DGACNT=0
;
D LOG^DGPTFTR1:DGPTFMT=1,LOG^DGPTR1:DGPTFMT=2,LOG^DGPTR1:DGPTFMT=3,COM1^DGPTFTR
K DGLOGIC,T1,T2,DGCCO D LO^DGUTL
D VERCHK^DGPTRI3(DGPTF) I DGERR>0 D HANG^DGPTUTL K DGERR G CLSQ
I DGERR>0 K DGERR D ^DGPTF2 G CLSQ
;-- do austin edits
;
D ^DGPTAE I DGERR>0 K DGERR D ^DGPTF2 G CLSQ
K DGERR,^TMP("AEDIT",$J),DGACNT
I $P(^DGPT(PTF,0),U,4) S DGFEE=1 D FEE1 G CLSQ:'DGCI
I $P(^DGPT(PTF,0),U,4)'=1 D CREATE G CLSQ:'DGCI
S DR="7////"_DUZ_";8///T",DA=DGCI,DIE="^DGPT(" D ^DIE K DIE,DR
S (X,DINUM)=DGCI,DIC(0)="L",DIC="^DGP(45.84,",DIC("DR")="2///NOW;3////"_DUZ
K DD,DO D FILE^DICN K DIC,DINUM,DO
F I=0,.11,.52,.321,.32,57,.3 S:$D(^DPT(DFN,I)) ^DGP(45.84,DGCI,$S(I=0:10,1:I))=^DPT(DFN,I)
W !,"****** CENSUS CLOSED OUT ******" D HANG^DGPTUTL
S DGCST=1
CLSQ S DGPTFMT=DGPTFMTX K DGPTFMTX,DGFEE Q
;
CREATE ; -- create census record
W !,"Creating Census Record..."
S Y=$P(^DGPT(PTF,0),U,2) D CREATE^DGPTFCR G CREATEQ:Y<0 S DGCI=+Y W "#",DGCI
S DGEND=+^DG(45.86,DGCN,0)_".2359",DGBEG=+$P(^(0),U,5)
S ^DGPT(DGCI,0)=$P(^DGPT(PTF,0),U,1,10)_"^2^"_PTF_"^"_DGCN,DGCSUF=$P(^(0),U,5)
;S ^DGPT(DGCI,0)=$P(^DGPT(PTF,0),U,1,5)_"^1^"_$P(^DGPT(PTF,0),U,7,10)_"^2^"_PTF_"^"_DGCN,DGCSUF=$P(^(0),U,5)
S Y=DGEND D BS^DGPTC2 S X="",$P(X,U)=DGEND,$P(X,U,14)=Y
I $D(^DGPT(PTF,70)) S Y=^(70) F I=8,9,10 S $P(X,U,I)=$P(Y,U,I)
S ^DGPT(DGCI,70)=X D ASIH
;move code after reindex
;I $D(^DGPT(PTF,82)) S ^DGPT(DGCI,82)=^DGPT(PTF,82)
I $D(^DGPT(PTF,101)) S ^DGPT(DGCI,101)=^DGPT(PTF,101)
F NODE="M","P","S",535 F I=0:0 S I=$O(^DGPT(PTF,NODE,I)) Q:'I I $D(^DGPT(PTF,NODE,I,0)) S X=^(0) D @("SET"_NODE_"^DGPTC2")
K DA,DIKLM S DA=DGCI,DIK="^DGPT(" D IX1^DIK
;set poa data in census record after reindex
D POA
CREATEQ K X,Y,DGCSUF,DGBEG,DGEND Q
;
FEE1 ; -- create census record for fee record
W !,"Creating Census Record..."
S Y=$P(^DGPT(PTF,0),U,2) D CREATE^DGPTFCR G CREATEQ:Y<0 S DGCI=+Y W "#",DGCI
S DGEND=+^DG(45.86,DGCN,0)_".2359",DGBEG=+$P(^(0),U,5)
S ^DGPT(DGCI,0)=$P(^DGPT(PTF,0),U,1,10)_"^2^"_PTF_"^"_DGCN,DGCSUF=$P(^(0),U,5)
I $D(^DGPT(PTF,70)) S ^DGPT(DGCI,70)=^DGPT(PTF,70)
I $D(^DGPT(PTF,71)) S ^DGPT(DGCI,71)=^DGPT(PTF,71)
S $P(^DGPT(DGCI,70),U)=DGEND
;move code after reindex
;I $D(^DGPT(PTF,82)) S ^DGPT(DGCI,82)=^DGPT(PTF,82)
I $D(^DGPT(PTF,101)) S ^DGPT(DGCI,101)=^DGPT(PTF,101)
F NODE="M","P","S",535 F I=0:0 S I=$O(^DGPT(PTF,NODE,I)) Q:'I I $D(^DGPT(PTF,NODE,I,0)) S X=^(0) D @("SET"_NODE_"^DGPTC2")
K DA,DIKLM S DA=DGCI,DIK="^DGPT(" D IX1^DIK
;set poa data in census record after reindex
D POA
FEE1Q K X,Y,DGCSUF,DGBEG,DGEND Q
;
POA ;set poa data from ptf to its census record
N A,B
I $D(^DGPT(PTF,82)) S ^DGPT(DGCI,82)=$P(^DGPT(PTF,82),U,1,DGFEE>0*999+1)
S A=0 F S A=$O(^DGPT(DGCI,"M",A)) QUIT:'A I $D(^DGPT(PTF,"M",A,82)) S ^DGPT(DGCI,"M",A,82)=^DGPT(PTF,"M",A,82)
QUIT
;
OPEN ; -- re-open census rec by deleting
S DGPTIFN=DGCI D OPEN^DGPTFDEL S (DGCI,DGCST)=0
K DGPTIFN Q
;
WARD ; -- ward @ census d/t for an adm(even if nhcu/dom adm that is ASIH)
; input: DGPMCA := corres adm
; DGPMAN := corres adm 0th node
; output: Y := ward ptr or null
;
N MVT,M
S Y=""
I +DGPMAN>DGT Q
I $D(^DGPM(+$P(DGPMAN,U,17),0)),+^(0)<DGT Q
F %=(9999999.9999999-DGT):0 S %=$O(^DGPM("APMV",+$G(DFN),+$G(DGPMCA),%)) Q:'% D
. F MVT=0:0 S MVT=$O(^DGPM("APMV",$G(DFN),$G(DGPMCA),%,MVT)) Q:'MVT D
.. I $D(^DGPM(MVT,0)) S M=^(0) D
... I "^13^43^44^45^"'[(U_$P(M,U,18)_U),$D(^DIC(42,+$P(M,U,6),0)) S Y=+$P(M,U,6),%=9999999.9999999
... QUIT
.. QUIT
. QUIT
QUIT
;
ASIH ; -- calc asih days
N DGADM,DGREC,DGBDT,DGEDT,DGMVTP
S X1=DGBEG,X2=-1 D C^%DTC S DGBDT=X
S X1=$P(DGEND,"."),X2=1 D C^%DTC S DGEDT=X
S DGADM=$P(^DGPT(DGCI,0),U,2) D ASIH^DGUTL2
S $P(^DGPT(DGCI,70),U,8)=DGREC
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPTC1 6147 printed Sep 23, 2025@20:27:40 Page 2
DGPTC1 ;ALN/MJK/PLT - Census Record Processing ;4/14/15 4:14pm
+1 ;;5.3;Registration;**37,413,643,701,850,905,884**;Aug 13, 1993;Build 31
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
CEN ; -- determine if PTF rec is current Census rec
+1 ; input: PTF := ptf rec #
+2 ; DGPMCA := corres. adm (non-fee)
+3 ; DGPMAN := 0th node of corrs adm "
+4 ;output: DGCI := census rec #
+5 ; DGCST := census rec status
+6 ; DGCN := census date entry to 45.86
+7 ;
+8 KILL DGCST,DGCI,DGCN,DGCN0,DGFEE
+9 SET DGFEE=0
+10 if '$DATA(^DGPT(PTF,0))
GOTO CENQ
NEW DFN
SET DGPTF0=^(0)
SET DFN=+DGPTF0
+11 DO CEN^DGPTUTL
IF DGCN0=""!(DT'>DGCN0)
KILL DGCN
GOTO CENQ
+12 SET DGT=$PIECE(DGCN0,U)_".9"
IF '$PIECE(DGPTF0,U,4)
DO WARD
IF 'Y
KILL DGCN
GOTO CENQ
+13 ;if Fee Basis quit if admit > census date or admit < census date if disch
+14 IF $PIECE(DGPTF0,U,4)=1
IF $PIECE(DGPTF0,U,2)>DGT
GOTO CENQ
+15 IF $PIECE(DGPTF0,U,4)=1
IF +$PIECE($GET(^DGPT(PTF,70)),U)
IF $PIECE(DGPTF0,U,2)<DGT
GOTO CENQ
+16 IF $PIECE(DGPTF0,U,4)=1
DO FEE
GOTO CENQ
+17 SET DGCST=0
SET DGCI=""
+18 FOR
SET DGCI=$ORDER(^DGPT("ACENSUS",PTF,DGCI))
if 'DGCI
QUIT
IF $DATA(^DGPT(DGCI,0))
IF $PIECE(^(0),U,13)=DGCN
SET DGCST=$PIECE(^(0),U,6)
if DGCST'=0
QUIT
Begin DoDot:1
+19 SET DGCI=$$RDGCI(DGCI)
SET DGCST=1
End DoDot:1
QUIT
CENQ KILL DGCN0,DGA1,DGT,X,DGPTF0,DGFEE
QUIT
+1 ;
KVAR KILL DGCN,DGCI,DGCST
QUIT
+1 ;
FEE ;
+1 SET DGCST=0
SET DGCI=""
SET DGFEE=1
+2 FOR
SET DGCI=$ORDER(^DGPT("ACENSUS",PTF,DGCI))
if 'DGCI
QUIT
IF $DATA(^DGPT(DGCI,0))
IF $PIECE(^(0),U,13)=DGCN
SET DGCST=$PIECE(^(0),U,6)
if DGCST'=0
QUIT
Begin DoDot:1
+3 SET DGCI=$$RDGCI(DGCI)
SET DGCST=+$PIECE(^DGPT(DGCI,0),U,6)
End DoDot:1
QUIT
+4 QUIT
ACT ; -- census actions with input of X
+1 if '$DATA(X)
QUIT
+2 SET Y=2
DO RTY^DGPTUTL
+3 IF X="L"
DO CLS
GOTO ACTQ
+4 IF X="P"
DO OPEN
GOTO ACTQ
+5 IF X="E"
SET DGPTFLE=1
SET DGPTIFN=DGCI
DO EN^DGPTFREL
KILL DGRTY,DGRTY0
GOTO ^DGPTF
ACTQ KILL DGRTY,DGRTY0
GOTO EN1^DGPTF4
+1 ;
RDGCI(DGCI) ;-- eliminating 'OPEN' status census record and duplicates
+1 SET DGDL=DGCI
SET DGCIR=""
Begin DoDot:1
+2 FOR
SET DGCIR=$ORDER(^DGPT("ACENSUS",PTF,DGCIR),-1)
if DGCIR<DGDL
QUIT
Begin DoDot:2
+3 IF $DATA(^DGPT(DGCIR,0))
IF $PIECE(^(0),U,13)=DGCN
if DGCI=DGDL
SET DGCI=DGCIR
Begin DoDot:3
+4 IF DGCIR<DGCI
SET DGPTIFN=DGCIR
SET DGRTY=2
DO KDGP^DGPTFDEL
DO KDGPT^DGPTFDEL
End DoDot:3
End DoDot:2
End DoDot:1
+5 QUIT DGCI
+6 ;
CLS ;
+1 SET DGFEE=0
+2 IF $PIECE(^DGPT(DGPTF,0),U,4)'=1
WRITE !,"Updating TRANSFER DRGs..."
SET DGADM=$PIECE(^DGPT(PTF,0),U,2)
DO SUDO1^DGPTSUDO
+3 SET J=PTF
SET DGERR=-1
SET T2=^DG(45.86,DGCN,0)+.9
SET T1=$PIECE(^(0),U,5)
+4 SET DGPTFMTX=DGPTFMT
SET Y=T2
DO FMT^DGPTUTL
+5 WRITE !,"Performing edit checks..."
+6 ;-- init for Austin Edits
+7 KILL ^TMP("AEDIT",$JOB),^TMP("AERROR",$JOB)
SET DGACNT=0
+8 ;
+9 if DGPTFMT=1
DO LOG^DGPTFTR1
if DGPTFMT=2
DO LOG^DGPTR1
if DGPTFMT=3
DO LOG^DGPTR1
DO COM1^DGPTFTR
+10 KILL DGLOGIC,T1,T2,DGCCO
DO LO^DGUTL
+11 DO VERCHK^DGPTRI3(DGPTF)
IF DGERR>0
DO HANG^DGPTUTL
KILL DGERR
GOTO CLSQ
+12 IF DGERR>0
KILL DGERR
DO ^DGPTF2
GOTO CLSQ
+13 ;-- do austin edits
+14 ;
+15 DO ^DGPTAE
IF DGERR>0
KILL DGERR
DO ^DGPTF2
GOTO CLSQ
+16 KILL DGERR,^TMP("AEDIT",$JOB),DGACNT
+17 IF $PIECE(^DGPT(PTF,0),U,4)
SET DGFEE=1
DO FEE1
if 'DGCI
GOTO CLSQ
+18 IF $PIECE(^DGPT(PTF,0),U,4)'=1
DO CREATE
if 'DGCI
GOTO CLSQ
+19 SET DR="7////"_DUZ_";8///T"
SET DA=DGCI
SET DIE="^DGPT("
DO ^DIE
KILL DIE,DR
+20 SET (X,DINUM)=DGCI
SET DIC(0)="L"
SET DIC="^DGP(45.84,"
SET DIC("DR")="2///NOW;3////"_DUZ
+21 KILL DD,DO
DO FILE^DICN
KILL DIC,DINUM,DO
+22 FOR I=0,.11,.52,.321,.32,57,.3
if $DATA(^DPT(DFN,I))
SET ^DGP(45.84,DGCI,$SELECT(I=0:10,1:I))=^DPT(DFN,I)
+23 WRITE !,"****** CENSUS CLOSED OUT ******"
DO HANG^DGPTUTL
+24 SET DGCST=1
CLSQ SET DGPTFMT=DGPTFMTX
KILL DGPTFMTX,DGFEE
QUIT
+1 ;
CREATE ; -- create census record
+1 WRITE !,"Creating Census Record..."
+2 SET Y=$PIECE(^DGPT(PTF,0),U,2)
DO CREATE^DGPTFCR
if Y<0
GOTO CREATEQ
SET DGCI=+Y
WRITE "#",DGCI
+3 SET DGEND=+^DG(45.86,DGCN,0)_".2359"
SET DGBEG=+$PIECE(^(0),U,5)
+4 SET ^DGPT(DGCI,0)=$PIECE(^DGPT(PTF,0),U,1,10)_"^2^"_PTF_"^"_DGCN
SET DGCSUF=$PIECE(^(0),U,5)
+5 ;S ^DGPT(DGCI,0)=$P(^DGPT(PTF,0),U,1,5)_"^1^"_$P(^DGPT(PTF,0),U,7,10)_"^2^"_PTF_"^"_DGCN,DGCSUF=$P(^(0),U,5)
+6 SET Y=DGEND
DO BS^DGPTC2
SET X=""
SET $PIECE(X,U)=DGEND
SET $PIECE(X,U,14)=Y
+7 IF $DATA(^DGPT(PTF,70))
SET Y=^(70)
FOR I=8,9,10
SET $PIECE(X,U,I)=$PIECE(Y,U,I)
+8 SET ^DGPT(DGCI,70)=X
DO ASIH
+9 ;move code after reindex
+10 ;I $D(^DGPT(PTF,82)) S ^DGPT(DGCI,82)=^DGPT(PTF,82)
+11 IF $DATA(^DGPT(PTF,101))
SET ^DGPT(DGCI,101)=^DGPT(PTF,101)
+12 FOR NODE="M","P","S",535
FOR I=0:0
SET I=$ORDER(^DGPT(PTF,NODE,I))
if 'I
QUIT
IF $DATA(^DGPT(PTF,NODE,I,0))
SET X=^(0)
DO @("SET"_NODE_"^DGPTC2")
+13 KILL DA,DIKLM
SET DA=DGCI
SET DIK="^DGPT("
DO IX1^DIK
+14 ;set poa data in census record after reindex
+15 DO POA
CREATEQ KILL X,Y,DGCSUF,DGBEG,DGEND
QUIT
+1 ;
FEE1 ; -- create census record for fee record
+1 WRITE !,"Creating Census Record..."
+2 SET Y=$PIECE(^DGPT(PTF,0),U,2)
DO CREATE^DGPTFCR
if Y<0
GOTO CREATEQ
SET DGCI=+Y
WRITE "#",DGCI
+3 SET DGEND=+^DG(45.86,DGCN,0)_".2359"
SET DGBEG=+$PIECE(^(0),U,5)
+4 SET ^DGPT(DGCI,0)=$PIECE(^DGPT(PTF,0),U,1,10)_"^2^"_PTF_"^"_DGCN
SET DGCSUF=$PIECE(^(0),U,5)
+5 IF $DATA(^DGPT(PTF,70))
SET ^DGPT(DGCI,70)=^DGPT(PTF,70)
+6 IF $DATA(^DGPT(PTF,71))
SET ^DGPT(DGCI,71)=^DGPT(PTF,71)
+7 SET $PIECE(^DGPT(DGCI,70),U)=DGEND
+8 ;move code after reindex
+9 ;I $D(^DGPT(PTF,82)) S ^DGPT(DGCI,82)=^DGPT(PTF,82)
+10 IF $DATA(^DGPT(PTF,101))
SET ^DGPT(DGCI,101)=^DGPT(PTF,101)
+11 FOR NODE="M","P","S",535
FOR I=0:0
SET I=$ORDER(^DGPT(PTF,NODE,I))
if 'I
QUIT
IF $DATA(^DGPT(PTF,NODE,I,0))
SET X=^(0)
DO @("SET"_NODE_"^DGPTC2")
+12 KILL DA,DIKLM
SET DA=DGCI
SET DIK="^DGPT("
DO IX1^DIK
+13 ;set poa data in census record after reindex
+14 DO POA
FEE1Q KILL X,Y,DGCSUF,DGBEG,DGEND
QUIT
+1 ;
POA ;set poa data from ptf to its census record
+1 NEW A,B
+2 IF $DATA(^DGPT(PTF,82))
SET ^DGPT(DGCI,82)=$PIECE(^DGPT(PTF,82),U,1,DGFEE>0*999+1)
+3 SET A=0
FOR
SET A=$ORDER(^DGPT(DGCI,"M",A))
if 'A
QUIT
IF $DATA(^DGPT(PTF,"M",A,82))
SET ^DGPT(DGCI,"M",A,82)=^DGPT(PTF,"M",A,82)
+4 QUIT
+5 ;
OPEN ; -- re-open census rec by deleting
+1 SET DGPTIFN=DGCI
DO OPEN^DGPTFDEL
SET (DGCI,DGCST)=0
+2 KILL DGPTIFN
QUIT
+3 ;
WARD ; -- ward @ census d/t for an adm(even if nhcu/dom adm that is ASIH)
+1 ; input: DGPMCA := corres adm
+2 ; DGPMAN := corres adm 0th node
+3 ; output: Y := ward ptr or null
+4 ;
+5 NEW MVT,M
+6 SET Y=""
+7 IF +DGPMAN>DGT
QUIT
+8 IF $DATA(^DGPM(+$PIECE(DGPMAN,U,17),0))
IF +^(0)<DGT
QUIT
+9 FOR %=(9999999.9999999-DGT):0
SET %=$ORDER(^DGPM("APMV",+$GET(DFN),+$GET(DGPMCA),%))
if '%
QUIT
Begin DoDot:1
+10 FOR MVT=0:0
SET MVT=$ORDER(^DGPM("APMV",$GET(DFN),$GET(DGPMCA),%,MVT))
if 'MVT
QUIT
Begin DoDot:2
+11 IF $DATA(^DGPM(MVT,0))
SET M=^(0)
Begin DoDot:3
+12 IF "^13^43^44^45^"'[(U_$PIECE(M,U,18)_U)
IF $DATA(^DIC(42,+$PIECE(M,U,6),0))
SET Y=+$PIECE(M,U,6)
SET %=9999999.9999999
+13 QUIT
End DoDot:3
+14 QUIT
End DoDot:2
+15 QUIT
End DoDot:1
+16 QUIT
+17 ;
ASIH ; -- calc asih days
+1 NEW DGADM,DGREC,DGBDT,DGEDT,DGMVTP
+2 SET X1=DGBEG
SET X2=-1
DO C^%DTC
SET DGBDT=X
+3 SET X1=$PIECE(DGEND,".")
SET X2=1
DO C^%DTC
SET DGEDT=X
+4 SET DGADM=$PIECE(^DGPT(DGCI,0),U,2)
DO ASIH^DGUTL2
+5 SET $PIECE(^DGPT(DGCI,70),U,8)=DGREC
+6 QUIT
