DVBCREDT ;ALB/GTS/THM/LAB - EDIT STATIS C&P INFO ; Sep 23, 2019@16:41
;;2.7;AMIE;**193,214,225**;Apr 10, 1995;Build 5
;
;**Note: Priority E is Insufficient
; Priority 'E is not insufficient
;
K ^TMP("DVBCEDIT",$J) I $D(DUZ)#2=0 W !!,*7,"Your user number is invalid.",!! H 3 G EXIT
S DVBLN="EDIT C&P STATIC INFORMATION" D HOME^%ZIS S FF=IOF
G EN1
;
COMPARE I '$D(^TMP("DVBCEDIT",$J,DA,2,I,0)) S DVBCMOD=1 Q
I ^DVB(396.3,DA,2,I,0)'=^TMP("DVBCEDIT",$J,DA,2,I,0) S DVBCMOD=1 Q
Q
;
EN1 W @IOF,!?(IOM-$L(DVBLN)\2),DVBLN,!!! S DIC="AE",DIC("A")="Enter VETERAN NAME: ",DIC="^DVB(396.3,",DIE=DIC,DIC(0)="AEQM" D ^DIC G:X=""!(X=U) EXIT S DA=+Y I DA<0 G EN1
S STAT=$P(^DVB(396.3,DA,0),U,18)
;AJF; Request Status Conversion
S STAT=$$RSTAT^DVBCUTL8(STAT)
I STAT'="N"&(STAT'="P")&(STAT'="NR") W !!,"The status of this request is not NEW or NEW RE-ROUTED or PENDING, REPORTED.",!,"It cannot, therefore, be modified.",*7,!! S DVBCMOD=1 G CON
F I=0:0 S I=$O(^DVB(396.3,DA,2,I)) Q:I="" S ^TMP("DVBCEDIT",$J,DA,2,I,0)=^DVB(396.3,DA,2,I,0) ;save lines for compare
;
EDIT ;
N DVBARQST,SAVEDA,ENTTOUT
S DVBARQST=$P(^DVB(396.3,DA,0),U,10)
S SAVEDA=DA
W !! S DR="W @IOF,!!;9;10:10.2;24;29;21;W !!;23" D ^DIE
S:$D(DTOUT) ENTTOUT=""
;
;**Priority E -> E
I DVBARQST="E",($P(^DVB(396.3,DA,0),U,10)="E"&('$D(ENTTOUT))) DO
.W !
.N UPDT2507
.K DTOUT,DUOUT
.S DIR(0)="Y^AO",DIR("A")="Do you want to change the request this insufficient is linked to"
.S DIR("?")="Enter Yes to change the link and No to keep the current link.",DIR("B")="NO" D ^DIR
.S:+Y=1 UPDT2507=""
.I $D(UPDT2507) DO
..K DIR,Y
..N REQDA S REQDA=SAVEDA
..S NODE5=""
..S:$D(^DVB(396.3,REQDA,5)) NODE5=^DVB(396.3,REQDA,5) ;**Save link node
..D CLINSF^DVBCLOG2 S DA=SAVEDA D INSUF^DVBCLOG2 ;*Update 2507 Link info
..I '$D(DVBAOUT),('$D(DUOUT)) D INSUFXM^DVBCUTA2 ;*Update exam info
..I $D(DVBAOUT)!($D(DUOUT)) D RESTLINK^DVBCUTA2 ;*Restore 2507 link
..K NODE5
.I '$D(UPDT2507) DO ;**Exam info update check
..W !
..N REQDA S REQDA=SAVEDA
..S NODE5=^DVB(396.3,REQDA,5) ;**Save the link info node
..D INSUFXM^DVBCUTA2 ;**Update exam info
..K XMEDT,NODE5
.S DA=SAVEDA
;
;**Priority 'E -> E
I DVBARQST'="E",($P(^DVB(396.3,DA,0),U,10)="E"&('$D(ENTTOUT))) DO
.K DIR,Y
.N REQDA,XMDA S REQDA=SAVEDA
.D INSUF^DVBCLOG2 ;**Enter 2507 insuf link info
.I '$D(DVBAOUT) DO ;**Enter insuf info on exams
..N EXMNM,XMSTAT
..K DTOUT
..F XMDA=0:0 S XMDA=$O(^DVB(396.4,"C",REQDA,XMDA)) Q:(XMDA=""!($D(DTOUT))) DO
...W @IOF
...D XMUPDT^DVBCUTA2 ;**Exam info
..S:$D(DTOUT) DVBAOUT="" K Y,^TMP($J,"NEW")
.I $D(DVBAOUT) DO ;**Restore priority info when time out
..N MSG,RESET,EXMCLR
..S (RESET,MSG,EXMCLR)=""
..D RESTORE
.S DA=SAVEDA
;
;**Priority E -> 'E
I DVBARQST="E",($P(^DVB(396.3,DA,0),U,10)'="E") DO
.N REQDA,EXMCLR S REQDA=SAVEDA S EXMCLR=""
.D RESTORE ;**Clear link and insuf info on exams
.S DA=SAVEDA
;
;**If Timed out of information edit in DR string
I $D(ENTTOUT) DO
.I DVBARQST'="E",($P(^DVB(396.3,DA,0),U,10)="E") DO ;**clear insf info
..N REQDA,MSG,RESET
..S REQDA=SAVEDA S (MSG,RESET)=""
..D RESTORE
S DA=SAVEDA
S DIE="^DVB(396.3,"
I $P(^DVB(396.3,DA,0),U,2)[DT G CONK ;no check if entered today
K DVBCMOD F I=0:0 S I=$O(^DVB(396.3,DA,2,I)) Q:I="" D COMPARE Q:$D(DVBCMOD)
I $D(DVBCMOD) S DR="23.5///NOW;23.6////^S X=DUZ" D ^DIE W @IOF,!!,*7,"Since you have modified the REMARKS section,",!,"a new copy of the request will be issued to the",!,"medical center tomorrow morning."
;
CON I $D(DVBCMOD) W !!,"Press RETURN to continue " R ANS:DTIME G:'$T!(ANS=U) EXIT
CONK K I,DVBCMOD,DIC,DA,DIE,X,Y G EN1
;
EXIT K ^TMP("DVBCEDIT",$J),ANS,DVBAOUT,FF,DVBLN,STAT G KILL^DVBCUTIL
;
RESTORE ;** Remove insufficient info from 2507
K DIE,DA,DR
D CLINSF^DVBCLOG2 ;**Clear 2507 info
I $D(RESET) DO ;**Reset Priority
.; lab dvba*2.7*214 changed //// to /// to add validation
.S DA=REQDA,DR="9///^S X=DVBARQST",DIE="^DVB(396.3,"
.D ^DIE K DA,DR,DIE
I $D(EXMCLR) DO ;**Clear exam info
.F XMDA=0:0 S XMDA=$O(^DVB(396.4,"C",REQDA,XMDA)) Q:(XMDA="") DO
..K DA,DR,DIE
..S DA=XMDA,DR=".11////@;.12///@;80///@",DIE="^DVB(396.4,"
..D ^DIE
.K DA,DR,DIE
I $D(MSG) DO ;**Output message
.S TVAR(1,0)="1,3,0,2:1,0^Insufficient link info not updated!...Priority restored"
.D WR^DVBAUTL4("TVAR")
.K TVAR
.D CONTMES^DVBCUTL4
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBCREDT 4457 printed Dec 13, 2024@01:48:23 Page 2
DVBCREDT ;ALB/GTS/THM/LAB - EDIT STATIS C&P INFO ; Sep 23, 2019@16:41
+1 ;;2.7;AMIE;**193,214,225**;Apr 10, 1995;Build 5
+2 ;
+3 ;**Note: Priority E is Insufficient
+4 ; Priority 'E is not insufficient
+5 ;
+6 KILL ^TMP("DVBCEDIT",$JOB)
IF $DATA(DUZ)#2=0
WRITE !!,*7,"Your user number is invalid.",!!
HANG 3
GOTO EXIT
+7 SET DVBLN="EDIT C&P STATIC INFORMATION"
DO HOME^%ZIS
SET FF=IOF
+8 GOTO EN1
+9 ;
COMPARE IF '$DATA(^TMP("DVBCEDIT",$JOB,DA,2,I,0))
SET DVBCMOD=1
QUIT
+1 IF ^DVB(396.3,DA,2,I,0)'=^TMP("DVBCEDIT",$JOB,DA,2,I,0)
SET DVBCMOD=1
QUIT
+2 QUIT
+3 ;
EN1 WRITE @IOF,!?(IOM-$LENGTH(DVBLN)\2),DVBLN,!!!
SET DIC="AE"
SET DIC("A")="Enter VETERAN NAME: "
SET DIC="^DVB(396.3,"
SET DIE=DIC
SET DIC(0)="AEQM"
DO ^DIC
if X=""!(X=U)
GOTO EXIT
SET DA=+Y
IF DA<0
GOTO EN1
+1 SET STAT=$PIECE(^DVB(396.3,DA,0),U,18)
+2 ;AJF; Request Status Conversion
+3 SET STAT=$$RSTAT^DVBCUTL8(STAT)
+4 IF STAT'="N"&(STAT'="P")&(STAT'="NR")
WRITE !!,"The status of this request is not NEW or NEW RE-ROUTED or PENDING, REPORTED.",!,"It cannot, therefore, be modified.",*7,!!
SET DVBCMOD=1
GOTO CON
+5 ;save lines for compare
FOR I=0:0
SET I=$ORDER(^DVB(396.3,DA,2,I))
if I=""
QUIT
SET ^TMP("DVBCEDIT",$JOB,DA,2,I,0)=^DVB(396.3,DA,2,I,0)
+6 ;
EDIT ;
+1 NEW DVBARQST,SAVEDA,ENTTOUT
+2 SET DVBARQST=$PIECE(^DVB(396.3,DA,0),U,10)
+3 SET SAVEDA=DA
+4 WRITE !!
SET DR="W @IOF,!!;9;10:10.2;24;29;21;W !!;23"
DO ^DIE
+5 if $DATA(DTOUT)
SET ENTTOUT=""
+6 ;
+7 ;**Priority E -> E
+8 IF DVBARQST="E"
IF ($PIECE(^DVB(396.3,DA,0),U,10)="E"&('$DATA(ENTTOUT)))
Begin DoDot:1
+9 WRITE !
+10 NEW UPDT2507
+11 KILL DTOUT,DUOUT
+12 SET DIR(0)="Y^AO"
SET DIR("A")="Do you want to change the request this insufficient is linked to"
+13 SET DIR("?")="Enter Yes to change the link and No to keep the current link."
SET DIR("B")="NO"
DO ^DIR
+14 if +Y=1
SET UPDT2507=""
+15 IF $DATA(UPDT2507)
Begin DoDot:2
+16 KILL DIR,Y
+17 NEW REQDA
SET REQDA=SAVEDA
+18 SET NODE5=""
+19 ;**Save link node
if $DATA(^DVB(396.3,REQDA,5))
SET NODE5=^DVB(396.3,REQDA,5)
+20 ;*Update 2507 Link info
DO CLINSF^DVBCLOG2
SET DA=SAVEDA
DO INSUF^DVBCLOG2
+21 ;*Update exam info
IF '$DATA(DVBAOUT)
IF ('$DATA(DUOUT))
DO INSUFXM^DVBCUTA2
+22 ;*Restore 2507 link
IF $DATA(DVBAOUT)!($DATA(DUOUT))
DO RESTLINK^DVBCUTA2
+23 KILL NODE5
End DoDot:2
+24 ;**Exam info update check
IF '$DATA(UPDT2507)
Begin DoDot:2
+25 WRITE !
+26 NEW REQDA
SET REQDA=SAVEDA
+27 ;**Save the link info node
SET NODE5=^DVB(396.3,REQDA,5)
+28 ;**Update exam info
DO INSUFXM^DVBCUTA2
+29 KILL XMEDT,NODE5
End DoDot:2
+30 SET DA=SAVEDA
End DoDot:1
+31 ;
+32 ;**Priority 'E -> E
+33 IF DVBARQST'="E"
IF ($PIECE(^DVB(396.3,DA,0),U,10)="E"&('$DATA(ENTTOUT)))
Begin DoDot:1
+34 KILL DIR,Y
+35 NEW REQDA,XMDA
SET REQDA=SAVEDA
+36 ;**Enter 2507 insuf link info
DO INSUF^DVBCLOG2
+37 ;**Enter insuf info on exams
IF '$DATA(DVBAOUT)
Begin DoDot:2
+38 NEW EXMNM,XMSTAT
+39 KILL DTOUT
+40 FOR XMDA=0:0
SET XMDA=$ORDER(^DVB(396.4,"C",REQDA,XMDA))
if (XMDA=""!($DATA(DTOUT)))
QUIT
Begin DoDot:3
+41 WRITE @IOF
+42 ;**Exam info
DO XMUPDT^DVBCUTA2
End DoDot:3
+43 if $DATA(DTOUT)
SET DVBAOUT=""
KILL Y,^TMP($JOB,"NEW")
End DoDot:2
+44 ;**Restore priority info when time out
IF $DATA(DVBAOUT)
Begin DoDot:2
+45 NEW MSG,RESET,EXMCLR
+46 SET (RESET,MSG,EXMCLR)=""
+47 DO RESTORE
End DoDot:2
+48 SET DA=SAVEDA
End DoDot:1
+49 ;
+50 ;**Priority E -> 'E
+51 IF DVBARQST="E"
IF ($PIECE(^DVB(396.3,DA,0),U,10)'="E")
Begin DoDot:1
+52 NEW REQDA,EXMCLR
SET REQDA=SAVEDA
SET EXMCLR=""
+53 ;**Clear link and insuf info on exams
DO RESTORE
+54 SET DA=SAVEDA
End DoDot:1
+55 ;
+56 ;**If Timed out of information edit in DR string
+57 IF $DATA(ENTTOUT)
Begin DoDot:1
+58 ;**clear insf info
IF DVBARQST'="E"
IF ($PIECE(^DVB(396.3,DA,0),U,10)="E")
Begin DoDot:2
+59 NEW REQDA,MSG,RESET
+60 SET REQDA=SAVEDA
SET (MSG,RESET)=""
+61 DO RESTORE
End DoDot:2
End DoDot:1
+62 SET DA=SAVEDA
+63 SET DIE="^DVB(396.3,"
+64 ;no check if entered today
IF $PIECE(^DVB(396.3,DA,0),U,2)[DT
GOTO CONK
+65 KILL DVBCMOD
FOR I=0:0
SET I=$ORDER(^DVB(396.3,DA,2,I))
if I=""
QUIT
DO COMPARE
if $DATA(DVBCMOD)
QUIT
+66 IF $DATA(DVBCMOD)
SET DR="23.5///NOW;23.6////^S X=DUZ"
DO ^DIE
WRITE @IOF,!!,*7,"Since you have modified the REMARKS section,",!,"a new copy of the request will be issued to the",!,"medical center tomorrow morning."
+67 ;
CON IF $DATA(DVBCMOD)
WRITE !!,"Press RETURN to continue "
READ ANS:DTIME
if '$TEST!(ANS=U)
GOTO EXIT
CONK KILL I,DVBCMOD,DIC,DA,DIE,X,Y
GOTO EN1
+1 ;
EXIT KILL ^TMP("DVBCEDIT",$JOB),ANS,DVBAOUT,FF,DVBLN,STAT
GOTO KILL^DVBCUTIL
+1 ;
RESTORE ;** Remove insufficient info from 2507
+1 KILL DIE,DA,DR
+2 ;**Clear 2507 info
DO CLINSF^DVBCLOG2
+3 ;**Reset Priority
IF $DATA(RESET)
Begin DoDot:1
+4 ; lab dvba*2.7*214 changed //// to /// to add validation
+5 SET DA=REQDA
SET DR="9///^S X=DVBARQST"
SET DIE="^DVB(396.3,"
+6 DO ^DIE
KILL DA,DR,DIE
End DoDot:1
+7 ;**Clear exam info
IF $DATA(EXMCLR)
Begin DoDot:1
+8 FOR XMDA=0:0
SET XMDA=$ORDER(^DVB(396.4,"C",REQDA,XMDA))
if (XMDA="")
QUIT
Begin DoDot:2
+9 KILL DA,DR,DIE
+10 SET DA=XMDA
SET DR=".11////@;.12///@;80///@"
SET DIE="^DVB(396.4,"
+11 DO ^DIE
End DoDot:2
+12 KILL DA,DR,DIE
End DoDot:1
+13 ;**Output message
IF $DATA(MSG)
Begin DoDot:1
+14 SET TVAR(1,0)="1,3,0,2:1,0^Insufficient link info not updated!...Priority restored"
+15 DO WR^DVBAUTL4("TVAR")
+16 KILL TVAR
+17 DO CONTMES^DVBCUTL4
End DoDot:1
+18 QUIT
