source: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTC1.m@ 643

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

initial load of FOIAVistA 6/30/08 version
File size: 5.1 KB
Line 
1DGPTC1 ;ALN/MJK - Census Record Processing; JAN 27, 2005
2 ;;5.3;Registration;**37,413,643,701**;Aug 13, 1993
3 ;
4CEN ; -- determine if PTF rec is current Census rec
5 ; input: PTF := ptf rec #
6 ; DGPMCA := corres. adm (non-fee)
7 ; DGPMAN := 0th node of corrs adm "
8 ;output: DGCI := census rec #
9 ; DGCST := census rec status
10 ; DGCN := census date entry to 45.86
11 ;
12 K DGCST,DGCI,DGCN,DGCN0,DGFEE
13 S DGFEE=0
14 G CENQ:'$D(^DGPT(PTF,0)) N DFN S DGPTF0=^(0),DFN=+DGPTF0
15 ;G CENQ:$P(DGPTF0,U,4)
16 D CEN^DGPTUTL I DGCN0=""!(DT'>DGCN0) K DGCN G CENQ
17 ;I $P(DGPTF0,U,4) D FEE G CENQ ;DG*701 reposition line
18 S DGT=$P(DGCN0,U)_".9" I '$P(DGPTF0,U,4) D WARD I 'Y K DGCN G CENQ
19 ;if Fee Basis quit if admit > census date or admit < census date if disch
20 I $P(DGPTF0,U,4)=1,$P(DGPTF0,U,2)>DGT G CENQ
21 I $P(DGPTF0,U,4)=1,+$P($G(^DGPT(PTF,70)),U),$P(DGPTF0,U,2)<DGT G CENQ
22 I $P(DGPTF0,U,4)=1 D FEE G CENQ
23 S DGCST=0,DGCI=""
24 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
25 .S DGCI=$$RDGCI(DGCI),DGCST=1
26CENQ K DGCN0,DGA1,DGT,X,DGPTF0,DGFEE Q
27 ;
28KVAR K DGCN,DGCI,DGCST Q
29 ;
30FEE ;
31 S DGCST=0,DGCI="",DGFEE=1
32 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
33 . S DGCI=$$RDGCI(DGCI),DGCST=+$P(^DGPT(DGCI,0),U,6)
34 Q
35ACT ; -- census actions with input of X
36 Q:'$D(X)
37 S Y=2 D RTY^DGPTUTL
38 I X="L" D CLS G ACTQ
39 I X="P" D OPEN G ACTQ
40 I X="E" S DGPTFLE=1,DGPTIFN=DGCI D EN^DGPTFREL K DGRTY,DGRTY0 G ^DGPTF
41ACTQ K DGRTY,DGRTY0 G EN1^DGPTF4
42 ;
43RDGCI(DGCI) ;-- eliminating 'OPEN' status census record and duplicates
44 S DGDL=DGCI,DGCIR="" D
45 .F S DGCIR=$O(^DGPT("ACENSUS",PTF,DGCIR),-1) Q:DGCIR<DGDL D
46 ..I $D(^DGPT(DGCIR,0)),$P(^(0),U,13)=DGCN S:DGCI=DGDL DGCI=DGCIR D
47 ...I DGCIR<DGCI S DGPTIFN=DGCIR,DGRTY=2 D KDGP^DGPTFDEL,KDGPT^DGPTFDEL
48 Q DGCI
49 ;
50CLS ;
51 S DGFEE=0
52 I $P(^DGPT(DGPTF,0),U,4)'=1 W !,"Updating TRANSFER DRGs..." S DGADM=$P(^DGPT(PTF,0),U,2) D SUDO1^DGPTSUDO
53 S J=PTF,DGERR=-1,T2=^DG(45.86,DGCN,0)+.9,T1=$P(^(0),U,5)
54 S DGPTFMTX=DGPTFMT S Y=T2 D FMT^DGPTUTL
55 W !,"Performing edit checks..."
56 ;-- init for Austin Edits
57 K ^TMP("AEDIT",$J),^TMP("AERROR",$J) S DGACNT=0
58 ;
59 D LOG^DGPTFTR1:DGPTFMT=1,LOG^DGPTR1:DGPTFMT=2,COM1^DGPTFTR
60 K DGLOGIC,T1,T2,DGCCO D LO^DGUTL
61 I DGERR>0 K DGERR D ^DGPTF2 G CLSQ
62 ;-- do austin edits
63 ;
64 D ^DGPTAE I DGERR>0 K DGERR D ^DGPTF2 G CLSQ
65 K DGERR,^TMP("AEDIT",$J),DGACNT
66 I $P(^DGPT(PTF,0),U,4) S DGFEE=1 D FEE1 G CLSQ:'DGCI
67 I $P(^DGPT(PTF,0),U,4)'=1 D CREATE G CLSQ:'DGCI
68 S DR="7////"_DUZ_";8///T",DA=DGCI,DIE="^DGPT(" D ^DIE K DIE,DR
69 S (X,DINUM)=DGCI,DIC(0)="L",DIC="^DGP(45.84,",DIC("DR")="2///NOW;3////"_DUZ
70 K DD,DO D FILE^DICN K DIC,DINUM
71 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)
72 W !,"****** CENSUS CLOSED OUT ******" D HANG^DGPTUTL
73 S DGCST=1
74CLSQ S DGPTFMT=DGPTFMTX K DGPTFMTX,DGFEE Q
75 ;
76CREATE ; -- create census record
77 W !,"Creating Census Record..."
78 S Y=$P(^DGPT(PTF,0),U,2) D CREATE^DGPTFCR G CREATEQ:Y<0 S DGCI=+Y W "#",DGCI
79 S DGEND=+^DG(45.86,DGCN,0)_".2359",DGBEG=+$P(^(0),U,5)
80 S ^DGPT(DGCI,0)=$P(^DGPT(PTF,0),U,1,10)_"^2^"_PTF_"^"_DGCN,DGCSUF=$P(^(0),U,5)
81 ;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)
82 S Y=DGEND D BS^DGPTC2 S X="",$P(X,U)=DGEND,$P(X,U,14)=Y
83 I $D(^DGPT(PTF,70)) S Y=^(70) F I=8,9,10 S $P(X,U,I)=$P(Y,U,I)
84 S ^DGPT(DGCI,70)=X D ASIH
85 I $D(^DGPT(PTF,101)) S ^DGPT(DGCI,101)=^DGPT(PTF,101)
86 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")
87 K DA,DIKLM S DA=DGCI,DIK="^DGPT(" D IX1^DIK
88CREATEQ K X,Y,DGCSUF,DGBEG,DGEND Q
89 ;
90FEE1 ; -- create census record for fee record
91 W !,"Creating Census Record..."
92 S Y=$P(^DGPT(PTF,0),U,2) D CREATE^DGPTFCR G CREATEQ:Y<0 S DGCI=+Y W "#",DGCI
93 S DGEND=+^DG(45.86,DGCN,0)_".2359",DGBEG=+$P(^(0),U,5)
94 S ^DGPT(DGCI,0)=$P(^DGPT(PTF,0),U,1,10)_"^2^"_PTF_"^"_DGCN,DGCSUF=$P(^(0),U,5)
95 I $D(^DGPT(PTF,70)) S ^DGPT(DGCI,70)=^DGPT(PTF,70)
96 S $P(^DGPT(DGCI,70),U)=DGEND
97 I $D(^DGPT(PTF,101)) S ^DGPT(DGCI,101)=^DGPT(PTF,101)
98 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")
99 K DA,DIKLM S DA=DGCI,DIK="^DGPT(" D IX1^DIK
100FEE1Q K X,Y,DGCSUF,DGBEG,DGEND Q
101OPEN ; -- re-open census rec by deleting
102 S DGPTIFN=DGCI D OPEN^DGPTFDEL S (DGCI,DGCST)=0
103 K DGPTIFN Q
104 ;
105WARD ; -- ward @ census d/t for an adm(even if nhcu/dom adm that is ASIH)
106 ; input: DGPMCA := corres adm
107 ; DGPMAN := corres adm 0th node
108 ; output: Y := ward ptr or null
109 ;
110 N MVT,M
111 S Y=""
112 I +DGPMAN>DGT Q
113 I $D(^DGPM(+$P(DGPMAN,U,17),0)),+^(0)<DGT Q
114 F %=(9999999.9999999-DGT):0 S %=$O(^DGPM("APMV",DFN,DGPMCA,%)) Q:'% F MVT=0:0 S MVT=$O(^DGPM("APMV",DFN,DGPMCA,%,MVT)) Q:'MVT I $D(^DGPM(MVT,0)) S M=^(0) 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) G WARDQ
115WARDQ Q
116 ;
117ASIH ; -- calc asih days
118 N DGADM,DGREC,DGBDT,DGEDT,DGMVTP
119 S X1=DGBEG,X2=-1 D C^%DTC S DGBDT=X
120 S X1=$P(DGEND,"."),X2=1 D C^%DTC S DGEDT=X
121 S DGADM=$P(^DGPT(DGCI,0),U,2) D ASIH^DGUTL2
122 S $P(^DGPT(DGCI,70),U,8)=DGREC
123 Q
Note: See TracBrowser for help on using the repository browser.