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

DVBCUTL6.m

Go to the documentation of this file. 
  1. DVBCUTL6 ;ALB/GTS-AMIE C&P APPT LINK DISPLAY SUBRTNS ; 10/20/94  1:45 PM
  1.  ;;2.7;AMIE;**1**;Apr 10, 1995
  1.  ;
  1.  ;** NOTICE: This routine is part of an implementation of a Nationally
  1.  ;**         Controlled Procedure.  Local modifications to this routine
  1.  ;**         are prohibited per VHA Directive 10-93-142
  1.  ;
  1.  ;** Version Changes
  1.  ;   2.7 - New routine (Enhc 13)
  1.  ;
  1. LKHDOUT ;** Link MGNT screen hdr
  1.  W @IOF
  1.  W "AMIE/C&P Appointment Link Management",!!,"Current appointment links"
  1.  W !,"Clinic",?32,"Date/Time",?51,"Status",!
  1.  Q
  1.  ;
  1. EXMOUT(LPDA) ;** Output exam
  1.  W !!,"Exam: ",$P(^DVB(396.6,$P(^DVB(396.4,LPDA,0),U,3),0),U,2)
  1.  W !,"Clinic",?32,"Date/Time",?49,"Status"
  1.  Q
  1.  ;
  1. EXMDISP(REQDA) ;** Output Open/Completed exams
  1.  D EXMHD
  1.  N DVBADA,DVBASTAT
  1.  S DVBADA=""
  1.  F  S DVBADA=$O(^DVB(396.4,"C",REQDA,DVBADA)) Q:(DVBADA=""!($D(DTOUT)!$D(DUOUT)))  DO
  1.  .I $D(^DVB(396.4,DVBADA,0)) DO
  1.  ..S DVBASTAT=$P(^DVB(396.4,DVBADA,0),U,4)
  1.  ..D EXAMLST^DVBCUTA4(DVBADA,DVBASTAT)
  1.  Q
  1.  ;
  1. EXMHD ;** Exam header
  1.  W @IOF
  1.  N DVBALN
  1.  S Y=$P(^DVB(396.3,REQDA,0),U,5)
  1.  X ^DD("DD")
  1.  W !!,"AMIE exams on 2507 request for: ",$P(^DPT($P(^DVB(396.3,REQDA,0),U,1),0),U,1)
  1.  W !,"2507 Request Date Reported to MAS: ",Y
  1.  S $P(DVBALN,"-",80)=""
  1.  W !,DVBALN
  1.  W !!,"Exam:",?40,"Status:"
  1.  K Y
  1.  Q
  1.  ;
  1. APPTSEL(DVBADFN,APPTTYPE,REQDA,STRTDT,ENDDT) ;Select appt
  1.  ;** APPTTYPE = appt type to select
  1.  ;** STRTDT,ENDDT = selected date range
  1.  ;
  1.  ;** APPTSEL creates ^TMP = appt's of APPTTYPE in date range
  1.  ;** ^TMP=appt dte-ext ^ Clinic-ext ^ Status-ext ^ appt dte-int
  1.  W @IOF
  1.  N TMPDA
  1.  S STRTDT=STRTDT-.1,TMPDA=1
  1.  S:+STRTDT<0 STRTDT=0
  1.  S:'$D(ENDDT) ENDDT=""
  1.  S:ENDDT="" ENDDT=9999999
  1.  K STATUS,STATVAR
  1.  I $D(^DPT(DVBADFN,"S")) DO
  1.  .F  S STRTDT=$O(^DPT(DVBADFN,"S",STRTDT)) Q:(STRTDT=""!(STRTDT>ENDDT))  DO
  1.  ..I $P(^DPT(DVBADFN,"S",STRTDT,0),U,16)=APPTTYPE DO
  1.  ...S TMPDA=TMPDA+1
  1.  ...S DA=DVBADFN,DA(2.98)=STRTDT,DR="1900",DR(2.98)=".01",DIC=2
  1.  ...S DIQ="DVBAARY" K ^UTILITY("DIQ",$J)
  1.  ...D EN^DIQ1 K ^UTILITY("DIQ",$J)
  1.  ...S Y=STRTDT X ^DD("DD")
  1.  ...S STATVAR=$$STATUS^SDAM1(DVBADFN,STRTDT,$P(^DPT(DVBADFN,"S",STRTDT,0),U,1),^DPT(DVBADFN,"S",STRTDT,0))
  1.  ...S STATUS=$P(STATVAR,";",3)
  1.  ...S ^TMP("DVBC",$J,TMPDA)=Y_"^"_DVBAARY(2.98,STRTDT,.01)_"^"_STATUS_"^"_STRTDT
  1.  ...K DVBAARY(2.98),Y,STATUS,STATVAR
  1.  D ARYDISP
  1.  Q
  1.  ;
  1. ARYDISP ;** Display appts for selection
  1.  ;** run APPTSEL before ARYDISP
  1.  ;
  1.  ;** DVBAAPT returned (= selected ^TMP node)
  1.  ;
  1.  K DA,DR,DIC,DIQ
  1.  I '$D(DVBAMORE) N DVBAMORE
  1.  I '$D(TMPDA) N TMPDA
  1.  W !!!,"Select an appointment to link to the 2507 request",!
  1.  W !,?1,"1",?4,"Display Current C&P Appointment Links"
  1.  S ^TMP("DVBC",$J,1)=""
  1.  F TMPDA=2:1 Q:'$D(^TMP("DVBC",$J,TMPDA))  DO
  1.  .W !,?1,TMPDA,?4,$P(^TMP("DVBC",$J,TMPDA),U,1)
  1.  .W ?23,$E($P(^TMP("DVBC",$J,TMPDA),U,2),1,22)
  1.  .W:$D(^DVB(396.95,"AB",REQDA,$P(^TMP("DVBC",$J,TMPDA),U,4))) ?47,"*CL"
  1.  .W ?51,$E($P(^TMP("DVBC",$J,TMPDA),U,3),1,27)
  1.  .S DVBAMORE=$O(^TMP("DVBC",$J,TMPDA))
  1.  .I +DVBAMORE'>0 D SELAPT
  1.  .I (+DVBAMORE>0)&(TMPDA#5=0) D SELAPT
  1.  S DVBAAPT=""
  1.  I $D(Y) DO
  1.  .S DVBAAPT=^TMP("DVBC",$J,+Y)
  1.  .K ^TMP("DVBC",$J,+Y)
  1.  Q
  1.  ;
  1. SELAPT ;** Select Appt
  1.  W !
  1.  S DIR("A",1)="ENTER '^' TO STOP, OR"
  1.  S DIR("A")="CHOOSE 1-"_TMPDA_": "
  1.  S DIR(0)="NOA^1:"_TMPDA_"^I X["".""!('$D(^TMP(""DVBC"",$J,+Y))) K X"
  1.  S DIR("?",1)="Select an appointment by entering its associated number."
  1.  S DIR("?",2)=" *CL following Clinic means the appointment date is the"
  1.  S DIR("?",2)=DIR("?",2)_" Current Date for"
  1.  S DIR("?",3)=" an existing link."
  1.  S DIR("?",4)="Enter '1' to see the current links to this 2507."
  1.  S DIR("?")="Select from the numbers listed."
  1.  D ^DIR
  1.  I $D(DTOUT)!($D(DUOUT)) S TMPDA=9999,DVBAOUT=""
  1.  S:+Y>1 TMPDA=9999
  1.  W:+Y'>0 !
  1.  I +Y=1 DO
  1.  .W @IOF
  1.  .D LNKARY^DVBCUTA3(REQDA,DVBADFN)
  1.  .D LNKLIST^DVBCUTA3
  1.  .S:TMPDA'>5 TMPDA=TMPDA-1
  1.  .S:(TMPDA>5&(TMPDA#5=0)) TMPDA=TMPDA-5
  1.  .S:(TMPDA>5&(TMPDA#5'=0)) TMPDA=TMPDA-1
  1.  .D REFRSH^DVBCUTA4(TMPDA)
  1.  .K Y
  1.  I $D(Y),(+Y'>0) K Y
  1.  K DIR,DTOUT,DUOUT
  1.  Q
  1.  ;
  1. LINKINF(REQDA,CURRAPT) ;** Display Link info
  1.  N LINKNODE,LINKDA,INITDTE,ORIGDTE,VETDTE
  1.  S LINKDA=""
  1.  S LINKDA=$O(^DVB(396.95,"AB",REQDA,CURRAPT,LINKDA))
  1.  S LINKNODE=^DVB(396.95,LINKDA,0)
  1.  S INITDTE=$P(LINKNODE,U,1)
  1.  S ORIGDTE=$P(LINKNODE,U,2)
  1.  S VETDTE=$P(LINKNODE,U,5)
  1.  I INITDTE'=CURRAPT DO
  1.  .K Y
  1.  .S Y=INITDTE
  1.  .X ^DD("DD")
  1.  .W !,"Initial Appt: ",?36,Y
  1.  I ORIGDTE'=CURRAPT DO
  1.  .K Y
  1.  .S Y=ORIGDTE
  1.  .X ^DD("DD")
  1.  .W !,"Clock Stop Appt: ",?36,Y
  1.  I VETDTE'=""&(VETDTE'=CURRAPT) DO
  1.  .K Y
  1.  .S Y=VETDTE
  1.  .X ^DD("DD")
  1.  .W !,"Last Veteran requested Appointment: ",?36,Y
  1.  K Y
  1.  S Y=CURRAPT
  1.  X ^DD("DD")
  1.  W !,"Current Appt: ",?36,Y
  1.  K Y
  1.  Q