source: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTCR.m@ 1141

Last change on this file since 1141 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 6.1 KB
RevLine 
[613]1DGPTCR ;ALB/MJK - Census Worklist Re-gen ; JAN 27, 2005
2 ;;5.3;Registration;**136,383,643**;Aug 13, 1993
3 ;
4GEN ; -- ask user regen ques
5 D CHKCUR^DGPTCO1
6 W ! D DATE^DGPTCO1
7 S DIC("A")="Generate CENSUS WORKFILE for Census date: ",DIC="^DG(45.86,",DIC(0)="AEMQ" S:Y]"" DIC("B")=Y
8 D ^DIC K DIC G GENQ:Y<0 S DGCN=+Y,DGCDT=+$P(Y,U,2)_".9"
9 ;
10GEN1 W !!,"Are you sure" S %=2 D YN^DICN
11 I %<0!(%=2) W " (Ok, work file will remain the same.)" G GENQ
12 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
13 S ZTRTN="REGEN^DGPTCR",ZTIO="",ZTDESC="Regenerating CENSUS WORKFILE"
14 S ZTSAVE("DGCN")="",ZTSAVE("DGCDT")="" W ! D ^%ZTLOAD
15GENQ K DGCN,%,Y Q
16 ;
17REGEN ; -- census workfile generation
18 ; -- kill off old values
19 ; input: DGCN := ifn of census date file
20 ; DGCDT := date of census
21 ; DGFIRST := flag(1/0) to send bulletin (option)
22 ;
23 ;Lock global to prevent duplicate entries in Census Workfile
24 L +^DG(45.85,"DGPT CENSUS REGEN WORKFILE"):5 I '$T N DGPTMSG D BLDMSG,SNDMSG Q
25 K ^UTILITY("DGPT REGEN",$J) S:'$D(XQM) XQM=0
26 S:'$D(DGFIRST) DGFIRST='$O(^DG(45.85,"ACENSUS",DGCN,0))
27 S DGOLD="^UTILITY(""DGPT REGEN"",$J,""OLD"")",DGNEW="^UTILITY(""DGPT REGEN"",$J,""NEW"")"
28 F DGI=0:0 S DGI=$O(^DG(45.85,"ACENSUS",DGCN,DGI)) Q:'DGI D
29 . S DIK="^DG(45.85,",DA=DGI
30 . I $D(^DG(45.85,DA,0)) D
31 . . S DGPTF=$P(^DG(45.85,DA,0),U,12)
32 . . S @DGOLD@(+^DG(45.85,DA,0),+$P(^(0),U,3),+DGPTF)="" D ^DIK K DIK,DGPTF
33 ; -- scan and create new values
34 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
35 D FEE
36 S DIE="^DG(45.86,",DA=DGCN,DR=".06///NOW" D ^DIE
37 L -^DG(45.85,"DGPT CENSUS REGEN WORKFILE")
38 D BULL
39Q K DGEW,DGOLD,DGI,DGMV,DGAD0,DGAD1,DGDT,DFN,DGFIRST,^UTILITY("DGPT REGEN",$J),DGOLD,DGNEW
40 Q
41 ;
42CHK ; -- determine if good adm then set work entry
43 G CHKQ:'$D(^DGPM(DGAD,0)) S DGPMCA=DGAD,(DGPMAN,DGAD0)=^(0)
44 S DFN=+$P(DGAD0,U,3) G CHKQ:'$D(^DPT(DFN,0))
45 S DGT=DGCDT D WARD^DGPTC1 G CHKQ:'Y S DGCWD=+Y
46 S DGPTF=+$P(DGAD0,U,16)
47 S DGAD1=$S($D(^DGPM(+$P(DGAD0,U,17),0)):^(0),1:"")
48 S:'$D(@DGOLD@(DFN,DGAD,+DGPTF)) @DGNEW@(DFN,DGAD,+DGPTF)="" K @DGOLD@(DFN,DGAD,+DGPTF)
49 S X=DFN,DIC="^DG(45.85,",DIC(0)="L",DIC("DR")="[DGPT STUFF ENTRY]"
50 K DD,DO D FILE^DICN K DIC
51CHKQ K DFN,DGT,DGPMCA,DGPMAN,DGCWD Q
52FEE ; --check for fee entries
53 F DFN=0:0 S DFN=$O(^DGPT("AFEE",DFN)) Q:'DFN D
54 . F DGDT=0:0 S DGDT=$O(^DGPT("AFEE",DFN,DGDT)) Q:'DGDT D
55 ..; -- dgds=discharge date
56 .. S PTFEE=$O(^DGPT("AFEE",DFN,DGDT,0))
57 .. Q:'$D(^DGPT(PTFEE,0))
58 .. Q:$P(^DGPT(PTFEE,0),U,11)=2
59 .. S DGDS="" I $D(^DGPT(PTFEE,70)) S DGDS=$P(^(70),"^")
60 .. I DGDS="" S DGDS=9999999
61 .. D FEECHK
62 Q
63FEECHK ; -- determine if good adm then set work entry
64 G FEECHKQ:'$D(^DGPT(PTFEE,0))
65 G FEECHKQ:'$D(^DPT(DFN,0))
66 I DGDT<DGCDT,DGDS>DGCDT D
67 . S DGAD0=DGDT,$P(DGAD0,U,16)=PTFEE
68 . S DGAD1=$S((DGDS=9999999):"",1:DGDS)
69 . S:'$D(@DGOLD@(DFN,0,+PTFEE)) @DGNEW@(DFN,0,+PTFEE)="" K @DGOLD@(DFN,0,+PTFEE)
70 . S X=DFN,DIC="^DG(45.85,",DIC(0)="L",DIC("DR")="[DGPT STUFF ENTRY]"
71 . K DD,DO D FILE^DICN K DIC
72FEECHKQ K PTFEE,DGDS Q
73 ;
74BULL ; -- bull to user re-generating
75 G BULLQ:DGFIRST K ^UTILITY("DGPT REGEN",$J,"TEXT")
76 K DGBLK S $P(DGBLK," ",100)="",Y=+^DG(45.86,DGCN,0) X ^DD("DD")
77 S XMSUB="Census Workfile Update (CENSUS DATE: "_Y_")",XMY(DUZ)="",XMTEXT="^UTILITY(""DGPT REGEN"",$J,""TEXT"",",DGLINE=0
78 D BLANK
79 S Y=$P(^DG(45.86,DGCN,0),U,6) X ^DD("DD") S DGL=" Census Work File Regeneration Finished: "_Y D SET,BLANK
80 I $D(DGPTCV5) K @DGOLD,@DGNEW ;for v5 conversion only
81 I '$D(@DGOLD),'$D(@DGNEW) D BLANK S DGL=" **** Work File did NOT change as a result of update. ****" D SET G BULL1
82 S DGL="Changes resulting from regeneration of census work file:" D SET
83 D OLD:$D(@DGOLD),NEW:$D(@DGNEW)
84BULL1 D ^XMD
85BULLQ K DGBLK,DGI,DGX,DGL,DGLINE,XMY,XMSUB,XMTEXT Q
86 ;
87SET ; -- set line in xmtext array
88 S DGLINE=DGLINE+1
89 S ^UTILITY("DGPT REGEN",$J,"TEXT",DGLINE,0)=DGL
90 Q
91 ;
92BLANK S DGL=" " D SET Q
93 ;
94OLD ;
95 D BLANK
96 S DGL=">>> OLD ADMISSIONS no longer needing a Census Record <<< " D SET,HEAD
97 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
98 Q
99 ;
100NEW ;
101 D BLANK,BLANK
102 S DGL=">>> NEW ADMISSIONS added to workfile needing a Census Record <<< " D SET,HEAD
103 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
104 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
105 Q
106 ;
107HEAD ;
108 D BLANK
109 S DGL="Name Admission Date PTF# Census#" D SET
110 S DGL="---- -------------- ---- -------" D SET
111 Q
112 ;
113AD G ADQ:'$D(^DGPM(DGAD,0)) S DGX=^(0),DGL=""
114 S DGL=$E($S($D(^DPT(DFN,0)):$P(^(0),U),1:"")_DGBLK,1,20)_" ("_$E($P(^(0),U,9),6,10)_")"
115 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)
116 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
117 D SET
118ADQ K DGCI Q
119AD1 G AD1Q:'$D(^DGPT(PTFEE,0)) S DGX=^(0),DGL=""
120 S DGL=$E($S($D(^DPT(DFN,0)):$P(^(0),U),1:"")_DGBLK,1,20)_" ("_$E($P(^(0),U,9),6,10)_")"
121 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)
122 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
123 D SET
124AD1Q Q
125 ;
126BLDMSG ;Build message text if regen currently running
127 S DGPTMSG(1,0)="The Census Status Report or the Regenerate Census Workfile option was"
128 S DGPTMSG(2,0)="running at the time of your request. If these options are scheduled"
129 S DGPTMSG(3,0)="simultaneously, duplicate census records may be created in"
130 S DGPTMSG(4,0)="the Census Workfile."
131 S DGPTMSG(5,0)=""
132 S DGPTMSG(6,0)="To prevent this possible duplication, these options may not be"
133 S DGPTMSG(7,0)="scheduled at the same time. Please try again."
134 Q
135SNDMSG ;Generate mail message to user
136 N XMSUB,XMDUZ,XMY,XMTEXT
137 S XMSUB="Could not generate Census Workfile"
138 S XMDUZ="Census Workfile option"
139 S XMY(DUZ)=""
140 S XMTEXT="DGPTMSG("
141 D ^XMD
142 Q
Note: See TracBrowser for help on using the repository browser.