DVBCEEXM ;ALB/GTS-557/THM-COMPILE EXISTING 2507 EXAMS ; 5/24/91 7:07 AM
;;2.7;AMIE;**22**;Apr 10, 1995
;
EN ;only need DFN to return data
I '$D(^DVB(396.4,"APE",DFN)) W !!,"No Requests are currently on file." Q
;;;I '$D(^DVB(396.4,"APE",DFN)) W !!,"Press [RETURN] to continue"
;;;I '$D(^DVB(396.4,"APE",DFN)) R DVBCIN:DTIME K DVBCIN Q
W "Requested exams currently on file:",!!
D SORT
F JX=1:1:80 W "-"
K DVBAEXM,DVBAEXST,DVBADA,DVBADONE,DVBAPDT,DVBAST,DVBARO,JX,DVBCX
Q
;
STAT S DVBAST=$P(^DVB(396.4,DVBADA,0),U,4)
S:$D(^DVB(396.4,DVBADA,"TRAN")) DVBCX=$P(^("TRAN"),U,3)
S DVBAST=$S(DVBAST="C":"Completed",DVBAST="RX":"Cancelled by RO",DVBAST="X":"Cancelled by MAS",DVBAST="F":"Cancelled, failed to report",DVBAST="O":"Open",DVBAST="T":"Transferred",1:"Unknown status")
Q
;
CON I $Y>12,IOST?1"C-".E W !!,"Press [RETURN] to continue or ""^"" to end display of existing exams" R ANS:DTIME W ! I '$T!(ANS=U) S DVBADONE=1
I $Y>12,IOST?1"C-".E W:(DVBADONE'=1) @IOF,"Exams currently on file, continued --",!!!
I ($Y>45),(IOST?1"P-".E) D HDR
Q
;
HDR S PG=PG+1
W @IOF,!,"Date: ",FDT(0),?(80-$L(PGHD)\2),PGHD,?71,"Page: ",PG,!,?(80-$L($$SITE^DVBCUTL4)\2),$$SITE^DVBCUTL4 I PG>1 W !!,"Name: ",PNAM,?44,"SSN: ",SSN,?63,"C-NUM: ",CNUM
W ! F XLINE=1:1:80 W "="
W !!,"Requested exams currently on file:",!
W ! Q
;
SORT ; ** Explore 396.4 file; display exams already requested **
N DVBAEXM,DVBADA,DVBADONE,DVBAPDT,DVBAST,DVBARO,DVBARQDT
S (DVBAEXM,DVBADA,DVBADONE,DVBAPDT,DVBAST,DVBARO,DVBARQDT)=""
F S DVBAEXM=$O(^DVB(396.4,"APE",DFN,DVBAEXM)) Q:DVBAEXM=""!(DVBADONE=1) F S DVBARQDT=$O(^DVB(396.4,"APE",DFN,DVBAEXM,DVBARQDT)) Q:DVBARQDT="" D FLOOP Q:DVBADONE=1
Q
;
FLOOP ; ** Final loop of "APE" index **
F S DVBADA=$O(^DVB(396.4,"APE",DFN,DVBAEXM,DVBARQDT,DVBADA)) Q:DVBADA="" D BLD,CON Q:DVBADONE=1 D PRINT
Q
;
BLD ; ** Set variables to be printed to screen **
N DA,DIK,DATA,DVBAREQ,DVBASTAT,DVBATYPE
;don't continue if record doesn't exist in file #396.4
I '$D(^DVB(396.4,DVBADA,0)) D Q
.;kill xref if record doesn't exist
.K ^DVB(396.4,"APE",DFN,DVBAEXM,DVBARQDT,DVBADA)
;don't continue if record doesn't exist in file #396.3
S DVBAREQ=$P(^DVB(396.4,DVBADA,0),U,2) D Q:'DVBAREQ
.I '$D(^DVB(396.3,DVBAREQ)) D
..;delete record in file #396.4 if its 'parent' in file #396.3 doesn't exist
..;remove reference to file #396.3 so call to ^dik won't error out
..S DATA=^DVB(396.4,DVBADA,0),$P(^(0),U,2)=""
..;delete "c" xref and mumps xrefs manually because reference to file #396.3 was removed
..S DVBATYPE=$P(DATA,U,3),DVBASTAT=$P(DATA,U,4)
..K ^DVB(396.4,"C",DVBAREQ,DVBADA)
..K ^DVB(396.4,"APE",DFN,DVBAEXM,DVBARQDT,DVBADA)
..K ^DVB(396.4,"APS",DFN,DVBATYPE,DVBASTAT,DVBADA)
..K ^DVB(396.4,"ARQ"_DVBAREQ,DVBATYPE,DVBADA)
..;proceed with fm delete
..S DIK="^DVB(396.4,",DA=DVBADA D ^DIK
..S DVBAREQ=0
S Y=DVBARQDT X ^DD("DD") S DVBAPDT=Y
S DVBARO=$P(^DVB(396.3,DVBAREQ,0),U,3)
S DVBARO=$S($D(^DIC(4,+DVBARO,0)):$P(^(0),U,1),1:"Unknown RO")
D STAT
Q
;
PRINT ; ** Print an entry from list of requested exams **
W DVBAEXM,!,"Requested on ",DVBAPDT," by ",DVBARO," - ",DVBAST,!!
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBCEEXM 3207 printed Dec 13, 2024@01:43:59 Page 2
DVBCEEXM ;ALB/GTS-557/THM-COMPILE EXISTING 2507 EXAMS ; 5/24/91 7:07 AM
+1 ;;2.7;AMIE;**22**;Apr 10, 1995
+2 ;
EN ;only need DFN to return data
+1 IF '$DATA(^DVB(396.4,"APE",DFN))
WRITE !!,"No Requests are currently on file."
QUIT
+2 ;;;I '$D(^DVB(396.4,"APE",DFN)) W !!,"Press [RETURN] to continue"
+3 ;;;I '$D(^DVB(396.4,"APE",DFN)) R DVBCIN:DTIME K DVBCIN Q
+4 WRITE "Requested exams currently on file:",!!
+5 DO SORT
+6 FOR JX=1:1:80
WRITE "-"
+7 KILL DVBAEXM,DVBAEXST,DVBADA,DVBADONE,DVBAPDT,DVBAST,DVBARO,JX,DVBCX
+8 QUIT
+9 ;
STAT SET DVBAST=$PIECE(^DVB(396.4,DVBADA,0),U,4)
+1 if $DATA(^DVB(396.4,DVBADA,"TRAN"))
SET DVBCX=$PIECE(^("TRAN"),U,3)
+2 SET DVBAST=$SELECT(DVBAST="C":"Completed",DVBAST="RX":"Cancelled by RO",DVBAST="X":"Cancelled by MAS",DVBAST="F":"Cancelled, failed to report",DVBAST="O":"Open",DVBAST="T":"Transferred",1:"Unknown status")
+3 QUIT
+4 ;
CON IF $Y>12
IF IOST?1"C-".E
WRITE !!,"Press [RETURN] to continue or ""^"" to end display of existing exams"
READ ANS:DTIME
WRITE !
IF '$TEST!(ANS=U)
SET DVBADONE=1
+1 IF $Y>12
IF IOST?1"C-".E
if (DVBADONE'=1)
WRITE @IOF,"Exams currently on file, continued --",!!!
+2 IF ($Y>45)
IF (IOST?1"P-".E)
DO HDR
+3 QUIT
+4 ;
HDR SET PG=PG+1
+1 WRITE @IOF,!,"Date: ",FDT(0),?(80-$LENGTH(PGHD)\2),PGHD,?71,"Page: ",PG,!,?(80-$LENGTH($$SITE^DVBCUTL4)\2),$$SITE^DVBCUTL4
IF PG>1
WRITE !!,"Name: ",PNAM,?44,"SSN: ",SSN,?63,"C-NUM: ",CNUM
+2 WRITE !
FOR XLINE=1:1:80
WRITE "="
+3 WRITE !!,"Requested exams currently on file:",!
+4 WRITE !
QUIT
+5 ;
SORT ; ** Explore 396.4 file; display exams already requested **
+1 NEW DVBAEXM,DVBADA,DVBADONE,DVBAPDT,DVBAST,DVBARO,DVBARQDT
+2 SET (DVBAEXM,DVBADA,DVBADONE,DVBAPDT,DVBAST,DVBARO,DVBARQDT)=""
+3 FOR
SET DVBAEXM=$ORDER(^DVB(396.4,"APE",DFN,DVBAEXM))
if DVBAEXM=""!(DVBADONE=1)
QUIT
FOR
SET DVBARQDT=$ORDER(^DVB(396.4,"APE",DFN,DVBAEXM,DVBARQDT))
if DVBARQDT=""
QUIT
DO FLOOP
if DVBADONE=1
QUIT
+4 QUIT
+5 ;
FLOOP ; ** Final loop of "APE" index **
+1 FOR
SET DVBADA=$ORDER(^DVB(396.4,"APE",DFN,DVBAEXM,DVBARQDT,DVBADA))
if DVBADA=""
QUIT
DO BLD
DO CON
if DVBADONE=1
QUIT
DO PRINT
+2 QUIT
+3 ;
BLD ; ** Set variables to be printed to screen **
+1 NEW DA,DIK,DATA,DVBAREQ,DVBASTAT,DVBATYPE
+2 ;don't continue if record doesn't exist in file #396.4
+3 IF '$DATA(^DVB(396.4,DVBADA,0))
Begin DoDot:1
+4 ;kill xref if record doesn't exist
+5 KILL ^DVB(396.4,"APE",DFN,DVBAEXM,DVBARQDT,DVBADA)
End DoDot:1
QUIT
+6 ;don't continue if record doesn't exist in file #396.3
+7 SET DVBAREQ=$PIECE(^DVB(396.4,DVBADA,0),U,2)
Begin DoDot:1
+8 IF '$DATA(^DVB(396.3,DVBAREQ))
Begin DoDot:2
+9 ;delete record in file #396.4 if its 'parent' in file #396.3 doesn't exist
+10 ;remove reference to file #396.3 so call to ^dik won't error out
+11 SET DATA=^DVB(396.4,DVBADA,0)
SET $PIECE(^(0),U,2)=""
+12 ;delete "c" xref and mumps xrefs manually because reference to file #396.3 was removed
+13 SET DVBATYPE=$PIECE(DATA,U,3)
SET DVBASTAT=$PIECE(DATA,U,4)
+14 KILL ^DVB(396.4,"C",DVBAREQ,DVBADA)
+15 KILL ^DVB(396.4,"APE",DFN,DVBAEXM,DVBARQDT,DVBADA)
+16 KILL ^DVB(396.4,"APS",DFN,DVBATYPE,DVBASTAT,DVBADA)
+17 KILL ^DVB(396.4,"ARQ"_DVBAREQ,DVBATYPE,DVBADA)
+18 ;proceed with fm delete
+19 SET DIK="^DVB(396.4,"
SET DA=DVBADA
DO ^DIK
+20 SET DVBAREQ=0
End DoDot:2
End DoDot:1
if 'DVBAREQ
QUIT
+21 SET Y=DVBARQDT
XECUTE ^DD("DD")
SET DVBAPDT=Y
+22 SET DVBARO=$PIECE(^DVB(396.3,DVBAREQ,0),U,3)
+23 SET DVBARO=$SELECT($DATA(^DIC(4,+DVBARO,0)):$PIECE(^(0),U,1),1:"Unknown RO")
+24 DO STAT
+25 QUIT
+26 ;
PRINT ; ** Print an entry from list of requested exams **
+1 WRITE DVBAEXM,!,"Requested on ",DVBAPDT," by ",DVBARO," - ",DVBAST,!!
+2 QUIT
