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

DVBCUTL5.m

Go to the documentation of this file.
  1. DVBCUTL5 ;ALB/GTS-AMIE C&P APPT LINK USER SEL RTNS ; 10/20/94 1:00 PM
  1. ;;2.7;AMIE;**193**;Apr 10, 1995;Build 84
  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. REQARY ;** Create Array of 2507's for veteran
  1. ;
  1. ;** If 2507 status=DVBASTAT, set node in ^TMP("DVBC",$J)
  1. ;** ^TMP("DVBC",$J) ordered from newest to oldest 2507
  1. ;** The following variables must be KILLed by the calling routine:
  1. ;** DVBAMORE, DVBALP, DVBAOUT, DVBADTOT, DVBAPNAM,DVBADA,DVBADFN
  1. ;** DVBADT,DVBAORD
  1. ;** NOTE: DVBASTAT must be defined before REQARY entry
  1. S DVBACNT=0
  1. ;
  1. ;** If entered from INSUF^DVBCLOG or DVBCMKLK and open
  1. ;** exam on current 2507, Set ^TMP
  1. F S DVBADA=$O(^DVB(396.3,"B",DVBADFN,DVBADA)) Q:DVBADA="" DO
  1. .;AJF;Request Status conversion ;
  1. .I $$RSTAT^DVBCUTL8($P(^DVB(396.3,DVBADA,0),U,18))=DVBASTAT DO
  1. ..S DVBAOPEN=$$OPENCHK(DVBADA) I +DVBAOPEN'>0 K DVBAOPEN
  1. ..I '$D(DVBASDPR)!($D(DVBASDPR)&($D(DVBAOPEN))) DO
  1. ...K DVBAOPEN
  1. ...S DVBADT=$P(^DVB(396.3,DVBADA,0),"^",2),DVBACNT=DVBACNT+1
  1. ...S ^TMP("DVBC",$J,9999999.999999-DVBADT,DVBADT,DVBADA)=""
  1. Q
  1. ;
  1. REQSEL ;** Select 2507
  1. ;
  1. ;** Loop ^TMP array, display 2507's in groups of 5
  1. ;** ^TMP subscripts:
  1. ;** ^TMP("DVBC",$J,9999999.999999-2507 Request date int,
  1. ;** Request date int, Request DA)
  1. W !!,"Select a 2507 request",!
  1. S DVBAORD=""
  1. S DVBAPNAM=$P(^DPT(DVBADFN,0),"^",1)
  1. F DVBALP=1:1 S DVBAORD=$O(^TMP("DVBC",$J,DVBAORD)) Q:DVBAORD="" DO
  1. .S (DVBADT,DVBADA)=""
  1. .S DVBADT=$O(^TMP("DVBC",$J,DVBAORD,DVBADT))
  1. .S DVBADA=$O(^TMP("DVBC",$J,DVBAORD,DVBADT,DVBADA))
  1. .K Y S Y=DVBADT X ^DD("DD")
  1. .W !,?5,DVBALP,?8," ",DVBAPNAM,?40," Request date: ",Y
  1. .S DVBAMORE=$O(^TMP("DVBC",$J,DVBAORD))
  1. .I +DVBAMORE'>0 D SELREQ ;**No more entries
  1. .I (+DVBAMORE>0)&(DVBALP#5=0) DO ;**More entries exist, 5 displayed
  1. ..W !,"ENTER '^' TO STOP, OR"
  1. ..D SELREQ
  1. Q
  1. ;
  1. FINDDA ;** Loop ^TMP, get 396.3 DA
  1. F DVBALP=1:1:DVBASEL S DVBAORD=$O(^TMP("DVBC",$J,DVBAORD)) DO
  1. .S (DVBADT,DVBADA)=""
  1. .S DVBADT=$O(^TMP("DVBC",$J,DVBAORD,DVBADT))
  1. .S DVBADA=$O(^TMP("DVBC",$J,DVBAORD,DVBADT,DVBADA))
  1. Q
  1. ;
  1. SELREQ ;** Select 2507 from ^TMP
  1. K DVBAOUT
  1. S DIR(0)="NOA^1:"_DVBALP_"^K:X[""."" X"
  1. S DIR("?")="Select a 2507 request by entering it's associated number"
  1. S DIR("A")="CHOOSE 1-"_DVBALP_": " D ^DIR
  1. I $D(DTOUT)!($D(DUOUT)) S DVBAORD="9999999.999999",DVBAOUT=""
  1. I '$D(DTOUT)&('$D(DUOUT)) S:+Y>0 DVBAORD="9999999.999999"
  1. S:$D(DTOUT) DVBADTOT=""
  1. W !
  1. K DTOUT,DUOUT,DIR
  1. Q
  1. ;
  1. OPENCHK(REQDA) ;** Check for open exam on 2507
  1. N LPDA,QVAR
  1. S LPDA=""
  1. F S LPDA=$O(^DVB(396.4,"C",REQDA,LPDA)) Q:'LPDA!($D(QVAR)) DO
  1. .I $P(^DVB(396.4,LPDA,0),U,4)="O" DO
  1. ..S:'$D(QVAR) QVAR=LPDA
  1. S:'$D(QVAR) QVAR=""
  1. Q +QVAR
  1. ;
  1. REQPAT() ;** Select patient who has 2507's
  1. S DIC(0)="AEMQ",DIC("A")="Select C&P Veteran Name: ",DIC="^DPT("
  1. S DIC("S")="I $D(^DVB(396.3,""B"",+Y))" D ^DIC K DIC
  1. Q +Y
  1. ;
  1. CPPATARY(DVBADFN) ;** Set ^TMP of 2507's for vet
  1. ;
  1. ;** ^TMP array ordered newest to oldest
  1. ;** DVBACNT to be killed by calling routine
  1. N REQDA,REQDT,REQ
  1. S DVBACNT=0
  1. S REQDA=""
  1. F S REQDA=$O(^DVB(396.3,"B",DVBADFN,REQDA)) Q:REQDA="" DO
  1. .S REQ=$G(^DVB(396.3,REQDA,0))
  1. .;AJF;Request Status conversion ;changed "N" to 1
  1. .I +$P(REQ,U,2)>0,($P(REQ,U,18)'=1) DO
  1. ..I $P(REQ,U,18)'="" DO
  1. ...S REQDT=$P(REQ,"^",2),DVBACNT=DVBACNT+1
  1. ...S ^TMP("DVBC",$J,9999999.999999-REQDT,REQDT,REQDA)=""
  1. Q
  1. ;
  1. NO2507 ;** 2507 not selected, error
  1. S DIR("A",1)="You have not selected a 2507 request to link a C&P appointment to."
  1. S DIR("A",2)="This is required to continue processing with the AMIE link management option."
  1. S DIR("A",3)=" "
  1. S DIR(0)="FAO^1:1",DIR("A")="Hit Return to continue." D ^DIR K DIR,X,Y
  1. Q
  1. ;
  1. SDEVTSPC(DVBAPCE) ;**Return piece of 'S' node in Sched event
  1. N DVBASPCV
  1. S DVBASPCV=""
  1. S:($D(^TMP("SDEVT",$J,SDHDL,1,"DPT",0,"AFTER"))) DVBASPCV=$P(^TMP("SDEVT",$J,SDHDL,1,"DPT",0,"AFTER"),U,DVBAPCE)
  1. Q DVBASPCV
  1. ;
  1. SDEVTXST() ;** Check ^TMP("SDEVT",$J) existence
  1. Q $D(^TMP("SDEVT",$J,SDHDL,1,"DPT",0,"AFTER"))
  1. ;
  1. SDORGST() ;** Return value of SD Event originating process
  1. N DVBAVAR
  1. S DVBAVAR=""
  1. Q $O(^TMP("SDEVT",$J,SDHDL,DVBAVAR))
  1. ;