DGPTC2 ;ALN/MJ/PLT - Census Record Processing ;4/14/15 4:14pm
;;5.3;Registration;**58,189,643,850,884,1083**;Aug 13, 1993;Build 3
;;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",1,300)=^DGPT(PTF,"M",M,300)
M ^DGPT(DGCI,"M",1,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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPTC2 3540 printed Dec 13, 2024@02:51:49 Page 2
DGPTC2 ;ALN/MJ/PLT - Census Record Processing ;4/14/15 4:14pm
+1 ;;5.3;Registration;**58,189,643,850,884,1083**;Aug 13, 1993;Build 3
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
SETP ; -- P node processing
+1 ;I DGCSUF="9AA"!(DGCSUF="BU") S I=999 G SETPQ
+2 if X<DGBEG!(X>DGEND)
GOTO SETPQ
SET ^DGPT(DGCI,"P",I,0)=X
+3 if '$DATA(^DGPT(DGCI,"P",0))
SET ^(0)="^45.05D^^"
SET X=^(0)
SET ^(0)=$PIECE(X,U,1,2)_"^"_I_"^"_($PIECE(X,U,4)+1)
+4 if $DATA(^DGPT(PTF,"P",I,1))
SET ^DGPT(DGCI,"P",I,1)=^DGPT(PTF,"P",I,1)
SETPQ QUIT
+1 ;
SETS ; -- S node processing
+1 DO GETSUFF
+2 IF $GET(DGSFLAG)
SET I=999
GOTO SETSQ
+3 if X<DGBEG!(X>DGEND)
GOTO SETSQ
SET ^DGPT(DGCI,"S",I,0)=X
+4 if '$DATA(^DGPT(DGCI,"S",0))
SET ^(0)="^45.01D^^"
SET X=^(0)
SET ^(0)=$PIECE(X,U,1,2)_"^"_I_"^"_($PIECE(X,U,4)+1)
+5 if $DATA(^DGPT(PTF,"S",I,1))
SET ^DGPT(DGCI,"S",I,1)=^DGPT(PTF,"S",I,1)
SETSQ KILL DGSFLAG
QUIT
+1 ;
SET535 ; -- 535 node processing
+1 DO GETSUFF
+2 IF '$PIECE(X,U,7)
IF $GET(DGSFLAG)
GOTO SET535Q
+3 IF $PIECE(X,U,7)
DO CONE
GOTO SET535Q
+4 if $PIECE(X,U,10)<DGBEG!($PIECE(X,U,10)>DGEND)
GOTO SET535Q
SET ^DGPT(DGCI,535,I,0)=X
+5 if '$DATA(^DGPT(DGCI,535,0))
SET ^(0)="^45.0535^^"
SET X=^(0)
SET ^(0)=$PIECE(X,U,1,2)_"^"_I_"^"_($PIECE(X,U,4)+1)
SET535Q KILL DGSFLAG
QUIT
+1 ;
SETM ; -- M node processing
+1 DO GETSUFF
+2 IF I'=1
IF $GET(DGSFLAG)
SET I=999
GOTO SETMQ
+3 IF I=1
DO ONE
GOTO SETMQ
+4 if ($PIECE(X,U,10)<DGBEG)!($PIECE(X,U,10)>DGEND)
GOTO SETMQ
SET ^DGPT(DGCI,"M",I,0)=X
+5 if '$DATA(^DGPT(DGCI,"M",0))
SET ^(0)="^45.02AI^^"
SET X=^(0)
SET ^(0)=$PIECE(X,U,1,2)_"^"_I_"^"_($PIECE(X,U,4)+1)
+6 if $DATA(^DGPT(PTF,"M",I,"P"))
SET ^DGPT(DGCI,"M",I,"P")=^DGPT(PTF,"M",I,"P")
+7 if $DATA(^DGPT(PTF,"M",I,81))
SET ^DGPT(DGCI,"M",I,81)=^DGPT(PTF,"M",I,81)
+8 ;set poa data after reindexthe new census reocrd
+9 ;S:$D(^DGPT(PTF,"M",I,82)) ^DGPT(DGCI,"M",I,82)=^DGPT(PTF,"M",I,82)
SETMQ KILL DGSFLAG
QUIT
+1 ;
BSEC ; -- set bed sec in 1 mvt ; input X := one node of "M" ; output := same
+1 NEW Y
+2 SET Y=+$ORDER(^DGPM("ATS",DFN,DGPMCA,9999999.9999999-DGEND))
SET Y=+$ORDER(^(Y,0))
+3 ;aas 850 fix
IF Y=0
SET Y=+$ORDER(^DGPM("ATS",DFN,DGPMCA,9999999.9999999-DGEND,0))
+4 SET $PIECE(X,U,2)=$SELECT($DATA(^DIC(45.7,+Y,0)):$PIECE(^(0),U,2),1:0)
+5 QUIT
+6 ;
BS ; -- determine bed status on census date
+1 SET I=+$ORDER(^DGPM("APMV",DFN,DGPMCA,9999999.9999999-Y))
SET I=+$ORDER(^(I,0))
+2 SET I=$SELECT($DATA(^DGPM(I,0)):$PIECE(^(0),U,18),1:0)
SET Y=1
+3 IF I
SET I=U_I_U
SET Y=$SELECT("^43^44^13^45^"[I:4,"^1^"[I:2,"^2^3^"[I:3,1:1)
+4 QUIT
+5 ;
CONE ;-- find last 535 before last census date
+1 SET DGX=$ORDER(^DGPT(PTF,535,"AM",DGEND))
SET DGX=+$SELECT(DGX:$ORDER(^(DGX,0)),1:$ORDER(^DGPT(PTF,535,"ADC",1,0)))
IF $DATA(^DGPT(PTF,535,DGX,0))
SET ^DGPT(DGCI,535,DGX,0)=^DGPT(PTF,535,DGX,0)
SET $PIECE(^DGPT(DGCI,535,DGX,0),U,10)=DGEND
+2 if '$DATA(^DGPT(DGCI,535,0))
SET ^(0)="^45.0535^^"
SET X=^(0)
SET ^(0)=$PIECE(X,U,1,2)_"^"_I_"^"_($PIECE(X,U,4)+1)
+3 QUIT
+4 ;
ONE ; -- find last mvt before census date
+1 SET M=$ORDER(^DGPT(PTF,"M","AM",DGEND))
SET M=$SELECT('M:M,1:$ORDER(^(M,0)))
SET M=$SELECT(M:M,1:1)
+2 IF M>1
IF $DATA(^DGPT(PTF,"M",M,0))
SET X="1^"_$PIECE(^(0),U,2,99)
+3 IF M=1
IF DGFEE=0
DO BSEC
+4 SET $PIECE(X,U,10)=DGEND
SET ^DGPT(DGCI,"M",1,0)=X
+5 if '$DATA(^DGPT(DGCI,"M",0))
SET ^(0)="^45.02AI^^"
SET X=^(0)
SET ^(0)=$PIECE(X,U,1,2)_"^1^"_($PIECE(X,U,4)+1)
+6 ;;Following code added to transmit GAF scores in Census Record
+7 ;;Code added by EDS-GRR 6/4/1998
+8 ;;
+9 MERGE ^DGPT(DGCI,"M",1,300)=^DGPT(PTF,"M",M,300)
+10 MERGE ^DGPT(DGCI,"M",1,81)=^DGPT(PTF,"M",M,81)
+11 ;poa data copied after reindex the new census entry
+12 ;M ^DGPT(DGCI,"M",M,82)=^DGPT(PTF,"M",M,82) ; move POA fields to Census
+13 ;;
+14 ;;End of GAF enhancement
+15 ;;
+16 if $DATA(^DGPT(PTF,"M",M,"P"))
SET ^DGPT(DGCI,"M",1,"P")=^("P")
+17 QUIT
GETSUFF ; -- get suffix if from Va Domiciliary or VA Nursing home
+1 FOR DGSTA=30,40
Begin DoDot:1
+2 DO NUMACT^DGPTSUF(DGSTA)
+3 IF DGANUM>0
Begin DoDot:2
+4 FOR DGCTR=1:1:DGANUM
IF DGCSUF=DGSUFNAM(DGCTR)
SET DGSFLAG=1
End DoDot:2
+5 KILL DGANUM,DGCTR,DGSUFNAM
End DoDot:1
+6 KILL DGSTA
+7 QUIT
