AGSCANP.m

AGSCANP ; IHS/ASDS/EFG - PRINT IDENTIFIERS ON SCAN ;  

 ;;7.1;PATIENT REGISTRATION;;AUG 25,2005

 ;

 W ?50,$P($G(^DPT(+Y,0)),U,9)    ;SSN

 W ?65,$E($P($G(^(0)),U,3),4,5)  ;DOB

 W "-"

 W $E($P($G(^(0)),U,3),6,7)      ;DOB

 W "-"

 W $E($P($G(^(0)),U,3),1,3)+1700,!  ;DOB

 D DEADY^AGMAN                   ;IS PATIENT DECEASED

 I $D(AG("DEAD")) D

 . W ?5,"(D)"

 . K AG("DEAD")

 ;If 'Add extra IDENTIFIERS to SCAN' in REGISTRATION PARAMETERES FILE

 ;is set to YES

 I $G(AGOPT(10))="Y" D

 . W:$D(^AUPNPAT(+Y,11)) ?10,$P(^(11),U,18)  ;CURRENT COMMUNITY

 . W ?40,"MOTHER'S (MDN): "

 . I $D(^DPT(+Y,.24)) W $P(^(.24),U,3)       ;

 I $D(^AUPNPAT(+Y,41)) D

 . F L=0:0 S L=$O(^AUPNPAT(+Y,41,L)) Q:'L  I $D(^DIC(4,L,0)) W !?21,$J($P(^AUPNPAT(+Y,41,L,0),U,2),6) W:$P(^(0),U,3) "(*)" W ?29,$P(^DIC(4,L,0),U)

 K L

 Q

AGSCANP   ; IHS/ASDS/EFG - PRINT IDENTIFIERS ON SCAN ;  

 +1       ;;7.1;PATIENT REGISTRATION;;AUG 25,2005

 +2       ;

 +3       ;SSN

           WRITE ?50,$PIECE($GET(^DPT(+Y,0)),U,9)

 +4       ;DOB

           WRITE ?65,$EXTRACT($PIECE($GET(^(0)),U,3),4,5)

 +5        WRITE "-"

 +6       ;DOB

           WRITE $EXTRACT($PIECE($GET(^(0)),U,3),6,7)

 +7        WRITE "-"

 +8       ;DOB

           WRITE $EXTRACT($PIECE($GET(^(0)),U,3),1,3)+1700,!

 +9       ;IS PATIENT DECEASED

           DO DEADY^AGMAN

 +10       IF $DATA(AG("DEAD"))

               Begin DoDot:1

 +11               WRITE ?5,"(D)"

 +12               KILL AG("DEAD")

               End DoDot:1

 +13      ;If 'Add extra IDENTIFIERS to SCAN' in REGISTRATION PARAMETERES FILE

 +14      ;is set to YES

 +15       IF $GET(AGOPT(10))="Y"

               Begin DoDot:1

 +16      ;CURRENT COMMUNITY

                   IF $DATA(^AUPNPAT(+Y,11))

                       WRITE ?10,$PIECE(^(11),U,18)

 +17               WRITE ?40,"MOTHER'S (MDN): "

 +18      ;

                   IF $DATA(^DPT(+Y,.24))

                       WRITE $PIECE(^(.24),U,3)

               End DoDot:1

 +19       IF $DATA(^AUPNPAT(+Y,41))

               Begin DoDot:1

 +20               FOR L=0:0

                       SET L=$ORDER(^AUPNPAT(+Y,41,L))

                       IF 'L

                           QUIT 

                       IF $DATA(^DIC(4,L,0))

                           WRITE !?21,$JUSTIFY($PIECE(^AUPNPAT(+Y,41,L,0),U,2),6)

                           IF $PIECE(^(0),U,3)

                               WRITE "(*)"

                           WRITE ?29,$PIECE(^DIC(4,L,0),U)

               End DoDot:1

 +21       KILL L

 +22       QUIT