DVBCRELS ;ALB/GTS-557/THM-RELEASE 2507 REQUEST TO RO ; 5/27/91 4:54 PM
;;2.7;AMIE;**83,193**;Apr 10, 1995;Build 84
;
I $D(DUZ)#2=0 W *7,!!,"Invalid user number (DUZ)",!! H 3 Q
I '$D(^XUSEC("DVBA C RELEASE 2507",DUZ)) W *7,!!,"You are not authorized to release 2507 requests!!",!! H 3 Q
G EN
;
EXAM S EXAM=$P(^DVB(396.4,DA,0),U,3),EXAM=$P(^DVB(396.6,+EXAM,0),U,1)
S STAT=$P(^DVB(396.4,DA,0),U,4)
I STAT'="C"&(STAT'["X") S NFINAL=1 W !,EXAM," is not complete " W:STAT="T" " (transferred)"
Q
;
EN D HOME^%ZIS S FF=IOF,HD="Veteran Selection",HD2="2507 Exam Release"
;
LOOK D KILL W @FF,!?(IOM-$L(HD)\2),HD,!?(IOM-$L(HD2)\2),HD2,!!!
S DIC("W")="D DICW^DVBCUTIL" S DIC="^DVB(396.3,",DIC(0)="AEQM",DIC("A")="Select VETERAN: " D ^DIC G:X=""!(X=U) EXIT I +Y<0 W *7," ???" G LOOK
;AJF;Request Status conversion
S STAT=$$RSTAT^DVBCUTL8($P(^DVB(396.3,+Y,0),U,18)) D STATCHK G:$D(NCN) LOOK
S REQDA=+Y,DFN=+$P(Y,U,2),REQDT=$P(^DVB(396.3,REQDA,0),U,2)
S (PNAM,SSN)="Unknown" I $D(^DPT(DFN,0)) S PNAM=$P(^(0),U,1),SSN=$P(^(0),U,9)
S CNUM=$S($D(^DPT(DFN,.31)):$P(^(.31),U,3),1:"Unknown") K DICW
S STAT=$$RSTAT^DVBCUTL8($P(^DVB(396.3,+Y,0),U,18)) D STATCHK I $D(NCN) K NCN G LOOK
W !!,"Please wait while the individual exam statuses are checked. " H 1 W !
;
DATA S NFINAL=0 F DA=0:0 S DA=$O(^DVB(396.4,"C",REQDA,DA)) Q:DA="" D EXAM
I NFINAL=0 W !!,"All exams have been completed, please enter the following:",!!
I NFINAL=1 W *7,!!,"Since there are still incomplete exams,",!," this request cannot be released to the RO. " W !!,"Press RETURN or ""^"" to exit " R ANS:DTIME G:'$T!(ANS=U) EXIT G LOOK
S DVBOTH=$P(^DVB(396.3,REQDA,1),U,3),DVBABY=$P(^(1),U,5),DVBDTA=$P(^(1),U,6)
S:DVBABY="" DVBABY="@" S:DVBDTA="" DVBDTA="@"
I NFINAL=0 K DR S CTIM=$$NOW^XLFDT,DA=REQDA,DIE="^DVB(396.3,",DR="12////"_CTIM_";13////"_CTIM_";14////^S X=DUZ;17////4;W *7;22;25R;26R" D ^DIE K CTIM
I '$D(Y),NFINAL=0 W !!,"This request is now released.",!! H 2
I '$D(Y),$P(^DVB(396.3,REQDA,0),U,22)]"",$P(^(0),U,22)'=$P(^XMB(1,1,0),U,1) D ^DVBCXFRE K DIC,DIE,DR,DA S FAX="Y",RSTAT="CT" G FX ;transfers
;set back to transcribed if error or not completed
;AJF;Request Status conversion
I $D(Y) W *7,!!,"Release NOT COMPLETED !!",!! H 2 S DR="6///@;12///@;13///@;14///@;17////8;25////"_DVBABY_";26////"_DVBDTA,DIE="^DVB(396.3,",DA=REQDA,DIC=DIE,$P(^DVB(396.3,REQDA,1),U,3)=DVBOTH D ^DIE G LOOK
S FAX=$S($D(^DVB(396.3,REQDA,1)):$P(^(1),U,3),1:"N"),RSTAT="C"
;
FX ;if to be faxed or transferred out, set like RO has printed it
;AJF;Request Status conversion
I FAX="Y" K DR S CTIM=$$NOW^XLFDT,DR="6////"_CTIM_";15////"_CTIM_";16////^S X=DUZ;17///"_RSTAT S (DIE,DIC)="^DVB(396.3,",DA=REQDA D ^DIE
G LOOK
;
EXIT G KILL^DVBCUTIL
;
KILL K CNUM,SSN,PNAM,FAX,CTIM,DIC,DA,D0,D1,DFN,X,Y,NCN,STAT,%,NOFND,NFINAL,REQDA,STAT,RSTAT,DVBDTA,DVBOTH,DVBABY
Q
;
STATCHK I STAT="RX" W *7,!!,"This request has been cancelled by the RO.",!! H 2 S NCN=1 Q
I STAT="CT" W *7,!!,"This request has been completed and transferred out.",!! H 2 S NCN=1 Q
I STAT="X" W *7,!!,"This request has been cancelled by MAS.",!! H 2 S NCN=1 Q
I STAT="R" W *7,!!,"This request has been released to the RO.",!! H 2 S NCN=1 Q
I STAT="C" W *7,!!,"This request has been printed by the RO.",!! H 2 S NCN=1 Q
I STAT="N"!(STAT="NT") W *7,!!,"This request is new and has not yet been reported to MAS.",!! H 2 S NCN=1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBCRELS 3426 printed Dec 13, 2024@01:48:24 Page 2
DVBCRELS ;ALB/GTS-557/THM-RELEASE 2507 REQUEST TO RO ; 5/27/91 4:54 PM
+1 ;;2.7;AMIE;**83,193**;Apr 10, 1995;Build 84
+2 ;
+3 IF $DATA(DUZ)#2=0
WRITE *7,!!,"Invalid user number (DUZ)",!!
HANG 3
QUIT
+4 IF '$DATA(^XUSEC("DVBA C RELEASE 2507",DUZ))
WRITE *7,!!,"You are not authorized to release 2507 requests!!",!!
HANG 3
QUIT
+5 GOTO EN
+6 ;
EXAM SET EXAM=$PIECE(^DVB(396.4,DA,0),U,3)
SET EXAM=$PIECE(^DVB(396.6,+EXAM,0),U,1)
+1 SET STAT=$PIECE(^DVB(396.4,DA,0),U,4)
+2 IF STAT'="C"&(STAT'["X")
SET NFINAL=1
WRITE !,EXAM," is not complete "
if STAT="T"
WRITE " (transferred)"
+3 QUIT
+4 ;
EN DO HOME^%ZIS
SET FF=IOF
SET HD="Veteran Selection"
SET HD2="2507 Exam Release"
+1 ;
LOOK DO KILL
WRITE @FF,!?(IOM-$LENGTH(HD)\2),HD,!?(IOM-$LENGTH(HD2)\2),HD2,!!!
+1 SET DIC("W")="D DICW^DVBCUTIL"
SET DIC="^DVB(396.3,"
SET DIC(0)="AEQM"
SET DIC("A")="Select VETERAN: "
DO ^DIC
if X=""!(X=U)
GOTO EXIT
IF +Y<0
WRITE *7," ???"
GOTO LOOK
+2 ;AJF;Request Status conversion
+3 SET STAT=$$RSTAT^DVBCUTL8($PIECE(^DVB(396.3,+Y,0),U,18))
DO STATCHK
if $DATA(NCN)
GOTO LOOK
+4 SET REQDA=+Y
SET DFN=+$PIECE(Y,U,2)
SET REQDT=$PIECE(^DVB(396.3,REQDA,0),U,2)
+5 SET (PNAM,SSN)="Unknown"
IF $DATA(^DPT(DFN,0))
SET PNAM=$PIECE(^(0),U,1)
SET SSN=$PIECE(^(0),U,9)
+6 SET CNUM=$SELECT($DATA(^DPT(DFN,.31)):$PIECE(^(.31),U,3),1:"Unknown")
KILL DICW
+7 SET STAT=$$RSTAT^DVBCUTL8($PIECE(^DVB(396.3,+Y,0),U,18))
DO STATCHK
IF $DATA(NCN)
KILL NCN
GOTO LOOK
+8 WRITE !!,"Please wait while the individual exam statuses are checked. "
HANG 1
WRITE !
+9 ;
DATA SET NFINAL=0
FOR DA=0:0
SET DA=$ORDER(^DVB(396.4,"C",REQDA,DA))
if DA=""
QUIT
DO EXAM
+1 IF NFINAL=0
WRITE !!,"All exams have been completed, please enter the following:",!!
+2 IF NFINAL=1
WRITE *7,!!,"Since there are still incomplete exams,",!," this request cannot be released to the RO. "
WRITE !!,"Press RETURN or ""^"" to exit "
READ ANS:DTIME
if '$TEST!(ANS=U)
GOTO EXIT
GOTO LOOK
+3 SET DVBOTH=$PIECE(^DVB(396.3,REQDA,1),U,3)
SET DVBABY=$PIECE(^(1),U,5)
SET DVBDTA=$PIECE(^(1),U,6)
+4 if DVBABY=""
SET DVBABY="@"
if DVBDTA=""
SET DVBDTA="@"
+5 IF NFINAL=0
KILL DR
SET CTIM=$$NOW^XLFDT
SET DA=REQDA
SET DIE="^DVB(396.3,"
SET DR="12////"_CTIM_";13////"_CTIM_";14////^S X=DUZ;17////4;W *7;22;25R;26R"
DO ^DIE
KILL CTIM
+6 IF '$DATA(Y)
IF NFINAL=0
WRITE !!,"This request is now released.",!!
HANG 2
+7 ;transfers
IF '$DATA(Y)
IF $PIECE(^DVB(396.3,REQDA,0),U,22)]""
IF $PIECE(^(0),U,22)'=$PIECE(^XMB(1,1,0),U,1)
DO ^DVBCXFRE
KILL DIC,DIE,DR,DA
SET FAX="Y"
SET RSTAT="CT"
GOTO FX
+8 ;set back to transcribed if error or not completed
+9 ;AJF;Request Status conversion
+10 IF $DATA(Y)
WRITE *7,!!,"Release NOT COMPLETED !!",!!
HANG 2
SET DR="6///@;12///@;13///@;14///@;17////8;25////"_DVBABY_";26////"_DVBDTA
SET DIE="^DVB(396.3,"
SET DA=REQDA
SET DIC=DIE
SET $PIECE(^DVB(396.3,REQDA,1),U,3)=DVBOTH
DO ^DIE
GOTO LOOK
+11 SET FAX=$SELECT($DATA(^DVB(396.3,REQDA,1)):$PIECE(^(1),U,3),1:"N")
SET RSTAT="C"
+12 ;
FX ;if to be faxed or transferred out, set like RO has printed it
+1 ;AJF;Request Status conversion
+2 IF FAX="Y"
KILL DR
SET CTIM=$$NOW^XLFDT
SET DR="6////"_CTIM_";15////"_CTIM_";16////^S X=DUZ;17///"_RSTAT
SET (DIE,DIC)="^DVB(396.3,"
SET DA=REQDA
DO ^DIE
+3 GOTO LOOK
+4 ;
EXIT GOTO KILL^DVBCUTIL
+1 ;
KILL KILL CNUM,SSN,PNAM,FAX,CTIM,DIC,DA,D0,D1,DFN,X,Y,NCN,STAT,%,NOFND,NFINAL,REQDA,STAT,RSTAT,DVBDTA,DVBOTH,DVBABY
+1 QUIT
+2 ;
STATCHK IF STAT="RX"
WRITE *7,!!,"This request has been cancelled by the RO.",!!
HANG 2
SET NCN=1
QUIT
+1 IF STAT="CT"
WRITE *7,!!,"This request has been completed and transferred out.",!!
HANG 2
SET NCN=1
QUIT
+2 IF STAT="X"
WRITE *7,!!,"This request has been cancelled by MAS.",!!
HANG 2
SET NCN=1
QUIT
+3 IF STAT="R"
WRITE *7,!!,"This request has been released to the RO.",!!
HANG 2
SET NCN=1
QUIT
+4 IF STAT="C"
WRITE *7,!!,"This request has been printed by the RO.",!!
HANG 2
SET NCN=1
QUIT
+5 IF STAT="N"!(STAT="NT")
WRITE *7,!!,"This request is new and has not yet been reported to MAS.",!!
HANG 2
SET NCN=1
+6 QUIT
