- 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