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

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

initial load of WorldVistAEHR

File size: 2.7 KB
Line 
1DGPTC2 ;ALN/MJK - Census Record Processing; jAN 27,2005
2 ;;5.3;Registration;**58,189,643**;Aug 13, 1993
3 ;
4SETP ; -- P node processing
5 ;I DGCSUF="9AA"!(DGCSUF="BU") S I=999 G SETPQ
6 G SETPQ:X<DGBEG!(X>DGEND) S ^DGPT(DGCI,"P",I,0)=X
7 S:'$D(^DGPT(DGCI,"P",0)) ^(0)="^45.05D^^" S X=^(0),^(0)=$P(X,U,1,2)_"^"_I_"^"_($P(X,U,4)+1)
8SETPQ Q
9 ;
10SETS ; -- S node processing
11 D GETSUFF
12 I $G(DGSFLAG) S I=999 G SETSQ
13 G SETSQ:X<DGBEG!(X>DGEND) S ^DGPT(DGCI,"S",I,0)=X
14 S:'$D(^DGPT(DGCI,"S",0)) ^(0)="^45.01D^^" S X=^(0),^(0)=$P(X,U,1,2)_"^"_I_"^"_($P(X,U,4)+1)
15SETSQ K DGSFLAG Q
16 ;
17SET535 ; -- 535 node processing
18 D GETSUFF
19 I '$P(X,U,7),$G(DGSFLAG) G SET535Q
20 I $P(X,U,7) D CONE G SET535Q
21 G SET535Q:$P(X,U,10)<DGBEG!($P(X,U,10)>DGEND) S ^DGPT(DGCI,535,I,0)=X
22 S:'$D(^DGPT(DGCI,535,0)) ^(0)="^45.0535^^" S X=^(0),^(0)=$P(X,U,1,2)_"^"_I_"^"_($P(X,U,4)+1)
23SET535Q K DGSFLAG Q
24 ;
25SETM ; -- M node processing
26 D GETSUFF
27 I I'=1,$G(DGSFLAG) S I=999 G SETMQ
28 I I=1 D ONE G SETMQ
29 G SETMQ:($P(X,U,10)<DGBEG)!($P(X,U,10)>DGEND) S ^DGPT(DGCI,"M",I,0)=X
30 S:'$D(^DGPT(DGCI,"M",0)) ^(0)="^45.02AI^^" S X=^(0),^(0)=$P(X,U,1,2)_"^"_I_"^"_($P(X,U,4)+1)
31 S:$D(^DGPT(PTF,"M",I,"P")) ^DGPT(DGCI,"M",I,"P")=^("P")
32SETMQ K DGSFLAG Q
33 ;
34BSEC ; -- set bed sec in 1 mvt ; input X := one node of "M" ; output := same
35 N Y
36 S Y=+$O(^DGPM("ATS",DFN,DGPMCA,9999999.9999999-DGEND)),Y=+$O(^(Y,0))
37 S $P(X,U,2)=$S($D(^DIC(45.7,+Y,0)):$P(^(0),U,2),1:0)
38 Q
39 ;
40BS ; -- determine bed status on census date
41 S I=+$O(^DGPM("APMV",DFN,DGPMCA,9999999.9999999-Y)),I=+$O(^(I,0))
42 S I=$S($D(^DGPM(I,0)):$P(^(0),U,18),1:0),Y=1
43 I I S I=U_I_U,Y=$S("^43^44^13^45^"[I:4,"^1^"[I:2,"^2^3^"[I:3,1:1)
44 Q
45 ;
46CONE ;-- find last 535 before last census date
47 S DGX=$O(^DGPT(PTF,535,"AM",DGEND)) S DGX=+$S(DGX:$O(^(DGX,0)),1:$O(^DGPT(PTF,535,"ADC",1,0))) I $D(^DGPT(PTF,535,DGX,0)) S ^DGPT(DGCI,535,DGX,0)=^DGPT(PTF,535,DGX,0),$P(^DGPT(DGCI,535,DGX,0),U,10)=DGEND
48 S:'$D(^DGPT(DGCI,535,0)) ^(0)="^45.0535^^" S X=^(0),^(0)=$P(X,U,1,2)_"^"_I_"^"_($P(X,U,4)+1)
49 Q
50 ;
51ONE ; -- find last mvt before census date
52 S M=$O(^DGPT(PTF,"M","AM",DGEND)),M=$S('M:M,1:$O(^(M,0))),M=$S(M:M,1:1)
53 I M>1,$D(^DGPT(PTF,"M",M,0)) S X="1^"_$P(^(0),U,2,99)
54 I M=1,DGFEE=0 D BSEC
55 S $P(X,U,10)=DGEND,^DGPT(DGCI,"M",1,0)=X
56 S:'$D(^DGPT(DGCI,"M",0)) ^(0)="^45.02AI^^" S X=^(0),^(0)=$P(X,U,1,2)_"^1^"_($P(X,U,4)+1)
57 ;;Following code added to transmit GAF scores in Census Record
58 ;;Code added by EDS-GRR 6/4/1998
59 ;;
60 M ^DGPT(DGCI,"M",M,300)=^DGPT(PTF,"M",M,300)
61 ;;
62 ;;End of GAF enhancement
63 ;;
64 S:$D(^DGPT(PTF,"M",M,"P")) ^DGPT(DGCI,"M",1,"P")=^("P")
65 Q
66GETSUFF ; -- get suffix if from Va Domiciliary or VA Nursing home
67 F DGSTA=30,40 D
68 .D NUMACT^DGPTSUF(DGSTA)
69 .I DGANUM>0 D
70 ..F DGCTR=1:1:DGANUM I DGCSUF=DGSUFNAM(DGCTR) S DGSFLAG=1
71 .K DGANUM,DGCTR,DGSUFNAM
72 K DGSTA
73 Q
Note: See TracBrowser for help on using the repository browser.