- 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 Jan 18, 2025@02:45:13 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