Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: DPTDZCH

DPTDZCH.m

Go to the documentation of this file.
  1. DPTDZCH ; IHS/TUCSON/JCM - DISPLAYS CHART NUMBERS FROM PATIENT FILE ; [ 09/12/2001 5:45 AM ]
  1. ;;1.0;PATIENT MERGE;;FEB 02, 1994
  1. ;IHS/ANMC/LJF 9/10/2001 added code to display other names
  1. ; 9/11/2001 fixed code under CHARTS2 to quit if no more
  1. ;
  1. START ;
  1. D NAMES ;IHS/ANMC/LJF 9/10/2001
  1. D CHARTS
  1. D EOJ
  1. Q
  1. ;
  1. CHARTS ; Displays chart numbers and facilities for patients
  1. W !!,"*** HEALTH RECORD NO."
  1. S Y=XDRMCD,Y(2)=XDRMCD2
  1. S DPTDLKF=0,DPTDLKFF=0,DPTDLKI=0
  1. 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
  1. 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
  1. Q
  1. CHART2 ;prints second patient's chart numbers
  1. I '$D(DPTDLKII),$P(^AUPNPAT(Y(2),41,0),U,4)<(DPTDLKI+1) G CHART2X
  1. S DPTDLKFF=$O(^AUPNPAT(Y(2),41,DPTDLKFF))
  1. Q:'DPTDLKFF Q:'$D(^AUTTLOC(DPTDLKFF,0)) ;IHS/ANMC/LJF 9/12/2001
  1. W ?49 W " ",$J($P(^AUTTLOC(DPTDLKFF,0),U,7),4)," ",$P(^AUPNPAT(Y(2),41,DPTDLKFF,0),U,2)
  1. ;
  1. CHART2X ;
  1. Q
  1. ;
  1. ;IHS/ANMC/LJF 9/10/2001 added NAMES and NAMES2 subrtns
  1. NAMES ; Displays other names for patients
  1. W !!,"*** ALIAS DETAILS:"
  1. S Y=XDRMCD,Y(2)=XDRMCD2
  1. S DPTDLKF=0,DPTDLKFF=0,DPTDLKI=0
  1. 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
  1. 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
  1. Q
  1. NAMES2 ;prints second patient's other names
  1. I '$D(DPTDLKII),$P(^DPT(Y(2),.01,0),U,4)<(DPTDLKI+1) G NAMES2X
  1. S DPTDLKFF=$O(^DPT(Y(2),.01,DPTDLKFF)) Q:'DPTDLKFF
  1. W ?49 W " ",$P(^DPT(Y(2),.01,DPTDLKFF,0),U)
  1. ;
  1. NAMES2X ;
  1. Q
  1. ;
  1. EOJ ;
  1. K DPTD,Y,DPTDLKF,DPTDLKFF,DPTDLKI,DPTDLKII
  1. Q