- DVBCUTL5 ;ALB/GTS-AMIE C&P APPT LINK USER SEL RTNS ; 10/20/94 1:00 PM
- ;;2.7;AMIE;**193**;Apr 10, 1995;Build 84
- ;
- ;** NOTICE: This routine is part of an implementation of a Nationally
- ;** Controlled Procedure. Local modifications to this routine
- ;** are prohibited per VHA Directive 10-93-142
- ;
- ;** Version Changes
- ; 2.7 - New routine (Enhc 13)
- ;
- REQARY ;** Create Array of 2507's for veteran
- ;
- ;** If 2507 status=DVBASTAT, set node in ^TMP("DVBC",$J)
- ;** ^TMP("DVBC",$J) ordered from newest to oldest 2507
- ;** The following variables must be KILLed by the calling routine:
- ;** DVBAMORE, DVBALP, DVBAOUT, DVBADTOT, DVBAPNAM,DVBADA,DVBADFN
- ;** DVBADT,DVBAORD
- ;** NOTE: DVBASTAT must be defined before REQARY entry
- S DVBACNT=0
- ;
- ;** If entered from INSUF^DVBCLOG or DVBCMKLK and open
- ;** exam on current 2507, Set ^TMP
- F S DVBADA=$O(^DVB(396.3,"B",DVBADFN,DVBADA)) Q:DVBADA="" DO
- .;AJF;Request Status conversion ;
- .I $$RSTAT^DVBCUTL8($P(^DVB(396.3,DVBADA,0),U,18))=DVBASTAT DO
- ..S DVBAOPEN=$$OPENCHK(DVBADA) I +DVBAOPEN'>0 K DVBAOPEN
- ..I '$D(DVBASDPR)!($D(DVBASDPR)&($D(DVBAOPEN))) DO
- ...K DVBAOPEN
- ...S DVBADT=$P(^DVB(396.3,DVBADA,0),"^",2),DVBACNT=DVBACNT+1
- ...S ^TMP("DVBC",$J,9999999.999999-DVBADT,DVBADT,DVBADA)=""
- Q
- ;
- REQSEL ;** Select 2507
- ;
- ;** Loop ^TMP array, display 2507's in groups of 5
- ;** ^TMP subscripts:
- ;** ^TMP("DVBC",$J,9999999.999999-2507 Request date int,
- ;** Request date int, Request DA)
- W !!,"Select a 2507 request",!
- S DVBAORD=""
- S DVBAPNAM=$P(^DPT(DVBADFN,0),"^",1)
- F DVBALP=1:1 S DVBAORD=$O(^TMP("DVBC",$J,DVBAORD)) Q:DVBAORD="" DO
- .S (DVBADT,DVBADA)=""
- .S DVBADT=$O(^TMP("DVBC",$J,DVBAORD,DVBADT))
- .S DVBADA=$O(^TMP("DVBC",$J,DVBAORD,DVBADT,DVBADA))
- .K Y S Y=DVBADT X ^DD("DD")
- .W !,?5,DVBALP,?8," ",DVBAPNAM,?40," Request date: ",Y
- .S DVBAMORE=$O(^TMP("DVBC",$J,DVBAORD))
- .I +DVBAMORE'>0 D SELREQ ;**No more entries
- .I (+DVBAMORE>0)&(DVBALP#5=0) DO ;**More entries exist, 5 displayed
- ..W !,"ENTER '^' TO STOP, OR"
- ..D SELREQ
- Q
- ;
- FINDDA ;** Loop ^TMP, get 396.3 DA
- F DVBALP=1:1:DVBASEL S DVBAORD=$O(^TMP("DVBC",$J,DVBAORD)) DO
- .S (DVBADT,DVBADA)=""
- .S DVBADT=$O(^TMP("DVBC",$J,DVBAORD,DVBADT))
- .S DVBADA=$O(^TMP("DVBC",$J,DVBAORD,DVBADT,DVBADA))
- Q
- ;
- SELREQ ;** Select 2507 from ^TMP
- K DVBAOUT
- S DIR(0)="NOA^1:"_DVBALP_"^K:X[""."" X"
- S DIR("?")="Select a 2507 request by entering it's associated number"
- S DIR("A")="CHOOSE 1-"_DVBALP_": " D ^DIR
- I $D(DTOUT)!($D(DUOUT)) S DVBAORD="9999999.999999",DVBAOUT=""
- I '$D(DTOUT)&('$D(DUOUT)) S:+Y>0 DVBAORD="9999999.999999"
- S:$D(DTOUT) DVBADTOT=""
- W !
- K DTOUT,DUOUT,DIR
- Q
- ;
- OPENCHK(REQDA) ;** Check for open exam on 2507
- N LPDA,QVAR
- S LPDA=""
- F S LPDA=$O(^DVB(396.4,"C",REQDA,LPDA)) Q:'LPDA!($D(QVAR)) DO
- .I $P(^DVB(396.4,LPDA,0),U,4)="O" DO
- ..S:'$D(QVAR) QVAR=LPDA
- S:'$D(QVAR) QVAR=""
- Q +QVAR
- ;
- REQPAT() ;** Select patient who has 2507's
- S DIC(0)="AEMQ",DIC("A")="Select C&P Veteran Name: ",DIC="^DPT("
- S DIC("S")="I $D(^DVB(396.3,""B"",+Y))" D ^DIC K DIC
- Q +Y
- ;
- CPPATARY(DVBADFN) ;** Set ^TMP of 2507's for vet
- ;
- ;** ^TMP array ordered newest to oldest
- ;** DVBACNT to be killed by calling routine
- N REQDA,REQDT,REQ
- S DVBACNT=0
- S REQDA=""
- F S REQDA=$O(^DVB(396.3,"B",DVBADFN,REQDA)) Q:REQDA="" DO
- .S REQ=$G(^DVB(396.3,REQDA,0))
- .;AJF;Request Status conversion ;changed "N" to 1
- .I +$P(REQ,U,2)>0,($P(REQ,U,18)'=1) DO
- ..I $P(REQ,U,18)'="" DO
- ...S REQDT=$P(REQ,"^",2),DVBACNT=DVBACNT+1
- ...S ^TMP("DVBC",$J,9999999.999999-REQDT,REQDT,REQDA)=""
- Q
- ;
- NO2507 ;** 2507 not selected, error
- S DIR("A",1)="You have not selected a 2507 request to link a C&P appointment to."
- S DIR("A",2)="This is required to continue processing with the AMIE link management option."
- S DIR("A",3)=" "
- S DIR(0)="FAO^1:1",DIR("A")="Hit Return to continue." D ^DIR K DIR,X,Y
- Q
- ;
- SDEVTSPC(DVBAPCE) ;**Return piece of 'S' node in Sched event
- N DVBASPCV
- S DVBASPCV=""
- S:($D(^TMP("SDEVT",$J,SDHDL,1,"DPT",0,"AFTER"))) DVBASPCV=$P(^TMP("SDEVT",$J,SDHDL,1,"DPT",0,"AFTER"),U,DVBAPCE)
- Q DVBASPCV
- ;
- SDEVTXST() ;** Check ^TMP("SDEVT",$J) existence
- Q $D(^TMP("SDEVT",$J,SDHDL,1,"DPT",0,"AFTER"))
- ;
- SDORGST() ;** Return value of SD Event originating process
- N DVBAVAR
- S DVBAVAR=""
- Q $O(^TMP("SDEVT",$J,SDHDL,DVBAVAR))
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBCUTL5 4436 printed Jan 18, 2025@02:50:27 Page 2
- 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
- +2 ;
- +3 ;** NOTICE: This routine is part of an implementation of a Nationally
- +4 ;** Controlled Procedure. Local modifications to this routine
- +5 ;** are prohibited per VHA Directive 10-93-142
- +6 ;
- +7 ;** Version Changes
- +8 ; 2.7 - New routine (Enhc 13)
- +9 ;
- REQARY ;** Create Array of 2507's for veteran
- +1 ;
- +2 ;** If 2507 status=DVBASTAT, set node in ^TMP("DVBC",$J)
- +3 ;** ^TMP("DVBC",$J) ordered from newest to oldest 2507
- +4 ;** The following variables must be KILLed by the calling routine:
- +5 ;** DVBAMORE, DVBALP, DVBAOUT, DVBADTOT, DVBAPNAM,DVBADA,DVBADFN
- +6 ;** DVBADT,DVBAORD
- +7 ;** NOTE: DVBASTAT must be defined before REQARY entry
- +8 SET DVBACNT=0
- +9 ;
- +10 ;** If entered from INSUF^DVBCLOG or DVBCMKLK and open
- +11 ;** exam on current 2507, Set ^TMP
- +12 FOR
- SET DVBADA=$ORDER(^DVB(396.3,"B",DVBADFN,DVBADA))
- if DVBADA=""
- QUIT
- Begin DoDot:1
- +13 ;AJF;Request Status conversion ;
- +14 IF $$RSTAT^DVBCUTL8($PIECE(^DVB(396.3,DVBADA,0),U,18))=DVBASTAT
- Begin DoDot:2
- +15 SET DVBAOPEN=$$OPENCHK(DVBADA)
- IF +DVBAOPEN'>0
- KILL DVBAOPEN
- +16 IF '$DATA(DVBASDPR)!($DATA(DVBASDPR)&($DATA(DVBAOPEN)))
- Begin DoDot:3
- +17 KILL DVBAOPEN
- +18 SET DVBADT=$PIECE(^DVB(396.3,DVBADA,0),"^",2)
- SET DVBACNT=DVBACNT+1
- +19 SET ^TMP("DVBC",$JOB,9999999.999999-DVBADT,DVBADT,DVBADA)=""
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +20 QUIT
- +21 ;
- REQSEL ;** Select 2507
- +1 ;
- +2 ;** Loop ^TMP array, display 2507's in groups of 5
- +3 ;** ^TMP subscripts:
- +4 ;** ^TMP("DVBC",$J,9999999.999999-2507 Request date int,
- +5 ;** Request date int, Request DA)
- +6 WRITE !!,"Select a 2507 request",!
- +7 SET DVBAORD=""
- +8 SET DVBAPNAM=$PIECE(^DPT(DVBADFN,0),"^",1)
- +9 FOR DVBALP=1:1
- SET DVBAORD=$ORDER(^TMP("DVBC",$JOB,DVBAORD))
- if DVBAORD=""
- QUIT
- Begin DoDot:1
- +10 SET (DVBADT,DVBADA)=""
- +11 SET DVBADT=$ORDER(^TMP("DVBC",$JOB,DVBAORD,DVBADT))
- +12 SET DVBADA=$ORDER(^TMP("DVBC",$JOB,DVBAORD,DVBADT,DVBADA))
- +13 KILL Y
- SET Y=DVBADT
- XECUTE ^DD("DD")
- +14 WRITE !,?5,DVBALP,?8," ",DVBAPNAM,?40," Request date: ",Y
- +15 SET DVBAMORE=$ORDER(^TMP("DVBC",$JOB,DVBAORD))
- +16 ;**No more entries
- IF +DVBAMORE'>0
- DO SELREQ
- +17 ;**More entries exist, 5 displayed
- IF (+DVBAMORE>0)&(DVBALP#5=0)
- Begin DoDot:2
- +18 WRITE !,"ENTER '^' TO STOP, OR"
- +19 DO SELREQ
- End DoDot:2
- End DoDot:1
- +20 QUIT
- +21 ;
- FINDDA ;** Loop ^TMP, get 396.3 DA
- +1 FOR DVBALP=1:1:DVBASEL
- SET DVBAORD=$ORDER(^TMP("DVBC",$JOB,DVBAORD))
- Begin DoDot:1
- +2 SET (DVBADT,DVBADA)=""
- +3 SET DVBADT=$ORDER(^TMP("DVBC",$JOB,DVBAORD,DVBADT))
- +4 SET DVBADA=$ORDER(^TMP("DVBC",$JOB,DVBAORD,DVBADT,DVBADA))
- End DoDot:1
- +5 QUIT
- +6 ;
- SELREQ ;** Select 2507 from ^TMP
- +1 KILL DVBAOUT
- +2 SET DIR(0)="NOA^1:"_DVBALP_"^K:X[""."" X"
- +3 SET DIR("?")="Select a 2507 request by entering it's associated number"
- +4 SET DIR("A")="CHOOSE 1-"_DVBALP_": "
- DO ^DIR
- +5 IF $DATA(DTOUT)!($DATA(DUOUT))
- SET DVBAORD="9999999.999999"
- SET DVBAOUT=""
- +6 IF '$DATA(DTOUT)&('$DATA(DUOUT))
- if +Y>0
- SET DVBAORD="9999999.999999"
- +7 if $DATA(DTOUT)
- SET DVBADTOT=""
- +8 WRITE !
- +9 KILL DTOUT,DUOUT,DIR
- +10 QUIT
- +11 ;
- OPENCHK(REQDA) ;** Check for open exam on 2507
- +1 NEW LPDA,QVAR
- +2 SET LPDA=""
- +3 FOR
- SET LPDA=$ORDER(^DVB(396.4,"C",REQDA,LPDA))
- if 'LPDA!($DATA(QVAR))
- QUIT
- Begin DoDot:1
- +4 IF $PIECE(^DVB(396.4,LPDA,0),U,4)="O"
- Begin DoDot:2
- +5 if '$DATA(QVAR)
- SET QVAR=LPDA
- End DoDot:2
- End DoDot:1
- +6 if '$DATA(QVAR)
- SET QVAR=""
- +7 QUIT +QVAR
- +8 ;
- REQPAT() ;** Select patient who has 2507's
- +1 SET DIC(0)="AEMQ"
- SET DIC("A")="Select C&P Veteran Name: "
- SET DIC="^DPT("
- +2 SET DIC("S")="I $D(^DVB(396.3,""B"",+Y))"
- DO ^DIC
- KILL DIC
- +3 QUIT +Y
- +4 ;
- CPPATARY(DVBADFN) ;** Set ^TMP of 2507's for vet
- +1 ;
- +2 ;** ^TMP array ordered newest to oldest
- +3 ;** DVBACNT to be killed by calling routine
- +4 NEW REQDA,REQDT,REQ
- +5 SET DVBACNT=0
- +6 SET REQDA=""
- +7 FOR
- SET REQDA=$ORDER(^DVB(396.3,"B",DVBADFN,REQDA))
- if REQDA=""
- QUIT
- Begin DoDot:1
- +8 SET REQ=$GET(^DVB(396.3,REQDA,0))
- +9 ;AJF;Request Status conversion ;changed "N" to 1
- +10 IF +$PIECE(REQ,U,2)>0
- IF ($PIECE(REQ,U,18)'=1)
- Begin DoDot:2
- +11 IF $PIECE(REQ,U,18)'=""
- Begin DoDot:3
- +12 SET REQDT=$PIECE(REQ,"^",2)
- SET DVBACNT=DVBACNT+1
- +13 SET ^TMP("DVBC",$JOB,9999999.999999-REQDT,REQDT,REQDA)=""
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +14 QUIT
- +15 ;
- NO2507 ;** 2507 not selected, error
- +1 SET DIR("A",1)="You have not selected a 2507 request to link a C&P appointment to."
- +2 SET DIR("A",2)="This is required to continue processing with the AMIE link management option."
- +3 SET DIR("A",3)=" "
- +4 SET DIR(0)="FAO^1:1"
- SET DIR("A")="Hit Return to continue."
- DO ^DIR
- KILL DIR,X,Y
- +5 QUIT
- +6 ;
- SDEVTSPC(DVBAPCE) ;**Return piece of 'S' node in Sched event
- +1 NEW DVBASPCV
- +2 SET DVBASPCV=""
- +3 if ($DATA(^TMP("SDEVT",$JOB,SDHDL,1,"DPT",0,"AFTER")))
- SET DVBASPCV=$PIECE(^TMP("SDEVT",$JOB,SDHDL,1,"DPT",0,"AFTER"),U,DVBAPCE)
- +4 QUIT DVBASPCV
- +5 ;
- SDEVTXST() ;** Check ^TMP("SDEVT",$J) existence
- +1 QUIT $DATA(^TMP("SDEVT",$JOB,SDHDL,1,"DPT",0,"AFTER"))
- +2 ;
- SDORGST() ;** Return value of SD Event originating process
- +1 NEW DVBAVAR
- +2 SET DVBAVAR=""
- +3 QUIT $ORDER(^TMP("SDEVT",$JOB,SDHDL,DVBAVAR))
- +4 ;