DGPTC2.m

DGPTC2 ;ALN/MJK - Census Record Processing; jAN 27,2005

 ;;5.3;Registration;**58,189,643,1015**;Aug 13, 1993;Build 21

 ;

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

DGPTC2    ;ALN/MJK - Census Record Processing; jAN 27,2005

 +1       ;;5.3;Registration;**58,189,643,1015**;Aug 13, 1993;Build 21

 +2       ;

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)

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)

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")=^("P")

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        SET $PIECE(X,U,2)=$SELECT($DATA(^DIC(45.7,+Y,0)):$PIECE(^(0),U,2),1:0)

 +4        QUIT 

 +5       ;

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",M,300)=^DGPT(PTF,"M",M,300)

 +10      ;;

 +11      ;;End of GAF enhancement

 +12      ;;

 +13       IF $DATA(^DGPT(PTF,"M",M,"P"))

               SET ^DGPT(DGCI,"M",1,"P")=^("P")

 +14       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