74 lines
2.7 KiB
Mathematica
74 lines
2.7 KiB
Mathematica
|
DGPTC2 ;ALN/MJK - Census Record Processing; jAN 27,2005
|
||
|
;;5.3;Registration;**58,189,643**;Aug 13, 1993
|
||
|
;
|
||
|
SETP ; -- P node processing
|
||
|
;I DGCSUF="9AA"!(DGCSUF="BU") S I=999 G SETPQ
|
||
|
G SETPQ:X<DGBEG!(X>DGEND) S ^DGPT(DGCI,"P",I,0)=X
|
||
|
S:'$D(^DGPT(DGCI,"P",0)) ^(0)="^45.05D^^" S X=^(0),^(0)=$P(X,U,1,2)_"^"_I_"^"_($P(X,U,4)+1)
|
||
|
SETPQ Q
|
||
|
;
|
||
|
SETS ; -- S node processing
|
||
|
D GETSUFF
|
||
|
I $G(DGSFLAG) S I=999 G SETSQ
|
||
|
G SETSQ:X<DGBEG!(X>DGEND) S ^DGPT(DGCI,"S",I,0)=X
|
||
|
S:'$D(^DGPT(DGCI,"S",0)) ^(0)="^45.01D^^" S X=^(0),^(0)=$P(X,U,1,2)_"^"_I_"^"_($P(X,U,4)+1)
|
||
|
SETSQ K DGSFLAG Q
|
||
|
;
|
||
|
SET535 ; -- 535 node processing
|
||
|
D GETSUFF
|
||
|
I '$P(X,U,7),$G(DGSFLAG) G SET535Q
|
||
|
I $P(X,U,7) D CONE G SET535Q
|
||
|
G SET535Q:$P(X,U,10)<DGBEG!($P(X,U,10)>DGEND) S ^DGPT(DGCI,535,I,0)=X
|
||
|
S:'$D(^DGPT(DGCI,535,0)) ^(0)="^45.0535^^" S X=^(0),^(0)=$P(X,U,1,2)_"^"_I_"^"_($P(X,U,4)+1)
|
||
|
SET535Q K DGSFLAG Q
|
||
|
;
|
||
|
SETM ; -- M node processing
|
||
|
D GETSUFF
|
||
|
I I'=1,$G(DGSFLAG) S I=999 G SETMQ
|
||
|
I I=1 D ONE G SETMQ
|
||
|
G SETMQ:($P(X,U,10)<DGBEG)!($P(X,U,10)>DGEND) S ^DGPT(DGCI,"M",I,0)=X
|
||
|
S:'$D(^DGPT(DGCI,"M",0)) ^(0)="^45.02AI^^" S X=^(0),^(0)=$P(X,U,1,2)_"^"_I_"^"_($P(X,U,4)+1)
|
||
|
S:$D(^DGPT(PTF,"M",I,"P")) ^DGPT(DGCI,"M",I,"P")=^("P")
|
||
|
SETMQ K DGSFLAG Q
|
||
|
;
|
||
|
BSEC ; -- set bed sec in 1 mvt ; input X := one node of "M" ; output := same
|
||
|
N Y
|
||
|
S Y=+$O(^DGPM("ATS",DFN,DGPMCA,9999999.9999999-DGEND)),Y=+$O(^(Y,0))
|
||
|
S $P(X,U,2)=$S($D(^DIC(45.7,+Y,0)):$P(^(0),U,2),1:0)
|
||
|
Q
|
||
|
;
|
||
|
BS ; -- determine bed status on census date
|
||
|
S I=+$O(^DGPM("APMV",DFN,DGPMCA,9999999.9999999-Y)),I=+$O(^(I,0))
|
||
|
S I=$S($D(^DGPM(I,0)):$P(^(0),U,18),1:0),Y=1
|
||
|
I I S I=U_I_U,Y=$S("^43^44^13^45^"[I:4,"^1^"[I:2,"^2^3^"[I:3,1:1)
|
||
|
Q
|
||
|
;
|
||
|
CONE ;-- find last 535 before last census date
|
||
|
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
|
||
|
S:'$D(^DGPT(DGCI,535,0)) ^(0)="^45.0535^^" S X=^(0),^(0)=$P(X,U,1,2)_"^"_I_"^"_($P(X,U,4)+1)
|
||
|
Q
|
||
|
;
|
||
|
ONE ; -- find last mvt before census date
|
||
|
S M=$O(^DGPT(PTF,"M","AM",DGEND)),M=$S('M:M,1:$O(^(M,0))),M=$S(M:M,1:1)
|
||
|
I M>1,$D(^DGPT(PTF,"M",M,0)) S X="1^"_$P(^(0),U,2,99)
|
||
|
I M=1,DGFEE=0 D BSEC
|
||
|
S $P(X,U,10)=DGEND,^DGPT(DGCI,"M",1,0)=X
|
||
|
S:'$D(^DGPT(DGCI,"M",0)) ^(0)="^45.02AI^^" S X=^(0),^(0)=$P(X,U,1,2)_"^1^"_($P(X,U,4)+1)
|
||
|
;;Following code added to transmit GAF scores in Census Record
|
||
|
;;Code added by EDS-GRR 6/4/1998
|
||
|
;;
|
||
|
M ^DGPT(DGCI,"M",M,300)=^DGPT(PTF,"M",M,300)
|
||
|
;;
|
||
|
;;End of GAF enhancement
|
||
|
;;
|
||
|
S:$D(^DGPT(PTF,"M",M,"P")) ^DGPT(DGCI,"M",1,"P")=^("P")
|
||
|
Q
|
||
|
GETSUFF ; -- get suffix if from Va Domiciliary or VA Nursing home
|
||
|
F DGSTA=30,40 D
|
||
|
.D NUMACT^DGPTSUF(DGSTA)
|
||
|
.I DGANUM>0 D
|
||
|
..F DGCTR=1:1:DGANUM I DGCSUF=DGSUFNAM(DGCTR) S DGSFLAG=1
|
||
|
.K DGANUM,DGCTR,DGSUFNAM
|
||
|
K DGSTA
|
||
|
Q
|