DVBCUTA1 ;ALB/GTS-AMIE C&P UTILITY ROUTINE A-1 ; 11/9/94 11:15 AM
;;2.7;AMIE;;Apr 10, 1995
;
;** Version Changes
; 2.7 - New routine (Enhc 15)
;
INSXM ;**Update Insuf exam info
;
;** Variable Descriptions
; DVBAXMDA - 396.4 IEN - new Exam Rec
; DVBAXMTP - 396.6 IEN - new exam
; DVBAPROV - Provider on insufficiently completed exam
; DVBAORXM - 396.4 IEN - insufficiently completed exam
; DVBACMND - Local var containing Mumps code
; X DVBACMND returns DVBAORXM
; DVBCADEX - Indicates exam being added to 2507
;
I '$D(OUT)&($P(^DVB(396.3,REQDA,0),"^",10)="E") DO
.S TVAR(1,0)="0,0,0,2,0^Enter the following information for the "_EXMNM
.S TVAR(2,0)="0,0,0,1:1,0^ exam being returned as insufficient."
.D WR^DVBAUTL4("TVAR")
.K TVAR
.N DVBAXMDA,REASON
.S DVBAXMDA=+Y
.K DIC,Y,DA
.S REASON=+$$INRSLK^DVBCUTA3
.S:+REASON'>0 DTOUT=""
.I +REASON>0 DO
..K DIE,Y,DA,DR
..S DIE="^DVB(396.4,",DR=".11////^S X=REASON;80;S:+$P(^DVB(396.3,REQDA,5),""^"",1)>0 Y="""";.12"
..S DA=DVBAXMDA S DIE("NO^")="" D ^DIE K DIE,DA,DR W !!
.I '$D(DTOUT),(+$P(^DVB(396.3,REQDA,5),"^",1)>0) DO
..K DIE,Y,DR,DA ;**2507 Linked
..N DVBAXMTP,DVBAPROV,DVBAORXM,DVBACMND ;**S/W update Original Provider
..S DVBAXMTP=$P(^TMP($J,"NEW",EXMNM),U,1),DVBAORXM="",DVBAPROV=""
..S DVBACMND="S DVBAORXM=$O(^DVB(396.4,""ARQ"_DVBAINDA_""","_DVBAXMTP_",DVBAORXM))"
..N XREF S XREF="ARQ"_DVBAINDA
..I $D(^DVB(396.4,XREF,DVBAXMTP)) X DVBACMND ;**Return insuff exam IEN
..S:+DVBAORXM>0 DVBAPROV=$P(^DVB(396.4,DVBAORXM,0),U,7)
..I '$D(DVBCADEX)&(DVBAPROV="") DO
...S DVBAPROV="Unknown" ;**Bad 'ARQ' X-Ref
..K DVBADMNM
..I +DVBAORXM>0 DO
...I $D(^DVB(396.4,DVBAORXM,"TRAN")),(+$P(^DVB(396.4,DVBAORXM,"TRAN"),U,3)>0) DO
....S DVBADMNM=$P(^DIC(4.2,+$P(^DVB(396.4,DVBAORXM,"TRAN"),U,3),0),U,1)
....S DVBADMNM=$P(DVBADMNM,".",1)
..S:$D(DVBADMNM) DVBAPROV=DVBAPROV_" at "_DVBADMNM
..I $D(DVBCADEX)&(+DVBAORXM'>0) DO
...S DIR(0)="FAO^1:30"
...S DIR("A")="ORIGINAL PROVIDER: "
...S DIR("?",1)="Enter the Original Provider who performed the examination,"
...S DIR("?",2)="if the exam was performed on the original 2507 request."
...S DIR("?")="Include the facility name if the exam was performed at another site." D ^DIR S DVBAPROV=X K DIR,X,Y
..S DIE="^DVB(396.4,",DR=".12////^S X=DVBAPROV",DA=DVBAXMDA
..D ^DIE K DVBADMNM
Q
;
RPTTYPE() ;** Report type - Detailed/Summary
;**RPTTYPE requires an entry. Up-arrow exit allowed.
;** All variables KILLed, EXCEPT DTOUT,DUOUT when user times
;** or Up-Arrows out. DTOUT,DUOUT KILLed by calling rtn.
N TYPE
S DIR(0)="SO^D:Detailed;S:Summary"
S DIR("A",1)=" "
S DIR("A")="Report Type"
D ^DIR
S TYPE=Y
K X,Y,DIR
Q TYPE
;
INSFTME(CURIEN) ;** Calc Insuff 2507 total process time
;** Variables
;** CURIEN - 396.3 IEN for 2507 in process
;** PROCTM - Processing time running total
;** LPQUIT - Exit loop indicator
;
N PROCTM,LPQUIT
S PROCTM=+$$PROCDAY^DVBCUTL2(CURIEN)
F Q:$D(LPQUIT) DO
.S:'$D(^DVB(396.3,CURIEN,5)) LPQUIT=""
.I $D(^DVB(396.3,CURIEN,5)) DO
..I +$P(^DVB(396.3,CURIEN,5),U,1)'>0 DO
...S PROCTM=PROCTM+$P(^DVB(396.3,CURIEN,5),U,2)
...S LPQUIT=""
..I +$P(^DVB(396.3,CURIEN,5),U,1)>0 DO
...S CURIEN=+$P(^DVB(396.3,CURIEN,5),U,1)
...S PROCTM=PROCTM+$$PROCDAY^DVBCUTL2(CURIEN)
Q PROCTM
;
LINKDISP ;** Display Appt Links
W @IOF
N DVBAMORE
W !,"Examination Appointment Links"
W !!," Which Current Appt is "_$P(DVBAAPT,U,1)_" a reschedule of?",!
W !,?4,"Initial Appt",?23,"Clock Stop Appt",?42,"Current Appt",?61,"Clinic"
S ARYDA=""
F ARYDA=1:1 Q:'$D(TMP("DVBC LINK",ARYDA)) DO
.S SELDA=""
.S SELDA=$O(TMP("DVBC LINK",ARYDA,SELDA))
.W !,?1,ARYDA,?4,$P(TMP("DVBC LINK",ARYDA,SELDA),U,1)
.W ?23,$P(TMP("DVBC LINK",ARYDA,SELDA),U,2),?42,$P(TMP("DVBC LINK",ARYDA,SELDA),U,3)
.W ?61,$E($P(TMP("DVBC LINK",ARYDA,SELDA),U,4),1,18)
.S DVBAMORE=$O(TMP("DVBC LINK",ARYDA))
.I +DVBAMORE'>0 D SELLNK W !
.I +DVBAMORE>0,(ARYDA#5=0) D SELLNK W !
S SELDA=""
I $D(Y) S SELDA=$O(TMP("DVBC LINK",Y,SELDA))
K TMP("DVBC LINK")
Q
;
SELLNK ;** Select link to modify
W !
S DIR("A",1)="ENTER '^' TO STOP OR"
S DIR("A")="CHOOSE 1-"_ARYDA_": "
S DIR(0)="NOA^1:"_ARYDA_"^I X["".""!('$D(TMP(""DVBC LINK"",+Y))) K X"
S DIR("?",1)="Select a link by entering its associated number."
S DIR("?",2)=" 'Initial Appt' is the first appointment made to complete the exam."
S DIR("?",3)=" 'Clock Stop Appt' is the date the processing clock will be stopped for the"
S DIR("?",4)=" series of linked appointments, if the veteran reschedules or no shows."
S DIR("?",5)=" 'Current Appt' is the appointment the link shows as currently scheduled"
S DIR("?",6)=" to complete the examination."
S DIR("?")="Select from the numbers listed."
D ^DIR
I $D(DTOUT)!($D(DUOUT)) S ARYDA=9999
S:+Y>0 ARYDA=9999
I +Y'>0 K Y
K DIR,DTOUT,DUOUT
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBCUTA1 4983 printed Dec 13, 2024@01:49:06 Page 2
DVBCUTA1 ;ALB/GTS-AMIE C&P UTILITY ROUTINE A-1 ; 11/9/94 11:15 AM
+1 ;;2.7;AMIE;;Apr 10, 1995
+2 ;
+3 ;** Version Changes
+4 ; 2.7 - New routine (Enhc 15)
+5 ;
INSXM ;**Update Insuf exam info
+1 ;
+2 ;** Variable Descriptions
+3 ; DVBAXMDA - 396.4 IEN - new Exam Rec
+4 ; DVBAXMTP - 396.6 IEN - new exam
+5 ; DVBAPROV - Provider on insufficiently completed exam
+6 ; DVBAORXM - 396.4 IEN - insufficiently completed exam
+7 ; DVBACMND - Local var containing Mumps code
+8 ; X DVBACMND returns DVBAORXM
+9 ; DVBCADEX - Indicates exam being added to 2507
+10 ;
+11 IF '$DATA(OUT)&($PIECE(^DVB(396.3,REQDA,0),"^",10)="E")
Begin DoDot:1
+12 SET TVAR(1,0)="0,0,0,2,0^Enter the following information for the "_EXMNM
+13 SET TVAR(2,0)="0,0,0,1:1,0^ exam being returned as insufficient."
+14 DO WR^DVBAUTL4("TVAR")
+15 KILL TVAR
+16 NEW DVBAXMDA,REASON
+17 SET DVBAXMDA=+Y
+18 KILL DIC,Y,DA
+19 SET REASON=+$$INRSLK^DVBCUTA3
+20 if +REASON'>0
SET DTOUT=""
+21 IF +REASON>0
Begin DoDot:2
+22 KILL DIE,Y,DA,DR
+23 SET DIE="^DVB(396.4,"
SET DR=".11////^S X=REASON;80;S:+$P(^DVB(396.3,REQDA,5),""^"",1)>0 Y="""";.12"
+24 SET DA=DVBAXMDA
SET DIE("NO^")=""
DO ^DIE
KILL DIE,DA,DR
WRITE !!
End DoDot:2
+25 IF '$DATA(DTOUT)
IF (+$PIECE(^DVB(396.3,REQDA,5),"^",1)>0)
Begin DoDot:2
+26 ;**2507 Linked
KILL DIE,Y,DR,DA
+27 ;**S/W update Original Provider
NEW DVBAXMTP,DVBAPROV,DVBAORXM,DVBACMND
+28 SET DVBAXMTP=$PIECE(^TMP($JOB,"NEW",EXMNM),U,1)
SET DVBAORXM=""
SET DVBAPROV=""
+29 SET DVBACMND="S DVBAORXM=$O(^DVB(396.4,""ARQ"_DVBAINDA_""","_DVBAXMTP_",DVBAORXM))"
+30 NEW XREF
SET XREF="ARQ"_DVBAINDA
+31 ;**Return insuff exam IEN
IF $DATA(^DVB(396.4,XREF,DVBAXMTP))
XECUTE DVBACMND
+32 if +DVBAORXM>0
SET DVBAPROV=$PIECE(^DVB(396.4,DVBAORXM,0),U,7)
+33 IF '$DATA(DVBCADEX)&(DVBAPROV="")
Begin DoDot:3
+34 ;**Bad 'ARQ' X-Ref
SET DVBAPROV="Unknown"
End DoDot:3
+35 KILL DVBADMNM
+36 IF +DVBAORXM>0
Begin DoDot:3
+37 IF $DATA(^DVB(396.4,DVBAORXM,"TRAN"))
IF (+$PIECE(^DVB(396.4,DVBAORXM,"TRAN"),U,3)>0)
Begin DoDot:4
+38 SET DVBADMNM=$PIECE(^DIC(4.2,+$PIECE(^DVB(396.4,DVBAORXM,"TRAN"),U,3),0),U,1)
+39 SET DVBADMNM=$PIECE(DVBADMNM,".",1)
End DoDot:4
End DoDot:3
+40 if $DATA(DVBADMNM)
SET DVBAPROV=DVBAPROV_" at "_DVBADMNM
+41 IF $DATA(DVBCADEX)&(+DVBAORXM'>0)
Begin DoDot:3
+42 SET DIR(0)="FAO^1:30"
+43 SET DIR("A")="ORIGINAL PROVIDER: "
+44 SET DIR("?",1)="Enter the Original Provider who performed the examination,"
+45 SET DIR("?",2)="if the exam was performed on the original 2507 request."
+46 SET DIR("?")="Include the facility name if the exam was performed at another site."
DO ^DIR
SET DVBAPROV=X
KILL DIR,X,Y
End DoDot:3
+47 SET DIE="^DVB(396.4,"
SET DR=".12////^S X=DVBAPROV"
SET DA=DVBAXMDA
+48 DO ^DIE
KILL DVBADMNM
End DoDot:2
End DoDot:1
+49 QUIT
+50 ;
RPTTYPE() ;** Report type - Detailed/Summary
+1 ;**RPTTYPE requires an entry. Up-arrow exit allowed.
+2 ;** All variables KILLed, EXCEPT DTOUT,DUOUT when user times
+3 ;** or Up-Arrows out. DTOUT,DUOUT KILLed by calling rtn.
+4 NEW TYPE
+5 SET DIR(0)="SO^D:Detailed;S:Summary"
+6 SET DIR("A",1)=" "
+7 SET DIR("A")="Report Type"
+8 DO ^DIR
+9 SET TYPE=Y
+10 KILL X,Y,DIR
+11 QUIT TYPE
+12 ;
INSFTME(CURIEN) ;** Calc Insuff 2507 total process time
+1 ;** Variables
+2 ;** CURIEN - 396.3 IEN for 2507 in process
+3 ;** PROCTM - Processing time running total
+4 ;** LPQUIT - Exit loop indicator
+5 ;
+6 NEW PROCTM,LPQUIT
+7 SET PROCTM=+$$PROCDAY^DVBCUTL2(CURIEN)
+8 FOR
if $DATA(LPQUIT)
QUIT
Begin DoDot:1
+9 if '$DATA(^DVB(396.3,CURIEN,5))
SET LPQUIT=""
+10 IF $DATA(^DVB(396.3,CURIEN,5))
Begin DoDot:2
+11 IF +$PIECE(^DVB(396.3,CURIEN,5),U,1)'>0
Begin DoDot:3
+12 SET PROCTM=PROCTM+$PIECE(^DVB(396.3,CURIEN,5),U,2)
+13 SET LPQUIT=""
End DoDot:3
+14 IF +$PIECE(^DVB(396.3,CURIEN,5),U,1)>0
Begin DoDot:3
+15 SET CURIEN=+$PIECE(^DVB(396.3,CURIEN,5),U,1)
+16 SET PROCTM=PROCTM+$$PROCDAY^DVBCUTL2(CURIEN)
End DoDot:3
End DoDot:2
End DoDot:1
+17 QUIT PROCTM
+18 ;
LINKDISP ;** Display Appt Links
+1 WRITE @IOF
+2 NEW DVBAMORE
+3 WRITE !,"Examination Appointment Links"
+4 WRITE !!," Which Current Appt is "_$PIECE(DVBAAPT,U,1)_" a reschedule of?",!
+5 WRITE !,?4,"Initial Appt",?23,"Clock Stop Appt",?42,"Current Appt",?61,"Clinic"
+6 SET ARYDA=""
+7 FOR ARYDA=1:1
if '$DATA(TMP("DVBC LINK",ARYDA))
QUIT
Begin DoDot:1
+8 SET SELDA=""
+9 SET SELDA=$ORDER(TMP("DVBC LINK",ARYDA,SELDA))
+10 WRITE !,?1,ARYDA,?4,$PIECE(TMP("DVBC LINK",ARYDA,SELDA),U,1)
+11 WRITE ?23,$PIECE(TMP("DVBC LINK",ARYDA,SELDA),U,2),?42,$PIECE(TMP("DVBC LINK",ARYDA,SELDA),U,3)
+12 WRITE ?61,$EXTRACT($PIECE(TMP("DVBC LINK",ARYDA,SELDA),U,4),1,18)
+13 SET DVBAMORE=$ORDER(TMP("DVBC LINK",ARYDA))
+14 IF +DVBAMORE'>0
DO SELLNK
WRITE !
+15 IF +DVBAMORE>0
IF (ARYDA#5=0)
DO SELLNK
WRITE !
End DoDot:1
+16 SET SELDA=""
+17 IF $DATA(Y)
SET SELDA=$ORDER(TMP("DVBC LINK",Y,SELDA))
+18 KILL TMP("DVBC LINK")
+19 QUIT
+20 ;
SELLNK ;** Select link to modify
+1 WRITE !
+2 SET DIR("A",1)="ENTER '^' TO STOP OR"
+3 SET DIR("A")="CHOOSE 1-"_ARYDA_": "
+4 SET DIR(0)="NOA^1:"_ARYDA_"^I X["".""!('$D(TMP(""DVBC LINK"",+Y))) K X"
+5 SET DIR("?",1)="Select a link by entering its associated number."
+6 SET DIR("?",2)=" 'Initial Appt' is the first appointment made to complete the exam."
+7 SET DIR("?",3)=" 'Clock Stop Appt' is the date the processing clock will be stopped for the"
+8 SET DIR("?",4)=" series of linked appointments, if the veteran reschedules or no shows."
+9 SET DIR("?",5)=" 'Current Appt' is the appointment the link shows as currently scheduled"
+10 SET DIR("?",6)=" to complete the examination."
+11 SET DIR("?")="Select from the numbers listed."
+12 DO ^DIR
+13 IF $DATA(DTOUT)!($DATA(DUOUT))
SET ARYDA=9999
+14 if +Y>0
SET ARYDA=9999
+15 IF +Y'>0
KILL Y
+16 KILL DIR,DTOUT,DUOUT
+17 QUIT
