- 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 Mar 13, 2025@20:53:06 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
