- DVBCMKLK ;ALB/GTS-AMIE C&P APPT EVENT DRIVER-LINK RTN ; 10/20/94 4:00 PM
- ;;2.7;AMIE;;Apr 10, 1995
- ;
- ;** 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)
- ;
- EN ;** Link C&P appointment to 2507
- S DVBADFN=DFN,DVBASTAT="P" ;**DVBASTAT used in REQARY^DVBCUTL5
- ;
- ;**If user entered from AMIE Scheduling, only prompted if enhanced
- ;** dialogue turned on and is needed
- ;** QUIT on next line if from DVBCSCHD
- I $D(DVBASDRT) S DVBADA=REQDA D LINKAPPT^DVBCMKL2,KVARS QUIT ;*DVBCSCHD
- S (DVBADA,DVBASDPR)=""
- D REQARY^DVBCUTL5 ;**Set up ^TMP of AMIE 2507's
- I +DVBACNT>0 DO
- .I +DVBACNT=1 DO ;**Auto select 2507 if only one exists
- ..S (DVBADT,DVBADA,DVBAORD)=""
- ..S DVBAORD=$O(^TMP("DVBC",$J,DVBAORD))
- ..S DVBADT=$O(^TMP("DVBC",$J,DVBAORD,DVBADT))
- ..S DVBADA=$O(^TMP("DVBC",$J,DVBAORD,DVBADT,DVBADA))
- .I +DVBACNT>1 DO ;**If more than one 2507 exists, user select
- ..D REQSEL^DVBCUTL5 ;**Select a 2507 from ^TMP
- ..I (+Y'>0)!($D(DVBAOUT)) S DVBADA=""
- ..S:+Y>0 DVBASEL=+Y ;**Y is selected 2507 val returned from ^DIR
- ..D:+Y>0 FINDDA^DVBCUTL5 ;**Find selected 2507 DA (Returned in DVBADA)
- .K ^TMP("DVBC",$J)
- .I '$D(^DVB(396.3,+DVBADA,0)),(+$$ENHNC^DVBCUTA4=1) DO ;**Write warning
- ..S DIR("A",1)="You have not selected a 2507 request to link the C&P appointment to."
- ..S DIR("A",2)="The appointment should be linked with the AMIE/C&P Appointment Link"
- ..S DIR("A",3)=" Management Option to ensure proper processing time calculation for this 2507"
- ..S DIR("A",4)=" in the event of a veteran cancellation."
- ..S DIR("A",5)=" "
- ..S DIR(0)="FAO^1:1",DIR("A")="Hit any key to continue." D ^DIR K DIR,X,Y
- .I $D(^DVB(396.3,+DVBADA,0)) D LINKAPPT^DVBCMKL2 ;**If 2507, link appt
- I +DVBACNT'>0,(+$$ENHNC^DVBCUTA4=1) DO ;**Write Warning
- .S DIR("A",1)="You have made a C&P appointment for a patient who has no pending 2507 request!"
- .S DIR("A",2)=" "
- .S DIR(0)="FAO^1:1",DIR("A")="Hit any key to continue." D ^DIR K DIR,X,Y
- Q
- ;
- KVARS ;** Kill variables used by scheduling protocol
- K DVBAMORE,DVBALP,DVBAOUT,DVBADTOT,DVBASDPR,DVBASEL
- K DVBAPNAM,DVBADA,DVBADFN,DVBASTAT,DVBADT,DVBAORD,DVBACNT
- K ^TMP("DVBC",$J),Y,DVBAYANS,DVBALKRC,DVBARSAP
- Q
- ;
- CRTREC ;** Add a record to file 396.95 (Appt Tracking)
- K DD,DO
- S DVBAADT=$P(SDATA,U,3)
- S DIC="^DVB(396.95,",X=DVBAADT,DIC(0)="LX",DLAYGO="396.95"
- S DIC("DR")=".02////^S X=DVBAADT;.03////^S X=DVBAADT;"
- S DIC("DR")=DIC("DR")_".04////^S X=0;.06////^S X=DVBADA;"
- S DIC("DR")=DIC("DR")_".07////^S X=1"
- D FILE^DICN K DIC,X,DLAYGO,DVBAADT
- I +$$ENHNC^DVBCUTA4=1 DO
- .N REQDT,SAVY
- .S:$D(Y) SAVY=Y
- .S REQDT=$$GETDTE(DVBADA) ;**Set REQDT
- .S:$D(SAVY) Y=SAVY
- .S DIR("A",1)=" "
- .S DIR("A",2)="Adding new C&P appointment link for 2507 request dated "_REQDT_"."
- .S DIR("A",3)=" "
- .S DIR(0)="FAO^1:1",DIR("A")="Hit any key to continue." D ^DIR K DIR,X,Y
- Q
- ;
- GETDTE(REQDA) ;** Get the request dte
- N REQDT
- K Y S Y=$P(^DVB(396.3,REQDA,0),U,2) X ^DD("DD")
- S REQDT=Y
- K Y
- Q REQDT
- ;
- RSCHAPT(LKDA,RSCHDT) ;** Update Appt record with reschedule data
- S DA=+LKDA,DIE="^DVB(396.95,",DR=".03////^S X=RSCHDT;.07////1"
- S:(+$P(^DVB(396.95,DA,0),U,4)=0&('$D(DVBAVTRQ))) DR=".02////^S X=RSCHDT;"_DR
- S:($D(DVBAVTRQ)) DR=".04////^S X=1;.05////^S X=RSCHDT;"_DR
- D ^DIE K DA,DIE,DR
- I +$$ENHNC^DVBCUTA4=1 DO
- .N REQDT,SAVY
- .S:$D(Y) SAVY=Y
- .S REQDT=$$GETDTE($P(^DVB(396.95,LKDA,0),U,6)) ;**Set REQDT
- .S:$D(SAVY) Y=SAVY
- .S DIR("A",1)=" "
- .S DIR("A",2)="Adjusting C&P appointment link for 2507 request dated "_REQDT_"."
- .S DIR("A",3)=" "
- .S DIR(0)="FAO^1:1",DIR("A")="Hit any key to continue." D ^DIR K DIR,X,Y
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBCMKLK 3854 printed Feb 18, 2025@23:11:16 Page 2
- DVBCMKLK ;ALB/GTS-AMIE C&P APPT EVENT DRIVER-LINK RTN ; 10/20/94 4:00 PM
- +1 ;;2.7;AMIE;;Apr 10, 1995
- +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 ;
- EN ;** Link C&P appointment to 2507
- +1 ;**DVBASTAT used in REQARY^DVBCUTL5
- SET DVBADFN=DFN
- SET DVBASTAT="P"
- +2 ;
- +3 ;**If user entered from AMIE Scheduling, only prompted if enhanced
- +4 ;** dialogue turned on and is needed
- +5 ;** QUIT on next line if from DVBCSCHD
- +6 ;*DVBCSCHD
- IF $DATA(DVBASDRT)
- SET DVBADA=REQDA
- DO LINKAPPT^DVBCMKL2
- DO KVARS
- QUIT
- +7 SET (DVBADA,DVBASDPR)=""
- +8 ;**Set up ^TMP of AMIE 2507's
- DO REQARY^DVBCUTL5
- +9 IF +DVBACNT>0
- Begin DoDot:1
- +10 ;**Auto select 2507 if only one exists
- IF +DVBACNT=1
- Begin DoDot:2
- +11 SET (DVBADT,DVBADA,DVBAORD)=""
- +12 SET DVBAORD=$ORDER(^TMP("DVBC",$JOB,DVBAORD))
- +13 SET DVBADT=$ORDER(^TMP("DVBC",$JOB,DVBAORD,DVBADT))
- +14 SET DVBADA=$ORDER(^TMP("DVBC",$JOB,DVBAORD,DVBADT,DVBADA))
- End DoDot:2
- +15 ;**If more than one 2507 exists, user select
- IF +DVBACNT>1
- Begin DoDot:2
- +16 ;**Select a 2507 from ^TMP
- DO REQSEL^DVBCUTL5
- +17 IF (+Y'>0)!($DATA(DVBAOUT))
- SET DVBADA=""
- +18 ;**Y is selected 2507 val returned from ^DIR
- if +Y>0
- SET DVBASEL=+Y
- +19 ;**Find selected 2507 DA (Returned in DVBADA)
- if +Y>0
- DO FINDDA^DVBCUTL5
- End DoDot:2
- +20 KILL ^TMP("DVBC",$JOB)
- +21 ;**Write warning
- IF '$DATA(^DVB(396.3,+DVBADA,0))
- IF (+$$ENHNC^DVBCUTA4=1)
- Begin DoDot:2
- +22 SET DIR("A",1)="You have not selected a 2507 request to link the C&P appointment to."
- +23 SET DIR("A",2)="The appointment should be linked with the AMIE/C&P Appointment Link"
- +24 SET DIR("A",3)=" Management Option to ensure proper processing time calculation for this 2507"
- +25 SET DIR("A",4)=" in the event of a veteran cancellation."
- +26 SET DIR("A",5)=" "
- +27 SET DIR(0)="FAO^1:1"
- SET DIR("A")="Hit any key to continue."
- DO ^DIR
- KILL DIR,X,Y
- End DoDot:2
- +28 ;**If 2507, link appt
- IF $DATA(^DVB(396.3,+DVBADA,0))
- DO LINKAPPT^DVBCMKL2
- End DoDot:1
- +29 ;**Write Warning
- IF +DVBACNT'>0
- IF (+$$ENHNC^DVBCUTA4=1)
- Begin DoDot:1
- +30 SET DIR("A",1)="You have made a C&P appointment for a patient who has no pending 2507 request!"
- +31 SET DIR("A",2)=" "
- +32 SET DIR(0)="FAO^1:1"
- SET DIR("A")="Hit any key to continue."
- DO ^DIR
- KILL DIR,X,Y
- End DoDot:1
- +33 QUIT
- +34 ;
- KVARS ;** Kill variables used by scheduling protocol
- +1 KILL DVBAMORE,DVBALP,DVBAOUT,DVBADTOT,DVBASDPR,DVBASEL
- +2 KILL DVBAPNAM,DVBADA,DVBADFN,DVBASTAT,DVBADT,DVBAORD,DVBACNT
- +3 KILL ^TMP("DVBC",$JOB),Y,DVBAYANS,DVBALKRC,DVBARSAP
- +4 QUIT
- +5 ;
- CRTREC ;** Add a record to file 396.95 (Appt Tracking)
- +1 KILL DD,DO
- +2 SET DVBAADT=$PIECE(SDATA,U,3)
- +3 SET DIC="^DVB(396.95,"
- SET X=DVBAADT
- SET DIC(0)="LX"
- SET DLAYGO="396.95"
- +4 SET DIC("DR")=".02////^S X=DVBAADT;.03////^S X=DVBAADT;"
- +5 SET DIC("DR")=DIC("DR")_".04////^S X=0;.06////^S X=DVBADA;"
- +6 SET DIC("DR")=DIC("DR")_".07////^S X=1"
- +7 DO FILE^DICN
- KILL DIC,X,DLAYGO,DVBAADT
- +8 IF +$$ENHNC^DVBCUTA4=1
- Begin DoDot:1
- +9 NEW REQDT,SAVY
- +10 if $DATA(Y)
- SET SAVY=Y
- +11 ;**Set REQDT
- SET REQDT=$$GETDTE(DVBADA)
- +12 if $DATA(SAVY)
- SET Y=SAVY
- +13 SET DIR("A",1)=" "
- +14 SET DIR("A",2)="Adding new C&P appointment link for 2507 request dated "_REQDT_"."
- +15 SET DIR("A",3)=" "
- +16 SET DIR(0)="FAO^1:1"
- SET DIR("A")="Hit any key to continue."
- DO ^DIR
- KILL DIR,X,Y
- End DoDot:1
- +17 QUIT
- +18 ;
- GETDTE(REQDA) ;** Get the request dte
- +1 NEW REQDT
- +2 KILL Y
- SET Y=$PIECE(^DVB(396.3,REQDA,0),U,2)
- XECUTE ^DD("DD")
- +3 SET REQDT=Y
- +4 KILL Y
- +5 QUIT REQDT
- +6 ;
- RSCHAPT(LKDA,RSCHDT) ;** Update Appt record with reschedule data
- +1 SET DA=+LKDA
- SET DIE="^DVB(396.95,"
- SET DR=".03////^S X=RSCHDT;.07////1"
- +2 if (+$PIECE(^DVB(396.95,DA,0),U,4)=0&('$DATA(DVBAVTRQ)))
- SET DR=".02////^S X=RSCHDT;"_DR
- +3 if ($DATA(DVBAVTRQ))
- SET DR=".04////^S X=1;.05////^S X=RSCHDT;"_DR
- +4 DO ^DIE
- KILL DA,DIE,DR
- +5 IF +$$ENHNC^DVBCUTA4=1
- Begin DoDot:1
- +6 NEW REQDT,SAVY
- +7 if $DATA(Y)
- SET SAVY=Y
- +8 ;**Set REQDT
- SET REQDT=$$GETDTE($PIECE(^DVB(396.95,LKDA,0),U,6))
- +9 if $DATA(SAVY)
- SET Y=SAVY
- +10 SET DIR("A",1)=" "
- +11 SET DIR("A",2)="Adjusting C&P appointment link for 2507 request dated "_REQDT_"."
- +12 SET DIR("A",3)=" "
- +13 SET DIR(0)="FAO^1:1"
- SET DIR("A")="Hit any key to continue."
- DO ^DIR
- KILL DIR,X,Y
- End DoDot:1
- +14 QUIT