| 1 | DGPTC2 ;ALN/MJK - Census Record Processing; jAN 27,2005
|
|---|
| 2 | ;;5.3;Registration;**58,189,643**;Aug 13, 1993
|
|---|
| 3 | ;
|
|---|
| 4 | SETP ; -- 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)
|
|---|
| 8 | SETPQ Q
|
|---|
| 9 | ;
|
|---|
| 10 | SETS ; -- 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)
|
|---|
| 15 | SETSQ K DGSFLAG Q
|
|---|
| 16 | ;
|
|---|
| 17 | SET535 ; -- 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)
|
|---|
| 23 | SET535Q K DGSFLAG Q
|
|---|
| 24 | ;
|
|---|
| 25 | SETM ; -- 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")
|
|---|
| 32 | SETMQ K DGSFLAG Q
|
|---|
| 33 | ;
|
|---|
| 34 | BSEC ; -- 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 | ;
|
|---|
| 40 | BS ; -- 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 | ;
|
|---|
| 46 | CONE ;-- 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 | ;
|
|---|
| 51 | ONE ; -- 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
|
|---|
| 66 | GETSUFF ; -- 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
|
|---|
