DVBCUTA3 ;ALB/GTS-AMIE C&P UTILITY ROUTINE A-3 ; 2/10/95 11:15 AM
;;2.7;AMIE;;Apr 10, 1995
;
;** Version Changes
; 2.7 - New routine (Enhc 15)
;
INRSLK() ;** Lookup insufficient reason
N REASVAR,DVBAOUT,REASIN
S REASVAR=-1,REASIN=""
K DTOUT,DUOUT
F Q:($D(DTOUT)!(+REASVAR>0)!($D(DVBAOUT))) DO
.I '$D(DVBAXMDA) DO
..R !,"INSUFFICIENT REASON: ",REASIN:DTIME
..S:'$T DVBAOUT=""
.I $D(DVBAXMDA),(+DVBAXMDA'>0) DO
..R !,"INSUFFICIENT REASON: ",REASIN:DTIME
..S:'$T DVBAOUT=""
.I $D(DVBAXMDA),(+DVBAXMDA>0&(+$P(^DVB(396.4,DVBAXMDA,0),U,11)'>0)) DO
..R !,"INSUFFICIENT REASON: ",REASIN:DTIME
..S:'$T DVBAOUT=""
.I $D(DVBAXMDA),(+DVBAXMDA>0&(+$P(^DVB(396.4,DVBAXMDA,0),U,11)>0)) DO
..W !,"INSUFFICIENT REASON: "
..S:'$T DVBAOUT=""
..I +$P(^DVB(396.4,DVBAXMDA,0),U,11)>0 DO
...W $P(^DVB(396.94,$P(^DVB(396.4,DVBAXMDA,0),U,11),0),U,1)_"//"
..R REASIN:DTIME
..S:'$T DVBAOUT=""
..I '$D(DVBAOUT),(REASIN="") S REASIN=$P(^DVB(396.94,$P(^DVB(396.4,DVBAXMDA,0),U,11),0),U,1)
.I REASIN="^" DO
..S TVAR(1,0)="0,0,0,0,0^NOT ALLOWED"
..D WR^DVBAUTL4("TVAR")
..K TVAR
.I '$D(DVBAOUT),(REASIN="") S REASIN="^"
.I REASIN="^" DO
..S TVAR(1,0)="0,0,0,0,0^??"
..S TVAR(2,0)="0,5,0,1,0^Enter the insufficient reason this exam is being returned."
..S TVAR(3,0)="0,1,0,1,0^ANSWER WITH 2507 INSUFFICIENT REASONS INSUFFICIENT CODE"
..D WR^DVBAUTL4("TVAR")
..K TVAR
.I REASIN="?" DO
..K DIR S DIR(0)="YAO"
..S DIR("A",1)=" Enter the insufficient reason this exam is being returned. "
..S DIR("A",2)=" ANSWER WITH 2507 INSUFFICIENT REASONS INSUFFICIENT CODE"
..S DIR("A")=" DO YOU WANT THE ENTIRE 13-ENTRY 2507 INSUFFICIENT REASONS LIST? "
..D ^DIR
..D:+Y=1 RESHELP
..K Y,DIR
.I REASIN["??" DO
..S TVAR(1,0)="0,0,0,1,0^This field contains a pointer to the Insufficient Reason file (396.94)."
..D WR^DVBAUTL4("TVAR")
..K TVAR
..D RESHELP
.I REASIN'="^",(REASIN'["?") DO
..S DIC="^DVB(396.94,",X=REASIN,DIC(0)="MQE"
..D ^DIC
..S REASVAR=Y
..K DIC,X,Y
S:($D(DTOUT)!($D(DVBAOUT))) REASVAR=-1
Q REASVAR
;
RESHELP ;** Help for insufficient reasons
N LPVAR
S TVAR(1,0)="0,0,0,2,0^CHOOSE FROM:"
D WR^DVBAUTL4("TVAR")
K TVAR
F LPVAR=0:0 S LPVAR=$O(^DVB(396.94,LPVAR)) Q:+LPVAR=0 DO
.S TVAR(1,0)="0,3:0,0,1,0^"_$P(^DVB(396.94,LPVAR,0),U,1)
.D WR^DVBAUTL4("TVAR")
.K TVAR
W !
Q
;
LNKLIST ;** List links for user
I '$D(TMP("DVBC LINK")) DO
.S TVAR(1,0)="0,0,0,1,0^There are no links to this 2507 request."
.D WR^DVBAUTL4("TVAR")
.K TVAR
.D CONTMES^DVBCUTL4
I $D(TMP("DVBC LINK")) DO
.N DVBAMORE
.W !,?2,"Current Appointment Links",!
.W !,?1,"Initial Appt",?21,"Clock Stop Appt",?41,"Current Appt",?61,"Clinic"
.S ARYDA=""
.N GETOUT
.F ARYDA=1:1 Q:('$D(TMP("DVBC LINK",ARYDA))!($D(GETOUT))) DO
..S SELDA=""
..S SELDA=$O(TMP("DVBC LINK",ARYDA,SELDA))
..W !,?1,$P(TMP("DVBC LINK",ARYDA,SELDA),U,1)
..W ?21,$P(TMP("DVBC LINK",ARYDA,SELDA),U,2),?41,$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)!(+DVBAMORE>0&(ARYDA#5=0)) DO
...K DIR
...S DIR(0)="F,O^^",DIR("A")="Enter [Return] to continue or ""^"" to exit"
...K GETOUT D ^DIR S:$D(DTOUT)!($D(DUOUT)) GETOUT=1
...I '$D(GETOUT) W ! K DIR,DIRUT,X
.K TMP("DVBC LINK"),ARYDA,SELDA,DIR,X
Q
;
LNKARY(REQDA,DVBADFN) ;** Set up the link array (In TMP local)
N LKDA,ARYDA
S LKDA="",ARYDA=0
F S LKDA=$O(^DVB(396.95,"AR",REQDA,LKDA)) Q:+LKDA=0 DO
.S ARYDA=ARYDA+1
.S Y=$P(^DVB(396.95,LKDA,0),U,1) X ^DD("DD")
.S TMP("DVBC LINK",ARYDA,LKDA)=Y K Y
.S Y=$P(^DVB(396.95,LKDA,0),U,2) X ^DD("DD")
.S TMP("DVBC LINK",ARYDA,LKDA)=TMP("DVBC LINK",ARYDA,LKDA)_"^"_Y K Y
.S Y=$P(^DVB(396.95,LKDA,0),U,3) X ^DD("DD")
.S TMP("DVBC LINK",ARYDA,LKDA)=TMP("DVBC LINK",ARYDA,LKDA)_"^"_Y K Y
.S DA=DVBADFN,DA(2.98)=$P(^DVB(396.95,LKDA,0),U,3),DR="1900",DR(2.98)=".01",DIC=2
.S DIQ="DVBACLIN" K ^UTILITY("DIQ",$J)
.D EN^DIQ1 K ^UTILITY("DIQ",$J)
.S TMP("DVBC LINK",ARYDA,LKDA)=TMP("DVBC LINK",ARYDA,LKDA)_"^"_DVBACLIN(2.98,$P(^DVB(396.95,LKDA,0),U,3),.01)
.K DVBACLIN
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBCUTA3 4185 printed Apr 09, 2024@20:58:22 Page 2
DVBCUTA3 ;ALB/GTS-AMIE C&P UTILITY ROUTINE A-3 ; 2/10/95 11:15 AM
+1 ;;2.7;AMIE;;Apr 10, 1995
+2 ;
+3 ;** Version Changes
+4 ; 2.7 - New routine (Enhc 15)
+5 ;
INRSLK() ;** Lookup insufficient reason
+1 NEW REASVAR,DVBAOUT,REASIN
+2 SET REASVAR=-1
SET REASIN=""
+3 KILL DTOUT,DUOUT
+4 FOR
if ($DATA(DTOUT)!(+REASVAR>0)!($DATA(DVBAOUT)))
QUIT
Begin DoDot:1
+5 IF '$DATA(DVBAXMDA)
Begin DoDot:2
+6 READ !,"INSUFFICIENT REASON: ",REASIN:DTIME
+7 if '$TEST
SET DVBAOUT=""
End DoDot:2
+8 IF $DATA(DVBAXMDA)
IF (+DVBAXMDA'>0)
Begin DoDot:2
+9 READ !,"INSUFFICIENT REASON: ",REASIN:DTIME
+10 if '$TEST
SET DVBAOUT=""
End DoDot:2
+11 IF $DATA(DVBAXMDA)
IF (+DVBAXMDA>0&(+$PIECE(^DVB(396.4,DVBAXMDA,0),U,11)'>0))
Begin DoDot:2
+12 READ !,"INSUFFICIENT REASON: ",REASIN:DTIME
+13 if '$TEST
SET DVBAOUT=""
End DoDot:2
+14 IF $DATA(DVBAXMDA)
IF (+DVBAXMDA>0&(+$PIECE(^DVB(396.4,DVBAXMDA,0),U,11)>0))
Begin DoDot:2
+15 WRITE !,"INSUFFICIENT REASON: "
+16 if '$TEST
SET DVBAOUT=""
+17 IF +$PIECE(^DVB(396.4,DVBAXMDA,0),U,11)>0
Begin DoDot:3
+18 WRITE $PIECE(^DVB(396.94,$PIECE(^DVB(396.4,DVBAXMDA,0),U,11),0),U,1)_"//"
End DoDot:3
+19 READ REASIN:DTIME
+20 if '$TEST
SET DVBAOUT=""
+21 IF '$DATA(DVBAOUT)
IF (REASIN="")
SET REASIN=$PIECE(^DVB(396.94,$PIECE(^DVB(396.4,DVBAXMDA,0),U,11),0),U,1)
End DoDot:2
+22 IF REASIN="^"
Begin DoDot:2
+23 SET TVAR(1,0)="0,0,0,0,0^NOT ALLOWED"
+24 DO WR^DVBAUTL4("TVAR")
+25 KILL TVAR
End DoDot:2
+26 IF '$DATA(DVBAOUT)
IF (REASIN="")
SET REASIN="^"
+27 IF REASIN="^"
Begin DoDot:2
+28 SET TVAR(1,0)="0,0,0,0,0^??"
+29 SET TVAR(2,0)="0,5,0,1,0^Enter the insufficient reason this exam is being returned."
+30 SET TVAR(3,0)="0,1,0,1,0^ANSWER WITH 2507 INSUFFICIENT REASONS INSUFFICIENT CODE"
+31 DO WR^DVBAUTL4("TVAR")
+32 KILL TVAR
End DoDot:2
+33 IF REASIN="?"
Begin DoDot:2
+34 KILL DIR
SET DIR(0)="YAO"
+35 SET DIR("A",1)=" Enter the insufficient reason this exam is being returned. "
+36 SET DIR("A",2)=" ANSWER WITH 2507 INSUFFICIENT REASONS INSUFFICIENT CODE"
+37 SET DIR("A")=" DO YOU WANT THE ENTIRE 13-ENTRY 2507 INSUFFICIENT REASONS LIST? "
+38 DO ^DIR
+39 if +Y=1
DO RESHELP
+40 KILL Y,DIR
End DoDot:2
+41 IF REASIN["??"
Begin DoDot:2
+42 SET TVAR(1,0)="0,0,0,1,0^This field contains a pointer to the Insufficient Reason file (396.94)."
+43 DO WR^DVBAUTL4("TVAR")
+44 KILL TVAR
+45 DO RESHELP
End DoDot:2
+46 IF REASIN'="^"
IF (REASIN'["?")
Begin DoDot:2
+47 SET DIC="^DVB(396.94,"
SET X=REASIN
SET DIC(0)="MQE"
+48 DO ^DIC
+49 SET REASVAR=Y
+50 KILL DIC,X,Y
End DoDot:2
End DoDot:1
+51 if ($DATA(DTOUT)!($DATA(DVBAOUT)))
SET REASVAR=-1
+52 QUIT REASVAR
+53 ;
RESHELP ;** Help for insufficient reasons
+1 NEW LPVAR
+2 SET TVAR(1,0)="0,0,0,2,0^CHOOSE FROM:"
+3 DO WR^DVBAUTL4("TVAR")
+4 KILL TVAR
+5 FOR LPVAR=0:0
SET LPVAR=$ORDER(^DVB(396.94,LPVAR))
if +LPVAR=0
QUIT
Begin DoDot:1
+6 SET TVAR(1,0)="0,3:0,0,1,0^"_$PIECE(^DVB(396.94,LPVAR,0),U,1)
+7 DO WR^DVBAUTL4("TVAR")
+8 KILL TVAR
End DoDot:1
+9 WRITE !
+10 QUIT
+11 ;
LNKLIST ;** List links for user
+1 IF '$DATA(TMP("DVBC LINK"))
Begin DoDot:1
+2 SET TVAR(1,0)="0,0,0,1,0^There are no links to this 2507 request."
+3 DO WR^DVBAUTL4("TVAR")
+4 KILL TVAR
+5 DO CONTMES^DVBCUTL4
End DoDot:1
+6 IF $DATA(TMP("DVBC LINK"))
Begin DoDot:1
+7 NEW DVBAMORE
+8 WRITE !,?2,"Current Appointment Links",!
+9 WRITE !,?1,"Initial Appt",?21,"Clock Stop Appt",?41,"Current Appt",?61,"Clinic"
+10 SET ARYDA=""
+11 NEW GETOUT
+12 FOR ARYDA=1:1
if ('$DATA(TMP("DVBC LINK",ARYDA))!($DATA(GETOUT)))
QUIT
Begin DoDot:2
+13 SET SELDA=""
+14 SET SELDA=$ORDER(TMP("DVBC LINK",ARYDA,SELDA))
+15 WRITE !,?1,$PIECE(TMP("DVBC LINK",ARYDA,SELDA),U,1)
+16 WRITE ?21,$PIECE(TMP("DVBC LINK",ARYDA,SELDA),U,2),?41,$PIECE(TMP("DVBC LINK",ARYDA,SELDA),U,3)
+17 WRITE ?61,$EXTRACT($PIECE(TMP("DVBC LINK",ARYDA,SELDA),U,4),1,18)
+18 SET DVBAMORE=$ORDER(TMP("DVBC LINK",ARYDA))
+19 IF (+DVBAMORE'>0)!(+DVBAMORE>0&(ARYDA#5=0))
Begin DoDot:3
+20 KILL DIR
+21 SET DIR(0)="F,O^^"
SET DIR("A")="Enter [Return] to continue or ""^"" to exit"
+22 KILL GETOUT
DO ^DIR
if $DATA(DTOUT)!($DATA(DUOUT))
SET GETOUT=1
+23 IF '$DATA(GETOUT)
WRITE !
KILL DIR,DIRUT,X
End DoDot:3
End DoDot:2
+24 KILL TMP("DVBC LINK"),ARYDA,SELDA,DIR,X
End DoDot:1
+25 QUIT
+26 ;
LNKARY(REQDA,DVBADFN) ;** Set up the link array (In TMP local)
+1 NEW LKDA,ARYDA
+2 SET LKDA=""
SET ARYDA=0
+3 FOR
SET LKDA=$ORDER(^DVB(396.95,"AR",REQDA,LKDA))
if +LKDA=0
QUIT
Begin DoDot:1
+4 SET ARYDA=ARYDA+1
+5 SET Y=$PIECE(^DVB(396.95,LKDA,0),U,1)
XECUTE ^DD("DD")
+6 SET TMP("DVBC LINK",ARYDA,LKDA)=Y
KILL Y
+7 SET Y=$PIECE(^DVB(396.95,LKDA,0),U,2)
XECUTE ^DD("DD")
+8 SET TMP("DVBC LINK",ARYDA,LKDA)=TMP("DVBC LINK",ARYDA,LKDA)_"^"_Y
KILL Y
+9 SET Y=$PIECE(^DVB(396.95,LKDA,0),U,3)
XECUTE ^DD("DD")
+10 SET TMP("DVBC LINK",ARYDA,LKDA)=TMP("DVBC LINK",ARYDA,LKDA)_"^"_Y
KILL Y
+11 SET DA=DVBADFN
SET DA(2.98)=$PIECE(^DVB(396.95,LKDA,0),U,3)
SET DR="1900"
SET DR(2.98)=".01"
SET DIC=2
+12 SET DIQ="DVBACLIN"
KILL ^UTILITY("DIQ",$JOB)
+13 DO EN^DIQ1
KILL ^UTILITY("DIQ",$JOB)
+14 SET TMP("DVBC LINK",ARYDA,LKDA)=TMP("DVBC LINK",ARYDA,LKDA)_"^"_DVBACLIN(2.98,$PIECE(^DVB(396.95,LKDA,0),U,3),.01)
+15 KILL DVBACLIN
End DoDot:1
+16 QUIT
