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

DVBCREDT.m

Go to the documentation of this file. 
  1. 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
  1.  ;
  1.  ;**Note:  Priority E is Insufficient
  1.  ;         Priority 'E is not insufficient
  1.  ;
  1.  K ^TMP("DVBCEDIT",$J) I $D(DUZ)#2=0 W !!,*7,"Your user number is invalid.",!! H 3 G EXIT
  1.  S DVBLN="EDIT C&P STATIC INFORMATION" D HOME^%ZIS S FF=IOF
  1.  G EN1
  1.  ;
  1. COMPARE I '$D(^TMP("DVBCEDIT",$J,DA,2,I,0)) S DVBCMOD=1 Q
  1.  I ^DVB(396.3,DA,2,I,0)'=^TMP("DVBCEDIT",$J,DA,2,I,0) S DVBCMOD=1 Q
  1.  Q
  1.  ;
  1. 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
  1.  S STAT=$P(^DVB(396.3,DA,0),U,18)
  1.  ;AJF; Request Status Conversion
  1.  S STAT=$$RSTAT^DVBCUTL8(STAT)
  1.  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
  1.  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
  1.  ;
  1. EDIT ;
  1.  N DVBARQST,SAVEDA,ENTTOUT
  1.  S DVBARQST=$P(^DVB(396.3,DA,0),U,10)
  1.  S SAVEDA=DA
  1.  W !! S DR="W @IOF,!!;9;10:10.2;24;29;21;W !!;23" D ^DIE
  1.  S:$D(DTOUT) ENTTOUT=""
  1.  ;
  1.  ;**Priority E -> E
  1.  I DVBARQST="E",($P(^DVB(396.3,DA,0),U,10)="E"&('$D(ENTTOUT))) DO
  1.  .W !
  1.  .N UPDT2507
  1.  .K DTOUT,DUOUT
  1.  .S DIR(0)="Y^AO",DIR("A")="Do you want to change the request this insufficient is linked to"
  1.  .S DIR("?")="Enter Yes to change the link and No to keep the current link.",DIR("B")="NO" D ^DIR
  1.  .S:+Y=1 UPDT2507=""
  1.  .I $D(UPDT2507) DO
  1.  ..K DIR,Y
  1.  ..N REQDA S REQDA=SAVEDA
  1.  ..S NODE5=""
  1.  ..S:$D(^DVB(396.3,REQDA,5)) NODE5=^DVB(396.3,REQDA,5) ;**Save link node
  1.  ..D CLINSF^DVBCLOG2 S DA=SAVEDA D INSUF^DVBCLOG2 ;*Update 2507 Link info
  1.  ..I '$D(DVBAOUT),('$D(DUOUT)) D INSUFXM^DVBCUTA2 ;*Update exam info
  1.  ..I $D(DVBAOUT)!($D(DUOUT)) D RESTLINK^DVBCUTA2 ;*Restore 2507 link
  1.  ..K NODE5
  1.  .I '$D(UPDT2507) DO  ;**Exam info update check
  1.  ..W !
  1.  ..N REQDA S REQDA=SAVEDA
  1.  ..S NODE5=^DVB(396.3,REQDA,5) ;**Save the link info node
  1.  ..D INSUFXM^DVBCUTA2 ;**Update exam info
  1.  ..K XMEDT,NODE5
  1.  .S DA=SAVEDA
  1.  ;
  1.  ;**Priority 'E -> E
  1.  I DVBARQST'="E",($P(^DVB(396.3,DA,0),U,10)="E"&('$D(ENTTOUT))) DO
  1.  .K DIR,Y
  1.  .N REQDA,XMDA S REQDA=SAVEDA
  1.  .D INSUF^DVBCLOG2 ;**Enter 2507 insuf link info
  1.  .I '$D(DVBAOUT) DO  ;**Enter insuf info on exams
  1.  ..N EXMNM,XMSTAT
  1.  ..K DTOUT
  1.  ..F XMDA=0:0 S XMDA=$O(^DVB(396.4,"C",REQDA,XMDA)) Q:(XMDA=""!($D(DTOUT)))  DO
  1.  ...W @IOF
  1.  ...D XMUPDT^DVBCUTA2 ;**Exam info
  1.  ..S:$D(DTOUT) DVBAOUT="" K Y,^TMP($J,"NEW")
  1.  .I $D(DVBAOUT) DO  ;**Restore priority info when time out
  1.  ..N MSG,RESET,EXMCLR
  1.  ..S (RESET,MSG,EXMCLR)=""
  1.  ..D RESTORE
  1.  .S DA=SAVEDA
  1.  ;
  1.  ;**Priority E -> 'E
  1.  I DVBARQST="E",($P(^DVB(396.3,DA,0),U,10)'="E") DO
  1.  .N REQDA,EXMCLR S REQDA=SAVEDA S EXMCLR=""
  1.  .D RESTORE ;**Clear link and insuf info on exams
  1.  .S DA=SAVEDA
  1.  ;
  1.  ;**If Timed out of information edit in DR string
  1.  I $D(ENTTOUT) DO
  1.  .I DVBARQST'="E",($P(^DVB(396.3,DA,0),U,10)="E") DO  ;**clear insf info
  1.  ..N REQDA,MSG,RESET
  1.  ..S REQDA=SAVEDA S (MSG,RESET)=""
  1.  ..D RESTORE
  1.  S DA=SAVEDA
  1.  S DIE="^DVB(396.3,"
  1.  I $P(^DVB(396.3,DA,0),U,2)[DT G CONK ;no check if entered today
  1.  K DVBCMOD F I=0:0 S I=$O(^DVB(396.3,DA,2,I)) Q:I=""  D COMPARE Q:$D(DVBCMOD)
  1.  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."
  1.  ;
  1. CON I $D(DVBCMOD) W !!,"Press RETURN to continue  " R ANS:DTIME G:'$T!(ANS=U) EXIT
  1. CONK K I,DVBCMOD,DIC,DA,DIE,X,Y G EN1
  1.  ;
  1. EXIT K ^TMP("DVBCEDIT",$J),ANS,DVBAOUT,FF,DVBLN,STAT G KILL^DVBCUTIL
  1.  ;
  1. RESTORE ;** Remove insufficient info from 2507
  1.  K DIE,DA,DR
  1.  D CLINSF^DVBCLOG2 ;**Clear 2507 info
  1.  I $D(RESET) DO  ;**Reset Priority
  1.  .; lab dvba*2.7*214 changed //// to /// to add validation
  1.  .S DA=REQDA,DR="9///^S X=DVBARQST",DIE="^DVB(396.3,"
  1.  .D ^DIE K DA,DR,DIE
  1.  I $D(EXMCLR) DO  ;**Clear exam info
  1.  .F XMDA=0:0 S XMDA=$O(^DVB(396.4,"C",REQDA,XMDA)) Q:(XMDA="")  DO
  1.  ..K DA,DR,DIE
  1.  ..S DA=XMDA,DR=".11////@;.12///@;80///@",DIE="^DVB(396.4,"
  1.  ..D ^DIE
  1.  .K DA,DR,DIE
  1.  I $D(MSG) DO  ;**Output message
  1.  .S TVAR(1,0)="1,3,0,2:1,0^Insufficient link info not updated!...Priority restored"
  1.  .D WR^DVBAUTL4("TVAR")
  1.  .K TVAR
  1.  .D CONTMES^DVBCUTL4
  1.  Q