DGPTCR ;ALB/MJK - Census Worklist Re-gen ; JAN 27, 2005
;;5.3;Registration;**136,383,643**;Aug 13, 1993
;
GEN ; -- ask user regen ques
D CHKCUR^DGPTCO1
W ! D DATE^DGPTCO1
S DIC("A")="Generate CENSUS WORKFILE for Census date: ",DIC="^DG(45.86,",DIC(0)="AEMQ" S:Y]"" DIC("B")=Y
D ^DIC K DIC G GENQ:Y<0 S DGCN=+Y,DGCDT=+$P(Y,U,2)_".9"
;
GEN1 W !!,"Are you sure" S %=2 D YN^DICN
I %<0!(%=2) W " (Ok, work file will remain the same.)" G GENQ
I '% W !?5,"Answer 'YES' if you want the system to re-calculate which",!?5,"admissions require Census records.",!?5,"Otherwise, answer 'NO'." G GEN1
S ZTRTN="REGEN^DGPTCR",ZTIO="",ZTDESC="Regenerating CENSUS WORKFILE"
S ZTSAVE("DGCN")="",ZTSAVE("DGCDT")="" W ! D ^%ZTLOAD
GENQ K DGCN,%,Y Q
;
REGEN ; -- census workfile generation
; -- kill off old values
; input: DGCN := ifn of census date file
; DGCDT := date of census
; DGFIRST := flag(1/0) to send bulletin (option)
;
;Lock global to prevent duplicate entries in Census Workfile
L +^DG(45.85,"DGPT CENSUS REGEN WORKFILE"):5 I '$T N DGPTMSG D BLDMSG,SNDMSG Q
K ^UTILITY("DGPT REGEN",$J) S:'$D(XQM) XQM=0
S:'$D(DGFIRST) DGFIRST='$O(^DG(45.85,"ACENSUS",DGCN,0))
S DGOLD="^UTILITY(""DGPT REGEN"",$J,""OLD"")",DGNEW="^UTILITY(""DGPT REGEN"",$J,""NEW"")"
F DGI=0:0 S DGI=$O(^DG(45.85,"ACENSUS",DGCN,DGI)) Q:'DGI D
. S DIK="^DG(45.85,",DA=DGI
. I $D(^DG(45.85,DA,0)) D
. . S DGPTF=$P(^DG(45.85,DA,0),U,12)
. . S @DGOLD@(+^DG(45.85,DA,0),+$P(^(0),U,3),+DGPTF)="" D ^DIK K DIK,DGPTF
; -- scan and create new values
F DGDT=0:0 S DGDT=$O(^DGPM("ATT1",DGDT)) Q:'DGDT!(DGDT>DGCDT) F DGAD=0:0 S DGAD=$O(^DGPM("ATT1",DGDT,DGAD)) Q:'DGAD D CHK
D FEE
S DIE="^DG(45.86,",DA=DGCN,DR=".06///NOW" D ^DIE
L -^DG(45.85,"DGPT CENSUS REGEN WORKFILE")
D BULL
Q K DGEW,DGOLD,DGI,DGMV,DGAD0,DGAD1,DGDT,DFN,DGFIRST,^UTILITY("DGPT REGEN",$J),DGOLD,DGNEW
Q
;
CHK ; -- determine if good adm then set work entry
G CHKQ:'$D(^DGPM(DGAD,0)) S DGPMCA=DGAD,(DGPMAN,DGAD0)=^(0)
S DFN=+$P(DGAD0,U,3) G CHKQ:'$D(^DPT(DFN,0))
S DGT=DGCDT D WARD^DGPTC1 G CHKQ:'Y S DGCWD=+Y
S DGPTF=+$P(DGAD0,U,16)
S DGAD1=$S($D(^DGPM(+$P(DGAD0,U,17),0)):^(0),1:"")
S:'$D(@DGOLD@(DFN,DGAD,+DGPTF)) @DGNEW@(DFN,DGAD,+DGPTF)="" K @DGOLD@(DFN,DGAD,+DGPTF)
S X=DFN,DIC="^DG(45.85,",DIC(0)="L",DIC("DR")="[DGPT STUFF ENTRY]"
K DD,DO D FILE^DICN K DIC
CHKQ K DFN,DGT,DGPMCA,DGPMAN,DGCWD Q
FEE ; --check for fee entries
F DFN=0:0 S DFN=$O(^DGPT("AFEE",DFN)) Q:'DFN D
. F DGDT=0:0 S DGDT=$O(^DGPT("AFEE",DFN,DGDT)) Q:'DGDT D
..; -- dgds=discharge date
.. S PTFEE=$O(^DGPT("AFEE",DFN,DGDT,0))
.. Q:'$D(^DGPT(PTFEE,0))
.. Q:$P(^DGPT(PTFEE,0),U,11)=2
.. S DGDS="" I $D(^DGPT(PTFEE,70)) S DGDS=$P(^(70),"^")
.. I DGDS="" S DGDS=9999999
.. D FEECHK
Q
FEECHK ; -- determine if good adm then set work entry
G FEECHKQ:'$D(^DGPT(PTFEE,0))
G FEECHKQ:'$D(^DPT(DFN,0))
I DGDT<DGCDT,DGDS>DGCDT D
. S DGAD0=DGDT,$P(DGAD0,U,16)=PTFEE
. S DGAD1=$S((DGDS=9999999):"",1:DGDS)
. S:'$D(@DGOLD@(DFN,0,+PTFEE)) @DGNEW@(DFN,0,+PTFEE)="" K @DGOLD@(DFN,0,+PTFEE)
. S X=DFN,DIC="^DG(45.85,",DIC(0)="L",DIC("DR")="[DGPT STUFF ENTRY]"
. K DD,DO D FILE^DICN K DIC
FEECHKQ K PTFEE,DGDS Q
;
BULL ; -- bull to user re-generating
G BULLQ:DGFIRST K ^UTILITY("DGPT REGEN",$J,"TEXT")
K DGBLK S $P(DGBLK," ",100)="",Y=+^DG(45.86,DGCN,0) X ^DD("DD")
S XMSUB="Census Workfile Update (CENSUS DATE: "_Y_")",XMY(DUZ)="",XMTEXT="^UTILITY(""DGPT REGEN"",$J,""TEXT"",",DGLINE=0
D BLANK
S Y=$P(^DG(45.86,DGCN,0),U,6) X ^DD("DD") S DGL=" Census Work File Regeneration Finished: "_Y D SET,BLANK
I $D(DGPTCV5) K @DGOLD,@DGNEW ;for v5 conversion only
I '$D(@DGOLD),'$D(@DGNEW) D BLANK S DGL=" **** Work File did NOT change as a result of update. ****" D SET G BULL1
S DGL="Changes resulting from regeneration of census work file:" D SET
D OLD:$D(@DGOLD),NEW:$D(@DGNEW)
BULL1 D ^XMD
BULLQ K DGBLK,DGI,DGX,DGL,DGLINE,XMY,XMSUB,XMTEXT Q
;
SET ; -- set line in xmtext array
S DGLINE=DGLINE+1
S ^UTILITY("DGPT REGEN",$J,"TEXT",DGLINE,0)=DGL
Q
;
BLANK S DGL=" " D SET Q
;
OLD ;
D BLANK
S DGL=">>> OLD ADMISSIONS no longer needing a Census Record <<< " D SET,HEAD
F DFN=0:0 S DFN=$O(@DGOLD@(DFN)) Q:'DFN F DGAD=0:0 S DGAD=$O(@DGOLD@(DFN,DGAD)) Q:'DGAD D AD
Q
;
NEW ;
D BLANK,BLANK
S DGL=">>> NEW ADMISSIONS added to workfile needing a Census Record <<< " D SET,HEAD
F DFN=0:0 S DFN=$O(@DGNEW@(DFN)) Q:'DFN F DGAD=0:0 S DGAD=$O(@DGNEW@(DFN,DGAD)) Q:'DGAD D AD
F DFN=0:0 S DFN=$O(@DGNEW@(DFN)) Q:'DFN F PTFEE=0:0 S PTFEE=$O(@DGNEW@(DFN,0,+PTFEE)) Q:'PTFEE D AD1
Q
;
HEAD ;
D BLANK
S DGL="Name Admission Date PTF# Census#" D SET
S DGL="---- -------------- ---- -------" D SET
Q
;
AD G ADQ:'$D(^DGPM(DGAD,0)) S DGX=^(0),DGL=""
S DGL=$E($S($D(^DPT(DFN,0)):$P(^(0),U),1:"")_DGBLK,1,20)_" ("_$E($P(^(0),U,9),6,10)_")"
S Y=+DGX X ^DD("DD") S DGL=DGL_$E(DGBLK,1,5)_$E(Y_DGBLK,1,20)_$E(DGBLK,1,4)_$J($P(DGX,U,16),5)_$E(DGBLK,1,8)
F DGCI=0:0 S DGCI=$O(^DGPT("ACENSUS",+$P(DGX,U,16),DGCI)) Q:'DGCI I $D(^DGPT(DGCI,0)),$P(^(0),U,13)=DGCN S DGL=DGL_$J(DGCI,5) Q
D SET
ADQ K DGCI Q
AD1 G AD1Q:'$D(^DGPT(PTFEE,0)) S DGX=^(0),DGL=""
S DGL=$E($S($D(^DPT(DFN,0)):$P(^(0),U),1:"")_DGBLK,1,20)_" ("_$E($P(^(0),U,9),6,10)_")"
S Y=$P(DGX,U,2) X ^DD("DD") S DGL=DGL_$E(DGBLK,1,5)_$E(Y_DGBLK,1,20)_$E(DGBLK,1,4)_$J(PTFEE,5)_$E(DGBLK,1,8)
F DGCI=0:0 S DGCI=$O(^DGPT("ACENSUS",PTFEE,DGCI)) Q:'DGCI I $D(^DGPT(DGCI,0)),$P(^(0),U,13)=DGCN S DGL=DGL_$J(DGCI,5) Q
D SET
AD1Q Q
;
BLDMSG ;Build message text if regen currently running
S DGPTMSG(1,0)="The Census Status Report or the Regenerate Census Workfile option was"
S DGPTMSG(2,0)="running at the time of your request. If these options are scheduled"
S DGPTMSG(3,0)="simultaneously, duplicate census records may be created in"
S DGPTMSG(4,0)="the Census Workfile."
S DGPTMSG(5,0)=""
S DGPTMSG(6,0)="To prevent this possible duplication, these options may not be"
S DGPTMSG(7,0)="scheduled at the same time. Please try again."
Q
SNDMSG ;Generate mail message to user
N XMSUB,XMDUZ,XMY,XMTEXT
S XMSUB="Could not generate Census Workfile"
S XMDUZ="Census Workfile option"
S XMY(DUZ)=""
S XMTEXT="DGPTMSG("
D ^XMD
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPTCR 6383 printed Apr 09, 2024@21:49:24 Page 2
DGPTCR ;ALB/MJK - Census Worklist Re-gen ; JAN 27, 2005
+1 ;;5.3;Registration;**136,383,643**;Aug 13, 1993
+2 ;
GEN ; -- ask user regen ques
+1 DO CHKCUR^DGPTCO1
+2 WRITE !
DO DATE^DGPTCO1
+3 SET DIC("A")="Generate CENSUS WORKFILE for Census date: "
SET DIC="^DG(45.86,"
SET DIC(0)="AEMQ"
if Y]""
SET DIC("B")=Y
+4 DO ^DIC
KILL DIC
if Y<0
GOTO GENQ
SET DGCN=+Y
SET DGCDT=+$PIECE(Y,U,2)_".9"
+5 ;
GEN1 WRITE !!,"Are you sure"
SET %=2
DO YN^DICN
+1 IF %<0!(%=2)
WRITE " (Ok, work file will remain the same.)"
GOTO GENQ
+2 IF '%
WRITE !?5,"Answer 'YES' if you want the system to re-calculate which",!?5,"admissions require Census records.",!?5,"Otherwise, answer 'NO'."
GOTO GEN1
+3 SET ZTRTN="REGEN^DGPTCR"
SET ZTIO=""
SET ZTDESC="Regenerating CENSUS WORKFILE"
+4 SET ZTSAVE("DGCN")=""
SET ZTSAVE("DGCDT")=""
WRITE !
DO ^%ZTLOAD
GENQ KILL DGCN,%,Y
QUIT
+1 ;
REGEN ; -- census workfile generation
+1 ; -- kill off old values
+2 ; input: DGCN := ifn of census date file
+3 ; DGCDT := date of census
+4 ; DGFIRST := flag(1/0) to send bulletin (option)
+5 ;
+6 ;Lock global to prevent duplicate entries in Census Workfile
+7 LOCK +^DG(45.85,"DGPT CENSUS REGEN WORKFILE"):5
IF '$TEST
NEW DGPTMSG
DO BLDMSG
DO SNDMSG
QUIT
+8 KILL ^UTILITY("DGPT REGEN",$JOB)
if '$DATA(XQM)
SET XQM=0
+9 if '$DATA(DGFIRST)
SET DGFIRST='$ORDER(^DG(45.85,"ACENSUS",DGCN,0))
+10 SET DGOLD="^UTILITY(""DGPT REGEN"",$J,""OLD"")"
SET DGNEW="^UTILITY(""DGPT REGEN"",$J,""NEW"")"
+11 FOR DGI=0:0
SET DGI=$ORDER(^DG(45.85,"ACENSUS",DGCN,DGI))
if 'DGI
QUIT
Begin DoDot:1
+12 SET DIK="^DG(45.85,"
SET DA=DGI
+13 IF $DATA(^DG(45.85,DA,0))
Begin DoDot:2
+14 SET DGPTF=$PIECE(^DG(45.85,DA,0),U,12)
+15 SET @DGOLD@(+^DG(45.85,DA,0),+$PIECE(^(0),U,3),+DGPTF)=""
DO ^DIK
KILL DIK,DGPTF
End DoDot:2
End DoDot:1
+16 ; -- scan and create new values
+17 FOR DGDT=0:0
SET DGDT=$ORDER(^DGPM("ATT1",DGDT))
if 'DGDT!(DGDT>DGCDT)
QUIT
FOR DGAD=0:0
SET DGAD=$ORDER(^DGPM("ATT1",DGDT,DGAD))
if 'DGAD
QUIT
DO CHK
+18 DO FEE
+19 SET DIE="^DG(45.86,"
SET DA=DGCN
SET DR=".06///NOW"
DO ^DIE
+20 LOCK -^DG(45.85,"DGPT CENSUS REGEN WORKFILE")
+21 DO BULL
Q KILL DGEW,DGOLD,DGI,DGMV,DGAD0,DGAD1,DGDT,DFN,DGFIRST,^UTILITY("DGPT REGEN",$JOB),DGOLD,DGNEW
+1 QUIT
+2 ;
CHK ; -- determine if good adm then set work entry
+1 if '$DATA(^DGPM(DGAD,0))
GOTO CHKQ
SET DGPMCA=DGAD
SET (DGPMAN,DGAD0)=^(0)
+2 SET DFN=+$PIECE(DGAD0,U,3)
if '$DATA(^DPT(DFN,0))
GOTO CHKQ
+3 SET DGT=DGCDT
DO WARD^DGPTC1
if 'Y
GOTO CHKQ
SET DGCWD=+Y
+4 SET DGPTF=+$PIECE(DGAD0,U,16)
+5 SET DGAD1=$SELECT($DATA(^DGPM(+$PIECE(DGAD0,U,17),0)):^(0),1:"")
+6 if '$DATA(@DGOLD@(DFN,DGAD,+DGPTF))
SET @DGNEW@(DFN,DGAD,+DGPTF)=""
KILL @DGOLD@(DFN,DGAD,+DGPTF)
+7 SET X=DFN
SET DIC="^DG(45.85,"
SET DIC(0)="L"
SET DIC("DR")="[DGPT STUFF ENTRY]"
+8 KILL DD,DO
DO FILE^DICN
KILL DIC
CHKQ KILL DFN,DGT,DGPMCA,DGPMAN,DGCWD
QUIT
FEE ; --check for fee entries
+1 FOR DFN=0:0
SET DFN=$ORDER(^DGPT("AFEE",DFN))
if 'DFN
QUIT
Begin DoDot:1
+2 FOR DGDT=0:0
SET DGDT=$ORDER(^DGPT("AFEE",DFN,DGDT))
if 'DGDT
QUIT
Begin DoDot:2
+3 ; -- dgds=discharge date
+4 SET PTFEE=$ORDER(^DGPT("AFEE",DFN,DGDT,0))
+5 if '$DATA(^DGPT(PTFEE,0))
QUIT
+6 if $PIECE(^DGPT(PTFEE,0),U,11)=2
QUIT
+7 SET DGDS=""
IF $DATA(^DGPT(PTFEE,70))
SET DGDS=$PIECE(^(70),"^")
+8 IF DGDS=""
SET DGDS=9999999
+9 DO FEECHK
End DoDot:2
End DoDot:1
+10 QUIT
FEECHK ; -- determine if good adm then set work entry
+1 if '$DATA(^DGPT(PTFEE,0))
GOTO FEECHKQ
+2 if '$DATA(^DPT(DFN,0))
GOTO FEECHKQ
+3 IF DGDT<DGCDT
IF DGDS>DGCDT
Begin DoDot:1
+4 SET DGAD0=DGDT
SET $PIECE(DGAD0,U,16)=PTFEE
+5 SET DGAD1=$SELECT((DGDS=9999999):"",1:DGDS)
+6 if '$DATA(@DGOLD@(DFN,0,+PTFEE))
SET @DGNEW@(DFN,0,+PTFEE)=""
KILL @DGOLD@(DFN,0,+PTFEE)
+7 SET X=DFN
SET DIC="^DG(45.85,"
SET DIC(0)="L"
SET DIC("DR")="[DGPT STUFF ENTRY]"
+8 KILL DD,DO
DO FILE^DICN
KILL DIC
End DoDot:1
FEECHKQ KILL PTFEE,DGDS
QUIT
+1 ;
BULL ; -- bull to user re-generating
+1 if DGFIRST
GOTO BULLQ
KILL ^UTILITY("DGPT REGEN",$JOB,"TEXT")
+2 KILL DGBLK
SET $PIECE(DGBLK," ",100)=""
SET Y=+^DG(45.86,DGCN,0)
XECUTE ^DD("DD")
+3 SET XMSUB="Census Workfile Update (CENSUS DATE: "_Y_")"
SET XMY(DUZ)=""
SET XMTEXT="^UTILITY(""DGPT REGEN"",$J,""TEXT"","
SET DGLINE=0
+4 DO BLANK
+5 SET Y=$PIECE(^DG(45.86,DGCN,0),U,6)
XECUTE ^DD("DD")
SET DGL=" Census Work File Regeneration Finished: "_Y
DO SET
DO BLANK
+6 ;for v5 conversion only
IF $DATA(DGPTCV5)
KILL @DGOLD,@DGNEW
+7 IF '$DATA(@DGOLD)
IF '$DATA(@DGNEW)
DO BLANK
SET DGL=" **** Work File did NOT change as a result of update. ****"
DO SET
GOTO BULL1
+8 SET DGL="Changes resulting from regeneration of census work file:"
DO SET
+9 if $DATA(@DGOLD)
DO OLD
if $DATA(@DGNEW)
DO NEW
BULL1 DO ^XMD
BULLQ KILL DGBLK,DGI,DGX,DGL,DGLINE,XMY,XMSUB,XMTEXT
QUIT
+1 ;
SET ; -- set line in xmtext array
+1 SET DGLINE=DGLINE+1
+2 SET ^UTILITY("DGPT REGEN",$JOB,"TEXT",DGLINE,0)=DGL
+3 QUIT
+4 ;
BLANK SET DGL=" "
DO SET
QUIT
+1 ;
OLD ;
+1 DO BLANK
+2 SET DGL=">>> OLD ADMISSIONS no longer needing a Census Record <<< "
DO SET
DO HEAD
+3 FOR DFN=0:0
SET DFN=$ORDER(@DGOLD@(DFN))
if 'DFN
QUIT
FOR DGAD=0:0
SET DGAD=$ORDER(@DGOLD@(DFN,DGAD))
if 'DGAD
QUIT
DO AD
+4 QUIT
+5 ;
NEW ;
+1 DO BLANK
DO BLANK
+2 SET DGL=">>> NEW ADMISSIONS added to workfile needing a Census Record <<< "
DO SET
DO HEAD
+3 FOR DFN=0:0
SET DFN=$ORDER(@DGNEW@(DFN))
if 'DFN
QUIT
FOR DGAD=0:0
SET DGAD=$ORDER(@DGNEW@(DFN,DGAD))
if 'DGAD
QUIT
DO AD
+4 FOR DFN=0:0
SET DFN=$ORDER(@DGNEW@(DFN))
if 'DFN
QUIT
FOR PTFEE=0:0
SET PTFEE=$ORDER(@DGNEW@(DFN,0,+PTFEE))
if 'PTFEE
QUIT
DO AD1
+5 QUIT
+6 ;
HEAD ;
+1 DO BLANK
+2 SET DGL="Name Admission Date PTF# Census#"
DO SET
+3 SET DGL="---- -------------- ---- -------"
DO SET
+4 QUIT
+5 ;
AD if '$DATA(^DGPM(DGAD,0))
GOTO ADQ
SET DGX=^(0)
SET DGL=""
+1 SET DGL=$EXTRACT($SELECT($DATA(^DPT(DFN,0)):$PIECE(^(0),U),1:"")_DGBLK,1,20)_" ("_$EXTRACT($PIECE(^(0),U,9),6,10)_")"
+2 SET Y=+DGX
XECUTE ^DD("DD")
SET DGL=DGL_$EXTRACT(DGBLK,1,5)_$EXTRACT(Y_DGBLK,1,20)_$EXTRACT(DGBLK,1,4)_$JUSTIFY($PIECE(DGX,U,16),5)_$EXTRACT(DGBLK,1,8)
+3 FOR DGCI=0:0
SET DGCI=$ORDER(^DGPT("ACENSUS",+$PIECE(DGX,U,16),DGCI))
if 'DGCI
QUIT
IF $DATA(^DGPT(DGCI,0))
IF $PIECE(^(0),U,13)=DGCN
SET DGL=DGL_$JUSTIFY(DGCI,5)
QUIT
+4 DO SET
ADQ KILL DGCI
QUIT
AD1 if '$DATA(^DGPT(PTFEE,0))
GOTO AD1Q
SET DGX=^(0)
SET DGL=""
+1 SET DGL=$EXTRACT($SELECT($DATA(^DPT(DFN,0)):$PIECE(^(0),U),1:"")_DGBLK,1,20)_" ("_$EXTRACT($PIECE(^(0),U,9),6,10)_")"
+2 SET Y=$PIECE(DGX,U,2)
XECUTE ^DD("DD")
SET DGL=DGL_$EXTRACT(DGBLK,1,5)_$EXTRACT(Y_DGBLK,1,20)_$EXTRACT(DGBLK,1,4)_$JUSTIFY(PTFEE,5)_$EXTRACT(DGBLK,1,8)
+3 FOR DGCI=0:0
SET DGCI=$ORDER(^DGPT("ACENSUS",PTFEE,DGCI))
if 'DGCI
QUIT
IF $DATA(^DGPT(DGCI,0))
IF $PIECE(^(0),U,13)=DGCN
SET DGL=DGL_$JUSTIFY(DGCI,5)
QUIT
+4 DO SET
AD1Q QUIT
+1 ;
BLDMSG ;Build message text if regen currently running
+1 SET DGPTMSG(1,0)="The Census Status Report or the Regenerate Census Workfile option was"
+2 SET DGPTMSG(2,0)="running at the time of your request. If these options are scheduled"
+3 SET DGPTMSG(3,0)="simultaneously, duplicate census records may be created in"
+4 SET DGPTMSG(4,0)="the Census Workfile."
+5 SET DGPTMSG(5,0)=""
+6 SET DGPTMSG(6,0)="To prevent this possible duplication, these options may not be"
+7 SET DGPTMSG(7,0)="scheduled at the same time. Please try again."
+8 QUIT
SNDMSG ;Generate mail message to user
+1 NEW XMSUB,XMDUZ,XMY,XMTEXT
+2 SET XMSUB="Could not generate Census Workfile"
+3 SET XMDUZ="Census Workfile option"
+4 SET XMY(DUZ)=""
+5 SET XMTEXT="DGPTMSG("
+6 DO ^XMD
+7 QUIT
