DPTDZCH.m

DPTDZCH ; IHS/TUCSON/JCM - DISPLAYS CHART NUMBERS FROM PATIENT FILE ; [ 09/12/2001  5:45 AM ]

 ;;1.0;PATIENT MERGE;;FEB 02, 1994

 ;IHS/ANMC/LJF 9/10/2001 added code to display other names

 ;             9/11/2001 fixed code under CHARTS2 to quit if no more

 ;

START ;

 D NAMES  ;IHS/ANMC/LJF 9/10/2001

 D CHARTS

 D EOJ

 Q

 ;

CHARTS ; Displays chart numbers and facilities for patients

 W !!,"*** HEALTH RECORD NO."

 S Y=XDRMCD,Y(2)=XDRMCD2

 S DPTDLKF=0,DPTDLKFF=0,DPTDLKI=0

 I $D(^AUPNPAT(Y,41,0)) F DPTDLKI=0:1 S DPTDLKF=$O(^AUPNPAT(Y,41,DPTDLKF)) Q:'DPTDLKF  W:DPTDLKI ! W ?23," ",$J($P(^AUTTLOC(DPTDLKF,0),U,7),4)," ",$P(^AUPNPAT(Y,41,DPTDLKF,0),U,2) I $D(^AUPNPAT(Y(2),41,0)) D CHART2

 I $D(^AUPNPAT(Y(2),41,0)),$P(^AUPNPAT(Y(2),41,0),U,4)>DPTDLKI F DPTDLKII=1:1 Q:'$O(^AUPNPAT(Y(2),41,DPTDLKFF))  W ! D CHART2

 Q

CHART2 ;prints second patient's chart numbers

 I '$D(DPTDLKII),$P(^AUPNPAT(Y(2),41,0),U,4)<(DPTDLKI+1) G CHART2X

 S DPTDLKFF=$O(^AUPNPAT(Y(2),41,DPTDLKFF))

 Q:'DPTDLKFF  Q:'$D(^AUTTLOC(DPTDLKFF,0))  ;IHS/ANMC/LJF 9/12/2001

 W ?49 W " ",$J($P(^AUTTLOC(DPTDLKFF,0),U,7),4)," ",$P(^AUPNPAT(Y(2),41,DPTDLKFF,0),U,2)

 ;

CHART2X ;

 Q

 ;

 ;IHS/ANMC/LJF 9/10/2001 added NAMES and NAMES2 subrtns

NAMES ; Displays other names for patients

 W !!,"*** ALIAS DETAILS:"

 S Y=XDRMCD,Y(2)=XDRMCD2

 S DPTDLKF=0,DPTDLKFF=0,DPTDLKI=0

 I $D(^DPT(Y,.01,0)) F DPTDLKI=0:1 S DPTDLKF=$O(^DPT(Y,.01,DPTDLKF)) Q:'DPTDLKF  W:DPTDLKI ! W ?23," ",$P(^DPT(Y,.01,DPTDLKF,0),U) I $D(^DPT(Y(2),.01,0)) D NAMES2

 I $D(^DPT(Y(2),.01,0)),$P(^DPT(Y(2),.01,0),U,4)>DPTDLKI F DPTDLKII=1:1 Q:'$O(^DPT(Y(2),.01,DPTDLKFF))  W ! D NAMES2

 Q

NAMES2 ;prints second patient's other names

 I '$D(DPTDLKII),$P(^DPT(Y(2),.01,0),U,4)<(DPTDLKI+1) G NAMES2X

 S DPTDLKFF=$O(^DPT(Y(2),.01,DPTDLKFF)) Q:'DPTDLKFF

 W ?49 W " ",$P(^DPT(Y(2),.01,DPTDLKFF,0),U)

 ;

NAMES2X ;

 Q

 ;

EOJ ;

 K DPTD,Y,DPTDLKF,DPTDLKFF,DPTDLKI,DPTDLKII

 Q

DPTDZCH   ; IHS/TUCSON/JCM - DISPLAYS CHART NUMBERS FROM PATIENT FILE ; [ 09/12/2001  5:45 AM ]

 +1       ;;1.0;PATIENT MERGE;;FEB 02, 1994

 +2       ;IHS/ANMC/LJF 9/10/2001 added code to display other names

 +3       ;             9/11/2001 fixed code under CHARTS2 to quit if no more

 +4       ;

