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

DVBCUTA3.m

Go to the documentation of this file.
  1. DVBCUTA3 ;ALB/GTS-AMIE C&P UTILITY ROUTINE A-3 ; 2/10/95 11:15 AM
  1. ;;2.7;AMIE;;Apr 10, 1995
  1. ;
  1. ;** Version Changes
  1. ; 2.7 - New routine (Enhc 15)
  1. ;
  1. INRSLK() ;** Lookup insufficient reason
  1. N REASVAR,DVBAOUT,REASIN
  1. S REASVAR=-1,REASIN=""
  1. K DTOUT,DUOUT
  1. F Q:($D(DTOUT)!(+REASVAR>0)!($D(DVBAOUT))) DO
  1. .I '$D(DVBAXMDA) DO
  1. ..R !,"INSUFFICIENT REASON: ",REASIN:DTIME
  1. ..S:'$T DVBAOUT=""
  1. .I $D(DVBAXMDA),(+DVBAXMDA'>0) DO
  1. ..R !,"INSUFFICIENT REASON: ",REASIN:DTIME
  1. ..S:'$T DVBAOUT=""
  1. .I $D(DVBAXMDA),(+DVBAXMDA>0&(+$P(^DVB(396.4,DVBAXMDA,0),U,11)'>0)) DO
  1. ..R !,"INSUFFICIENT REASON: ",REASIN:DTIME
  1. ..S:'$T DVBAOUT=""
  1. .I $D(DVBAXMDA),(+DVBAXMDA>0&(+$P(^DVB(396.4,DVBAXMDA,0),U,11)>0)) DO
  1. ..W !,"INSUFFICIENT REASON: "
  1. ..S:'$T DVBAOUT=""
  1. ..I +$P(^DVB(396.4,DVBAXMDA,0),U,11)>0 DO
  1. ...W $P(^DVB(396.94,$P(^DVB(396.4,DVBAXMDA,0),U,11),0),U,1)_"//"
  1. ..R REASIN:DTIME
  1. ..S:'$T DVBAOUT=""
  1. ..I '$D(DVBAOUT),(REASIN="") S REASIN=$P(^DVB(396.94,$P(^DVB(396.4,DVBAXMDA,0),U,11),0),U,1)
  1. .I REASIN="^" DO
  1. ..S TVAR(1,0)="0,0,0,0,0^NOT ALLOWED"
  1. ..D WR^DVBAUTL4("TVAR")
  1. ..K TVAR
  1. .I '$D(DVBAOUT),(REASIN="") S REASIN="^"
  1. .I REASIN="^" DO
  1. ..S TVAR(1,0)="0,0,0,0,0^??"
  1. ..S TVAR(2,0)="0,5,0,1,0^Enter the insufficient reason this exam is being returned."
  1. ..S TVAR(3,0)="0,1,0,1,0^ANSWER WITH 2507 INSUFFICIENT REASONS INSUFFICIENT CODE"
  1. ..D WR^DVBAUTL4("TVAR")
  1. ..K TVAR
  1. .I REASIN="?" DO
  1. ..K DIR S DIR(0)="YAO"
  1. ..S DIR("A",1)=" Enter the insufficient reason this exam is being returned. "
  1. ..S DIR("A",2)=" ANSWER WITH 2507 INSUFFICIENT REASONS INSUFFICIENT CODE"
  1. ..S DIR("A")=" DO YOU WANT THE ENTIRE 13-ENTRY 2507 INSUFFICIENT REASONS LIST? "
  1. ..D ^DIR
  1. ..D:+Y=1 RESHELP
  1. ..K Y,DIR
  1. .I REASIN["??" DO
  1. ..S TVAR(1,0)="0,0,0,1,0^This field contains a pointer to the Insufficient Reason file (396.94)."
  1. ..D WR^DVBAUTL4("TVAR")
  1. ..K TVAR
  1. ..D RESHELP
  1. .I REASIN'="^",(REASIN'["?") DO
  1. ..S DIC="^DVB(396.94,",X=REASIN,DIC(0)="MQE"
  1. ..D ^DIC
  1. ..S REASVAR=Y
  1. ..K DIC,X,Y
  1. S:($D(DTOUT)!($D(DVBAOUT))) REASVAR=-1
  1. Q REASVAR
  1. ;
  1. RESHELP ;** Help for insufficient reasons
  1. N LPVAR
  1. S TVAR(1,0)="0,0,0,2,0^CHOOSE FROM:"
  1. D WR^DVBAUTL4("TVAR")
  1. K TVAR
  1. F LPVAR=0:0 S LPVAR=$O(^DVB(396.94,LPVAR)) Q:+LPVAR=0 DO
  1. .S TVAR(1,0)="0,3:0,0,1,0^"_$P(^DVB(396.94,LPVAR,0),U,1)
  1. .D WR^DVBAUTL4("TVAR")
  1. .K TVAR
  1. W !
  1. Q
  1. ;
  1. LNKLIST ;** List links for user
  1. I '$D(TMP("DVBC LINK")) DO
  1. .S TVAR(1,0)="0,0,0,1,0^There are no links to this 2507 request."
  1. .D WR^DVBAUTL4("TVAR")
  1. .K TVAR
  1. .D CONTMES^DVBCUTL4
  1. I $D(TMP("DVBC LINK")) DO
  1. .N DVBAMORE
  1. .W !,?2,"Current Appointment Links",!
  1. .W !,?1,"Initial Appt",?21,"Clock Stop Appt",?41,"Current Appt",?61,"Clinic"
  1. .S ARYDA=""
  1. .N GETOUT
  1. .F ARYDA=1:1 Q:('$D(TMP("DVBC LINK",ARYDA))!($D(GETOUT))) DO
  1. ..S SELDA=""
  1. ..S SELDA=$O(TMP("DVBC LINK",ARYDA,SELDA))
  1. ..W !,?1,$P(TMP("DVBC LINK",ARYDA,SELDA),U,1)
  1. ..W ?21,$P(TMP("DVBC LINK",ARYDA,SELDA),U,2),?41,$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)!(+DVBAMORE>0&(ARYDA#5=0)) DO
  1. ...K DIR
  1. ...S DIR(0)="F,O^^",DIR("A")="Enter [Return] to continue or ""^"" to exit"
  1. ...K GETOUT D ^DIR S:$D(DTOUT)!($D(DUOUT)) GETOUT=1
  1. ...I '$D(GETOUT) W ! K DIR,DIRUT,X
  1. .K TMP("DVBC LINK"),ARYDA,SELDA,DIR,X
  1. Q
  1. ;
  1. LNKARY(REQDA,DVBADFN) ;** Set up the link array (In TMP local)
  1. N LKDA,ARYDA
  1. S LKDA="",ARYDA=0
  1. F S LKDA=$O(^DVB(396.95,"AR",REQDA,LKDA)) Q:+LKDA=0 DO
  1. .S ARYDA=ARYDA+1
  1. .S Y=$P(^DVB(396.95,LKDA,0),U,1) X ^DD("DD")
  1. .S TMP("DVBC LINK",ARYDA,LKDA)=Y K Y
  1. .S Y=$P(^DVB(396.95,LKDA,0),U,2) X ^DD("DD")
  1. .S TMP("DVBC LINK",ARYDA,LKDA)=TMP("DVBC LINK",ARYDA,LKDA)_"^"_Y K Y
  1. .S Y=$P(^DVB(396.95,LKDA,0),U,3) X ^DD("DD")
  1. .S TMP("DVBC LINK",ARYDA,LKDA)=TMP("DVBC LINK",ARYDA,LKDA)_"^"_Y K Y
  1. .S DA=DVBADFN,DA(2.98)=$P(^DVB(396.95,LKDA,0),U,3),DR="1900",DR(2.98)=".01",DIC=2
  1. .S DIQ="DVBACLIN" K ^UTILITY("DIQ",$J)
  1. .D EN^DIQ1 K ^UTILITY("DIQ",$J)
  1. .S TMP("DVBC LINK",ARYDA,LKDA)=TMP("DVBC LINK",ARYDA,LKDA)_"^"_DVBACLIN(2.98,$P(^DVB(396.95,LKDA,0),U,3),.01)
  1. .K DVBACLIN
  1. Q