Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: DGPTC2

DGPTC2.m

Go to the documentation of this file.
DGPTC2 ;ALN/MJ/PLT - Census Record Processing ;4/14/15 4:14pm
 ;;5.3;Registration;**58,189,643,850,884**;Aug 13, 1993;Build 31
 ;;Per VA Directive 6402, this routine should not be modified.
 ;
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)
 S:$D(^DGPT(PTF,"P",I,1)) ^DGPT(DGCI,"P",I,1)=^DGPT(PTF,"P",I,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)
 S:$D(^DGPT(PTF,"S",I,1)) ^DGPT(DGCI,"S",I,1)=^DGPT(PTF,"S",I,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")=^DGPT(PTF,"M",I,"P")
 S:$D(^DGPT(PTF,"M",I,81)) ^DGPT(DGCI,"M",I,81)=^DGPT(PTF,"M",I,81)
 ;set poa data after reindexthe new census reocrd
 ;S:$D(^DGPT(PTF,"M",I,82)) ^DGPT(DGCI,"M",I,82)=^DGPT(PTF,"M",I,82)
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))
 I Y=0 S Y=+$O(^DGPM("ATS",DFN,DGPMCA,9999999.9999999-DGEND,0)) ;aas 850 fix
 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)
 M ^DGPT(DGCI,"M",M,81)=^DGPT(PTF,"M",M,81)
 ;poa data copied after reindex the new census entry
 ;M ^DGPT(DGCI,"M",M,82)=^DGPT(PTF,"M",M,82) ; move POA fields to Census
 ;;
 ;;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