- RARTE4 ;HISC/GJC - Edit/Delete Reports (cont) ;11/4/97 08:02
- ;;5.0;Radiology/Nuclear Medicine;**15,27,41,82,56,47**;Mar 16, 1998;Build 21
- ;Supported IA #10060 ^VA(200
- ;Supported IA #10007 DO^DIC1
- LOCK ;Try to lock next avail IEN, if locked - fail, if used - increment again
- S I=I+1 S RAXIT=$$LOCK^RAUTL12("^RARPT(",I) I RAXIT D UNLOCK2 D INCRPT G START^RARTE
- I $D(^RARPT(I))!($D(^RARPT("B",I))) D UNLOCK^RAUTL12("^RARPT(",I) G LOCK
- S ^RARPT(I,0)=RARPTN,RARPT=I,^(0)=$P(^RARPT(0),"^",1,2)_"^"_I_"^"_($P(^(0),"^",4)+1),^DISV($S($D(DUZ)#2:DUZ,1:0),"^RARPT(")=I S:'$D(^RARPT(RARPT,"T")) ^("T")=""
- S ^RARPT(RARPT,0)=RARPTN_"^"_RADFN_"^"_RADTE_"^"_RACN_"^D",DIK="^RARPT(",DA=RARPT D IX1^DIK
- K %,D,D0,DA,DI,DIC,DIE,DQ,DR,X,Y
- S DA(2)=RADFN,DA(1)=RADTI,DA=RACNI
- S DIE="^RADPT("_RADFN_",""DT"","_RADTI_",""P"","
- S DR="17////"_RARPT D ^DIE
- K %,D,D0,DA,DI,DIC,DIE,DQ,DR,RAY1,X,Y
- I RAPRTSET D PTR^RARTE2
- I RAXIT D UNLOCK2,UNLOCK^RAUTL12("^RARPT(",RARPT) Q
- G IN0
- IN ;lock rpt for the 1st time if editing existing rpt
- S RAXIT=$$LOCK^RAUTL12("^RARPT(",RARPT) I RAXIT D UNLOCK2,Q Q
- IN0 ;skip to here if rpt created in this session and already locked
- G IN1:'$P(RAMDV,"^",14) K RACOPY
- S DIC("S")="I RARPT'=+Y,$P(^(0),U,5)'=""X""" ;omit same & deleted rpt
- ; Remedy ticket #245679, remove multi-index lookup
- S DIC("A")="Select Report to Copy: ",DIC(0)="AEQ",DIC="^RARPT("
- D DICW,^DIC K DIC("S"),DIC("A") S RAY1=Y
- I X="^" D UNLOCK^RAUTL12("^RARPT(",RARPT),UNLOCK2 S RAXIT=$$EN3^RAUTL15(RARPT) D INCRPT G START^RARTE
- G IN1:RAY1<0
- F J="H","R","I" K ^RARPT(RARPT,J)
- F J="R","I" F I=1:1 Q:'$D(^RARPT(+Y,J,I,0)) S ^RARPT(RARPT,J,I,0)=^(0)
- ;F I=1:1 Q:'$D(^RADPT(RADFN,"DT",RADTI,"P",1,"H",I,0)) S ^RARPT(RARPT,"H",I,0)=^RADPT(RADFN,"DT",RADTI,"P",1,"H",I,0)
- S RACOPY=""
- IN1 ;skip to here if div param disallows rpt copying
- I $P(RAMDV,"^",14) W !,RAI
- K RAFIN
- S DR="50///"_RACN
- S DR(2,70.03)="12//^S X=$S($D(RARES)&($D(RABTCH)):RARES,1:"""");S:$D(^VA(200,+X,0)) RARES=$P(^(0),U);I X'>0 S Y=""@15"";70;@15;15"
- I $P(RAMDV,"^",28) S DR(2,70.03)=DR(2,70.03)_"R" ; req'd for DIVISION
- S DR(2,70.03)=DR(2,70.03)_"//^S X=$S($D(RASTFF)&($D(RABTCH)):RASTFF,1:"""");S:$D(^VA(200,+X,0)) RASTFF=$P(^(0),U);I X'>0 S Y=""@1"";60;@1;S RAFIN="""""
- S DA(1)=RADFN,DA=RADTI,DIE="^RADPT("_DA(1)_",""DT""," D ^DIE K DE,DQ
- D ELOC^RABWRTE ; Billing Aware -- ask Inter. Img Loc
- I RAPRTSET S RADRS=2 D COPY^RARTE2 ; copy resid and staff
- G PRT:'$D(RAFIN) W !,RAI
- ;
- ; **BNT - Commented out to stop copying history from file 70 to 74
- ; in patch RA*5*27. The history is now referenced directly from file 70.
- ; I $D(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"H")),'$D(^RARPT(RARPT,"H")) F I=1:1 Q:'$D(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"H",I,0)) S ^RARPT(RARPT,"H",I,0)=^(0)
- ; **
- I '$D(RACOPY),$P(RAMDV,"^",12) D STD^RARTE1 I X="^" G PRT
- W !,RAI D EDTRPT^RARTE1
- PRT D UNLOCK^RAUTL12(RAPNODE,RACNI)
- ; wait til report has been checked for completeness before unlocking it
- S RAXIT=$$EN3^RAUTL15(RARPT) D UNLOCK^RAUTL12("^RARPT(",RARPT)
- I RAXIT S RAXIT=0 D UNLOCK2 D INCRPT G START^RARTE
- ; ---
- D K RAAB G PRT1:'$D(RABTCH),PRT1:'$D(^RABTCH(74.2,+RABTCH,0))
- .; RAHLTCPB flag is inactive
- .N RAHLTCPB S RAHLTCPB=1 D:$S('$D(RACT):0,RACT="V":1,1:0) UPSTAT^RAUTL0
- .D:$S('$D(RACT):1,RACT'="V":1,1:0) UP1^RAUTL1
- ASKREP W !!,"Do you want to place this report in the batch ",RABTCHN,"? Yes// " R X:DTIME S:'$T!(X["^") X="N" S:X="" X="Y" G PRT1:"Nn"[$E(X)
- I "Yy"'[$E(X) W:X'["?" $C(7) W !!?3,"Enter 'YES' to place this report in the batch, or 'NO' not to." G ASKREP
- I $D(^RABTCH(74.2,"D",RARPT,RABTCH)) W !?5,"...report is already part of the '",RABTCHN,"' batch" D INCRPT G START^RARTE
- W !?5,"...will now place report in the '",RABTCHN,"' batch" S DIE="^RABTCH(74.2,",DA=RABTCH,DR="25///"_$E(RADTE,4,7)_$E(RADTE,2,3)_"-"_RACN,DR(2,74.21)="2////N" D ^DIE K DQ,DE D INCRPT G START^RARTE
- PRT1 R !!,"Do you wish to print this report? No// ",X:DTIME S:'$T!(X["^") X="N" S:X="" X="N" ;030497
- I "Nn"[$E(X) D INCRPT G START^RARTE
- I "Yy"'[$E(X) W:X'["?" $C(7) W !!?3,"Enter 'YES' to print this report, or 'NO' not to." G PRT1
- S ION=$P(RAMLC,"^",10),IOP=$S(ION]"":"Q;"_ION,1:"Q")
- S RAMES="W !!?3,""Report has been queued for printing on device "",ION,""."""
- D Q^RARTR D INCRPT G START^RARTE
- ;
- Q I $D(RABTCH),$D(^RABTCH(74.2,+RABTCH,"R",0)) D ASKPRT^RARTE1,BTCH^RABTCH:"Yy"[$E(X)
- Q1 K %,%DT,%W,%Y,%Y1,C,D0,D1,DA,DIC,DIE,DR,OREND,RABTCH,RABTCHN,RACN,RACNI,RACOPY,RACS,RACT,RADATE,RADFN,RADTE,RADTI,RADUZ,RAELESIG,RAFIN,RAHEAD,RAI,RAJ1
- K RALI,RALR,RANME,RANUM,RAOR,RAORDIFN,RAPNODE,RAPRC,RAPRIT,RAQUIT,RAREPORT,RARES,RARPDT,RARPT,RARPTN,RARPTZ,RARTPN,RASET,RASI,RASIG,RASN,RASSN,RAST,RAST1,RASTI,RASTFF,RAVW,XQUIT,W,X,Y
- K D,D2,DDER,DI,DIPGM,DLAYGO,J,RAEND,RAF5,RAFL,RAFST,RAIX,RAPOP,RAY1
- K ^TMP($J,"RAEX")
- K POP,DUOUT
- Q
- DICW ; Build DIC("W") string
- N DO D DO^DIC1
- S DIC("W")=$S($G(DIC("W"))]"":DIC("W")_" ",1:"")_"W "" "",$$FLD^RARTFLDS(+Y,""PROC"")"
- Q
- INCRPT ; Kill extraneous variables to avoid collisions.
- ; Incomplete report information, select another case #.
- K %,%DT,D,D0,D1,D2,DI,DIC,DIWT,DN,I,J,RACN,RACNI,RACT,RADATE,RADTE
- K RADTI,RAFIN,RAI,RALI,RALR,RANME,RAPRC,RARPT,RARPTN,RASSN,RAST,RAVW,X
- Q
- UNLOCK2 D UNLOCK^RAUTL12(RAPNODE,RACNI) L -^RADPT(RADFN,"DT",RADTI)
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRARTE4 5346 printed Feb 19, 2025@00:05:37 Page 2
- RARTE4 ;HISC/GJC - Edit/Delete Reports (cont) ;11/4/97 08:02
- +1 ;;5.0;Radiology/Nuclear Medicine;**15,27,41,82,56,47**;Mar 16, 1998;Build 21
- +2 ;Supported IA #10060 ^VA(200
- +3 ;Supported IA #10007 DO^DIC1
- LOCK ;Try to lock next avail IEN, if locked - fail, if used - increment again
- +1 SET I=I+1
- SET RAXIT=$$LOCK^RAUTL12("^RARPT(",I)
- IF RAXIT
- DO UNLOCK2
- DO INCRPT
- GOTO START^RARTE
- +2 IF $DATA(^RARPT(I))!($DATA(^RARPT("B",I)))
- DO UNLOCK^RAUTL12("^RARPT(",I)
- GOTO LOCK
- +3 SET ^RARPT(I,0)=RARPTN
- SET RARPT=I
- SET ^(0)=$PIECE(^RARPT(0),"^",1,2)_"^"_I_"^"_($PIECE(^(0),"^",4)+1)
- SET ^DISV($SELECT($DATA(DUZ)#2:DUZ,1:0),"^RARPT(")=I
- if '$DATA(^RARPT(RARPT,"T"))
- SET ^("T")=""
- +4 SET ^RARPT(RARPT,0)=RARPTN_"^"_RADFN_"^"_RADTE_"^"_RACN_"^D"
- SET DIK="^RARPT("
- SET DA=RARPT
- DO IX1^DIK
- +5 KILL %,D,D0,DA,DI,DIC,DIE,DQ,DR,X,Y
- +6 SET DA(2)=RADFN
- SET DA(1)=RADTI
- SET DA=RACNI
- +7 SET DIE="^RADPT("_RADFN_",""DT"","_RADTI_",""P"","
- +8 SET DR="17////"_RARPT
- DO ^DIE
- +9 KILL %,D,D0,DA,DI,DIC,DIE,DQ,DR,RAY1,X,Y
- +10 IF RAPRTSET
- DO PTR^RARTE2
- +11 IF RAXIT
- DO UNLOCK2
- DO UNLOCK^RAUTL12("^RARPT(",RARPT)
- QUIT
- +12 GOTO IN0
- IN ;lock rpt for the 1st time if editing existing rpt
- +1 SET RAXIT=$$LOCK^RAUTL12("^RARPT(",RARPT)
- IF RAXIT
- DO UNLOCK2
- DO Q
- QUIT
- IN0 ;skip to here if rpt created in this session and already locked
- +1 if '$PIECE(RAMDV,"^",14)
- GOTO IN1
- KILL RACOPY
- +2 ;omit same & deleted rpt
- SET DIC("S")="I RARPT'=+Y,$P(^(0),U,5)'=""X"""
- +3 ; Remedy ticket #245679, remove multi-index lookup
- +4 SET DIC("A")="Select Report to Copy: "
- SET DIC(0)="AEQ"
- SET DIC="^RARPT("
- +5 DO DICW
- DO ^DIC
- KILL DIC("S"),DIC("A")
- SET RAY1=Y
- +6 IF X="^"
- DO UNLOCK^RAUTL12("^RARPT(",RARPT)
- DO UNLOCK2
- SET RAXIT=$$EN3^RAUTL15(RARPT)
- DO INCRPT
- GOTO START^RARTE
- +7 if RAY1<0
- GOTO IN1
- +8 FOR J="H","R","I"
- KILL ^RARPT(RARPT,J)
- +9 FOR J="R","I"
- FOR I=1:1
- if '$DATA(^RARPT(+Y,J,I,0))
- QUIT
- SET ^RARPT(RARPT,J,I,0)=^(0)
- +10 ;F I=1:1 Q:'$D(^RADPT(RADFN,"DT",RADTI,"P",1,"H",I,0)) S ^RARPT(RARPT,"H",I,0)=^RADPT(RADFN,"DT",RADTI,"P",1,"H",I,0)
- +11 SET RACOPY=""
- IN1 ;skip to here if div param disallows rpt copying
- +1 IF $PIECE(RAMDV,"^",14)
- WRITE !,RAI
- +2 KILL RAFIN
- +3 SET DR="50///"_RACN
- +4 SET DR(2,70.03)="12//^S X=$S($D(RARES)&($D(RABTCH)):RARES,1:"""");S:$D(^VA(200,+X,0)) RARES=$P(^(0),U);I X'>0 S Y=""@15"";70;@15;15"
- +5 ; req'd for DIVISION
- IF $PIECE(RAMDV,"^",28)
- SET DR(2,70.03)=DR(2,70.03)_"R"
- +6 SET DR(2,70.03)=DR(2,70.03)_"//^S X=$S($D(RASTFF)&($D(RABTCH)):RASTFF,1:"""");S:$D(^VA(200,+X,0)) RASTFF=$P(^(0),U);I X'>0 S Y=""@1"";60;@1;S RAFIN="""""
- +7 SET DA(1)=RADFN
- SET DA=RADTI
- SET DIE="^RADPT("_DA(1)_",""DT"","
- DO ^DIE
- KILL DE,DQ
- +8 ; Billing Aware -- ask Inter. Img Loc
- DO ELOC^RABWRTE
- +9 ; copy resid and staff
- IF RAPRTSET
- SET RADRS=2
- DO COPY^RARTE2
- +10 if '$DATA(RAFIN)
- GOTO PRT
- WRITE !,RAI
- +11 ;
- +12 ; **BNT - Commented out to stop copying history from file 70 to 74
- +13 ; in patch RA*5*27. The history is now referenced directly from file 70.
- +14 ; I $D(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"H")),'$D(^RARPT(RARPT,"H")) F I=1:1 Q:'$D(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"H",I,0)) S ^RARPT(RARPT,"H",I,0)=^(0)
- +15 ; **
- +16 IF '$DATA(RACOPY)
- IF $PIECE(RAMDV,"^",12)
- DO STD^RARTE1
- IF X="^"
- GOTO PRT
- +17 WRITE !,RAI
- DO EDTRPT^RARTE1
- PRT DO UNLOCK^RAUTL12(RAPNODE,RACNI)
- +1 ; wait til report has been checked for completeness before unlocking it
- +2 SET RAXIT=$$EN3^RAUTL15(RARPT)
- DO UNLOCK^RAUTL12("^RARPT(",RARPT)
- +3 IF RAXIT
- SET RAXIT=0
- DO UNLOCK2
- DO INCRPT
- GOTO START^RARTE
- +4 ; ---
- +5 Begin DoDot:1
- +6 ; RAHLTCPB flag is inactive
- +7 NEW RAHLTCPB
- SET RAHLTCPB=1
- if $SELECT('$DATA(RACT)
- DO UPSTAT^RAUTL0
- +8 if $SELECT('$DATA(RACT)
- DO UP1^RAUTL1
- End DoDot:1
- KILL RAAB
- if '$DATA(RABTCH)
- GOTO PRT1
- if '$DATA(^RABTCH(74.2,+RABTCH,0))
- GOTO PRT1
- ASKREP WRITE !!,"Do you want to place this report in the batch ",RABTCHN,"? Yes// "
- READ X:DTIME
- if '$TEST!(X["^")
- SET X="N"
- if X=""
- SET X="Y"
- if "Nn"[$EXTRACT(X)
- GOTO PRT1
- +1 IF "Yy"'[$EXTRACT(X)
- if X'["?"
- WRITE $CHAR(7)
- WRITE !!?3,"Enter 'YES' to place this report in the batch, or 'NO' not to."
- GOTO ASKREP
- +2 IF $DATA(^RABTCH(74.2,"D",RARPT,RABTCH))
- WRITE !?5,"...report is already part of the '",RABTCHN,"' batch"
- DO INCRPT
- GOTO START^RARTE
- +3 WRITE !?5,"...will now place report in the '",RABTCHN,"' batch"
- SET DIE="^RABTCH(74.2,"
- SET DA=RABTCH
- SET DR="25///"_$EXTRACT(RADTE,4,7)_$EXTRACT(RADTE,2,3)_"-"_RACN
- SET DR(2,74.21)="2////N"
- DO ^DIE
- KILL DQ,DE
- DO INCRPT
- GOTO START^RARTE
- PRT1 ;030497
- READ !!,"Do you wish to print this report? No// ",X:DTIME
- if '$TEST!(X["^")
- SET X="N"
- if X=""
- SET X="N"
- +1 IF "Nn"[$EXTRACT(X)
- DO INCRPT
- GOTO START^RARTE
- +2 IF "Yy"'[$EXTRACT(X)
- if X'["?"
- WRITE $CHAR(7)
- WRITE !!?3,"Enter 'YES' to print this report, or 'NO' not to."
- GOTO PRT1
- +3 SET ION=$PIECE(RAMLC,"^",10)
- SET IOP=$SELECT(ION]"":"Q;"_ION,1:"Q")
- +4 SET RAMES="W !!?3,""Report has been queued for printing on device "",ION,""."""
- +5 DO Q^RARTR
- DO INCRPT
- GOTO START^RARTE
- +6 ;
- Q IF $DATA(RABTCH)
- IF $DATA(^RABTCH(74.2,+RABTCH,"R",0))
- DO ASKPRT^RARTE1
- if "Yy"[$EXTRACT(X)
- DO BTCH^RABTCH
- Q1 KILL %,%DT,%W,%Y,%Y1,C,D0,D1,DA,DIC,DIE,DR,OREND,RABTCH,RABTCHN,RACN,RACNI,RACOPY,RACS,RACT,RADATE,RADFN,RADTE,RADTI,RADUZ,RAELESIG,RAFIN,RAHEAD,RAI,RAJ1
- +1 KILL RALI,RALR,RANME,RANUM,RAOR,RAORDIFN,RAPNODE,RAPRC,RAPRIT,RAQUIT,RAREPORT,RARES,RARPDT,RARPT,RARPTN,RARPTZ,RARTPN,RASET,RASI,RASIG,RASN,RASSN,RAST,RAST1,RASTI,RASTFF,RAVW,XQUIT,W,X,Y
- +2 KILL D,D2,DDER,DI,DIPGM,DLAYGO,J,RAEND,RAF5,RAFL,RAFST,RAIX,RAPOP,RAY1
- +3 KILL ^TMP($JOB,"RAEX")
- +4 KILL POP,DUOUT
- +5 QUIT
- DICW ; Build DIC("W") string
- +1 NEW DO
- DO DO^DIC1
- +2 SET DIC("W")=$SELECT($GET(DIC("W"))]"":DIC("W")_" ",1:"")_"W "" "",$$FLD^RARTFLDS(+Y,""PROC"")"
- +3 QUIT
- INCRPT ; Kill extraneous variables to avoid collisions.
- +1 ; Incomplete report information, select another case #.
- +2 KILL %,%DT,D,D0,D1,D2,DI,DIC,DIWT,DN,I,J,RACN,RACNI,RACT,RADATE,RADTE
- +3 KILL RADTI,RAFIN,RAI,RALI,RALR,RANME,RAPRC,RARPT,RARPTN,RASSN,RAST,RAVW,X
- +4 QUIT
- UNLOCK2 DO UNLOCK^RAUTL12(RAPNODE,RACNI)
- LOCK -^RADPT(RADFN,"DT",RADTI)
- +1 QUIT