START     ;

 +1       ;IHS/ANMC/LJF 9/10/2001

           DO NAMES

 +2        DO CHARTS

 +3        DO EOJ

 +4        QUIT 

 +5       ;

CHARTS    ; Displays chart numbers and facilities for patients

 +1        WRITE !!,"*** HEALTH RECORD NO."

 +2        SET Y=XDRMCD

           SET Y(2)=XDRMCD2

 +3        SET DPTDLKF=0

           SET DPTDLKFF=0

           SET DPTDLKI=0

 +4        IF $DATA(^AUPNPAT(Y,41,0))

               FOR DPTDLKI=0:1

                   SET DPTDLKF=$ORDER(^AUPNPAT(Y,41,DPTDLKF))

                   IF 'DPTDLKF

                       QUIT 

                   IF DPTDLKI

                       WRITE !

                   WRITE ?23," ",$JUSTIFY($PIECE(^AUTTLOC(DPTDLKF,0),U,7),4)," ",$PIECE(^AUPNPAT(Y,41,DPTDLKF,0),U,2)

                   IF $DATA(^AUPNPAT(Y(2),41,0))

                       DO CHART2

 +5        IF $DATA(^AUPNPAT(Y(2),41,0))

               IF $PIECE(^AUPNPAT(Y(2),41,0),U,4)>DPTDLKI

                   FOR DPTDLKII=1:1

                       IF '$ORDER(^AUPNPAT(Y(2),41,DPTDLKFF))

                           QUIT 

                       WRITE !

                       DO CHART2

 +6        QUIT 

CHART2    ;prints second patient's chart numbers

 +1        IF '$DATA(DPTDLKII)

               IF $PIECE(^AUPNPAT(Y(2),41,0),U,4)<(DPTDLKI+1)

                   GOTO CHART2X

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

 +3       ;IHS/ANMC/LJF 9/12/2001

           IF 'DPTDLKFF

               QUIT 

           IF '$DATA(^AUTTLOC(DPTDLKFF,0))

               QUIT 

 +4        WRITE ?49

           WRITE " ",$JUSTIFY($PIECE(^AUTTLOC(DPTDLKFF,0),U,7),4)," ",$PIECE(^AUPNPAT(Y(2),41,DPTDLKFF,0),U,2)

 +5       ;

CHART2X   ;

 +1        QUIT 

 +2       ;

 +3       ;IHS/ANMC/LJF 9/10/2001 added NAMES and NAMES2 subrtns

NAMES     ; Displays other names for patients

 +1        WRITE !!,"*** ALIAS DETAILS:"

 +2        SET Y=XDRMCD

           SET Y(2)=XDRMCD2

 +3        SET DPTDLKF=0

           SET DPTDLKFF=0

           SET DPTDLKI=0

 +4        IF $DATA(^DPT(Y,.01,0))

               FOR DPTDLKI=0:1

                   SET DPTDLKF=$ORDER(^DPT(Y,.01,DPTDLKF))

                   IF 'DPTDLKF

                       QUIT 

                   IF DPTDLKI

                       WRITE !

                   WRITE ?23," ",$PIECE(^DPT(Y,.01,DPTDLKF,0),U)

                   IF $DATA(^DPT(Y(2),.01,0))

                       DO NAMES2

 +5        IF $DATA(^DPT(Y(2),.01,0))

               IF $PIECE(^DPT(Y(2),.01,0),U,4)>DPTDLKI

                   FOR DPTDLKII=1:1

                       IF '$ORDER(^DPT(Y(2),.01,DPTDLKFF))

                           QUIT 

                       WRITE !

                       DO NAMES2

 +6        QUIT 

NAMES2    ;prints second patient's other names

 +1        IF '$DATA(DPTDLKII)

               IF $PIECE(^DPT(Y(2),.01,0),U,4)<(DPTDLKI+1)

                   GOTO NAMES2X

 +2        SET DPTDLKFF=$ORDER(^DPT(Y(2),.01,DPTDLKFF))

           IF 'DPTDLKFF

               QUIT 

 +3        WRITE ?49

           WRITE " ",$PIECE(^DPT(Y(2),.01,DPTDLKFF,0),U)

 +4       ;

NAMES2X   ;

 +1        QUIT 

 +2       ;

EOJ       ;

 +1        KILL DPTD,Y,DPTDLKF,DPTDLKFF,DPTDLKI,DPTDLKII

 +2        QUIT