DVBAB68 ;ALB/SPH - CAPRI C&P EXAM DETAIL REPORT ;09/11/00
;;2.7;AMIE;**35,149**;Apr 10, 1995;Build 16
;
EN ;only need DFN to return data
I '$D(^DVB(396.4,"APE",DFN)) S ZMSG(DVBABCNT)="No Requests are currently on file.",DVBABCNT=DVBABCNT+1 Q
S ZMSG(DVBABCNT)="Requested exams currently on file:",DVBABCNT=DVBABCNT+1
D SORT
S ZMSG(DVBABCNT)="--------------------------------------------------------------------------------",DVBABCNT=DVBABCNT+1
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
;
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 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 **
S ZMSG(DVBABCNT)=DVBAEXM,DVBABCNT=DVBABCNT+1
S ZMSG(DVBABCNT)="Requested on "_DVBAPDT_" by "_DVBARO_" - "_DVBAST,DVBABCNT=DVBABCNT+1
S ZMSG(DVBABCNT)="",DVBABCNT=DVBABCNT+1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBAB68 2804 printed Nov 22, 2024@16:50:47 Page 2
DVBAB68 ;ALB/SPH - CAPRI C&P EXAM DETAIL REPORT ;09/11/00
+1 ;;2.7;AMIE;**35,149**;Apr 10, 1995;Build 16
+2 ;
EN ;only need DFN to return data
+1 IF '$DATA(^DVB(396.4,"APE",DFN))
SET ZMSG(DVBABCNT)="No Requests are currently on file."
SET DVBABCNT=DVBABCNT+1
QUIT
+2 SET ZMSG(DVBABCNT)="Requested exams currently on file:"
SET DVBABCNT=DVBABCNT+1
+3 DO SORT
+4 SET ZMSG(DVBABCNT)="--------------------------------------------------------------------------------"
SET DVBABCNT=DVBABCNT+1
+5 KILL DVBAEXM,DVBAEXST,DVBADA,DVBADONE,DVBAPDT,DVBAST,DVBARO,JX,DVBCX
+6 QUIT
+7 ;
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 ;
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
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 SET ZMSG(DVBABCNT)=DVBAEXM
SET DVBABCNT=DVBABCNT+1
+2 SET ZMSG(DVBABCNT)="Requested on "_DVBAPDT_" by "_DVBARO_" - "_DVBAST
SET DVBABCNT=DVBABCNT+1
+3 SET ZMSG(DVBABCNT)=""
SET DVBABCNT=DVBABCNT+1
+4 QUIT
