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

DVBCUTA1.m

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