- 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 Feb 18, 2025@23:15:33 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