RAUTL9 ;HISC/FPT-Utility Routines ;4/9/97 10:08
;;5.0;Radiology/Nuclear Medicine;**13,27,51**;Mar 16, 1998
EN1 ; allow lower & uppercase response to REPORT STATUS field
; called from [RA REPORT EDIT] & [RA VERIFY REPORT ONLY]
; " " routine UNVER+2^RARTE1
;
N Y K DIR,DIROUT,DIRUT,DTOUT,DUOUT
N RAMT S RAMT=0 ; RAMT=$S(Report status before edit="":0,1:1)
D IARU
I RATRUE=1 S DIR(0)="S^V:VERIFIED;R:RELEASED/NOT VERIFIED;PD:PROBLEM DRAFT;D:DRAFT"
I RATRUE=0 S DIR(0)="S^V:VERIFIED;PD:PROBLEM DRAFT;D:DRAFT"
S DIR("A")="REPORT STATUS"
S:$P(^RARPT(D0,0),"^",5)="" RAMT=1
S:$P(^RARPT(D0,0),"^",5)]"" DIR("B")=$P(^RARPT(D0,0),"^",5)
S:RAMT DIR("B")="D" ; default to 'Draft' if missing report status
D ^DIR K DIR,RATRUE
I $D(DIRUT),(RAMT) D
. S $P(^RARPT(D0,0),"^",5)="D" D ENSET^RAXREF(74,5,"D",D0)
. ; set Report Status to 'Draft' if originally null, and user times out
. ; or '^' out! Make sure xrefs are set!
. Q
Q:$D(DIRUT)
I $E(Y)="V",'$D(^XUSEC("RA VERIFY",DUZ)) W !!,*7,"You do not have the appropriate privileges to verify a report." G EN1
S RASTATX=$E(Y) S:RASTATX="P" RASTATX="PD"
Q
EN2 ; residents enter report status to pre-verify
; called from input templates [RA PRE-VERIFY REPORT EDIT] and [RA PRE-
; VERIFY REPORT ONLY]
N Y K DIR,DIROUT,DIRUT,DTOUT,DUOUT
N RAMT S RAMT=0 ; RAMT=$S(Report status before edit="":0,1:1)
D IARU
I RATRUE=1 S DIR(0)="S^R:RELEASED/NOT VERIFIED;PD:PROBLEM DRAFT;D:DRAFT"
I RATRUE=0 S DIR(0)="S^PD:PROBLEM DRAFT;D:DRAFT"
S DIR("A")="RESIDENT PRE-VERIFICATION REPORT STATUS"
S:$P(^RARPT(D0,0),"^",5)="" RAMT=1
S:$P(^RARPT(D0,0),"^",5)]"" DIR("B")=$P(^RARPT(D0,0),"^",5)
S:RAMT DIR("B")="D" ; default to 'Draft' if missing report status
D ^DIR K DIR,RATRUE
I $D(DIRUT),(RAMT) D
. S $P(^RARPT(D0,0),"^",5)="D" D ENSET^RAXREF(74,5,"D",D0)
. ; set Report Status to 'Draft' if originally null, and user times out
. ; or '^' out! Make sure xrefs are set!
. Q
Q:$D(DIRUT)
S RASTATX=$E(Y) S:RASTATX="P" RASTATX="PD"
Q
EN3 ; residents pre-verify a report
N Y K DIR,DIROUT,DIRUT,DTOUT,DUOUT
W ! S DIR(0)="Y",DIR("A")="WANT TO PRE-VERIFY THIS REPORT"
S DIR("?")="Answer YES to mark this report as pre-verified. Your user ID number, electronic signature code and the current date/time will be stored in the pre-verification fields of this entry."
D ^DIR K DIR
W ! Q:$D(DIRUT)
S RAYN=+Y
Q
EN4 ; re-display report text question
N Y K DIR,DIROUT,DIRUT,DTOUT,DUOUT
S DIR(0)="Y",DIR("A")="Want to View the Report Text again" D ^DIR K DIR
W ! Q:$D(DIRUT)
S RAYN=Y
Q
EXIST ; Checks if word processing data exists called from [RA REPORT EDIT]
; and [RA PRE-VERIFY REPORT EDIT] templates.
I RANODE="H",(($D(DTOUT))!($D(DUOUT))) D Q
. D CHRSTOR
I RANODE="R",(($D(DTOUT))!($D(DUOUT))) Q
I RANODE="I",(($D(DTOUT))!($D(DUOUT))) Q
I +$O(^RARPT(DA,RANODE,0)) D Q
. N CNT,X,X1,X2,X3,X4,RAWPFLG S (RAWPFLG,X)=0
. F S X=$O(^RARPT(DA,RANODE,X)) Q:X'>0 D Q:RAWPFLG
.. S (CNT,X2)=0
.. S X1=$G(^RARPT(DA,RANODE,X,0)) Q:X1']""
.. S X2=$L(X1)
.. F X3=1:1:X2 D Q:RAWPFLG
... S X4=$E(X1,X3) S:X4?1AN CNT=CNT+1
... S:X4'?1AN&(CNT>0) CNT=0
... S:CNT=2 RAWPFLG=1
... Q
.. Q
. I 'RAWPFLG D
.. S Y=$S(RANODE="H":"@1",RANODE="R":"@2",1:"@3")
.. W " ?? Invalid "
.. W $S(RANODE="H":"Clinical History",RANODE="R":"Report",1:"Impression")
.. W " text.",$C(7)
.. K ^RARPT(DA,RANODE) ; Clear out bad WP
.. Q
. I RANODE="H",('RAWPFLG) D CHRSTOR
. Q
Q
CHRSTOR ; Restores original data to the Clinical History field in the
; Rad/Nuc Med Reports File. Global: ^RARPT( File #: 74
; Set ^RARPT('DA',"H") array to value in ^TMP($J,"RA Clin Hist")
N %X,%Y,Y
S %X="^TMP($J,""RA Clin Hist"",",%Y="^RARPT("_DA_",""H"","
D %XY^%RCR K ^TMP($J,"RA Clin Hist")
Q
CHSAVE ; Checks if word processing data exists called from [RA REPORT EDIT]
; and [RA PRE-VERIFY REPORT EDIT] templates. For the 'Clinical History'
; field.
; Save off existing text in a ^TMP global.
K ^TMP($J,"RA Clin Hist") N %X,%Y
S %X="^RARPT("_DA_",""H"",",%Y="^TMP($J,""RA Clin Hist"","
D %XY^%RCR
Q
CHPRINT ; Prints text from the 'Clinical History' field in file 70
; from [RA REPORT EDIT] template. Added with patch RA*5*27 - bnt
;
N DIR,DTOUT,DUOUT
D EN^DDIOL("CLINICAL HISTORY:")
S DIWL=1,DIWF="|WC75",RAV=0 K ^UTILITY($J,"W")
F S RAV=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"H",RAV)) Q:RAV'>0 D
. S X=^RADPT(RADFN,"DT",RADTI,"P",RACNI,"H",RAV,0)
. D ^DIWP
D ^DIWW S X=""
Q
OUTTEXT(X,DIWF,DIWL,DIWR,RAFMAT,RALFF,RATFF) ; Output generic text using DIWP
;INPUT VARIABLES:
; 'X' --> Text to be formatted 'DIWF' --> Format control data
; 'DIWL' --> Left margin 'DIWR' --> Right margin
; 'RAFMAT' --> Tabs for columns 'RALFF' --> Leading line feed
; 'RATFF' --> Trailing line feed
N DIW,DIWI,DIWT,DIWTC,DIWX,RALFMAT,RATFMAT,Y,Z
Q:X']"" S RAFMAT=+$G(RAFMAT)
S RALFF=$TR($G(RALFF),$G(RALFF),"!")
S RATFF=$TR($G(RATFF),$G(RATFF),"!")
S RALFMAT=RALFF_"?"_RAFMAT,RATFMAT=RATFF
K ^UTILITY($J,"W",DIWL) D ^DIWP
S Y=0 F S Y=$O(^UTILITY($J,"W",DIWL,Y)) Q:Y'>0 D
. S Y(0)=$G(^UTILITY($J,"W",DIWL,Y,0)) W @RALFMAT,Y(0)
. S Z=$O(^UTILITY($J,"W",DIWL,Y))
. W:RATFMAT]""&(Z>0) @RATFF
. Q
K ^UTILITY($J,"W")
Q
STOPCHK ; does user want to stop task?
I $$S^%ZTLOAD D
. S ZTSTOP=1 K ZTREQ
. W !?10,"*** OUTPUT STOPPED AT USER'S REQUEST ***"
. W !?10,"Option Name: ",$S($P($G(XQY0),"^")]"":$P($G(XQY0),"^"),1:"Unknown")
. W !?10,"Option Menu Text: ",$S($P($G(XQY0),"^",2)]"":$P($G(XQY0),"^",2),1:"Unknown")
. W !?10,"Task #: ",$S(+$G(ZTSK)>0:+$G(ZTSK),1:"Unknown")
. Q
Q
UPDTPNT(RAIEN) ; Remove the possibility of broken pointers when a report
; is deleted from the Rad/Nuc Med Reports file (74). This checks the
; following files: Report Batches file (74.2) and the
; Report Distribution file (74.4)
N A,B,DA,DIK
I $D(^RABTCH(74.2,"D",RAIEN)) D
. S A=0 F S A=$O(^RABTCH(74.2,"D",RAIEN,A)) Q:A'>0 D
.. S B=0 F S B=$O(^RABTCH(74.2,"D",RAIEN,A,B)) Q:B'>0 D
... S DA=B,DA(1)=A,DIK="^RABTCH(74.2,"_DA(1)_",""R"","
... D ^DIK K DA,DIK
... Q
.. Q
. Q
I $D(^RABTCH(74.4,"B",RAIEN)) D
. S A=0 F S A=$O(^RABTCH(74.4,"B",RAIEN,A)) Q:A'>0 D
.. S DA=A,DIK="^RABTCH(74.4," D ^DIK K DA,DIK
.. Q
. Q
Q
IARU ; Imaging Location allows released/unverified
S RATRUE=$S($P(^RA(79.1,+$P(^RADPT(RADFN,"DT",RADTI,0),U,4),0),U,17)="Y":1,1:0)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRAUTL9 6519 printed Apr 09, 2024@21:39:35 Page 2
RAUTL9 ;HISC/FPT-Utility Routines ;4/9/97 10:08
+1 ;;5.0;Radiology/Nuclear Medicine;**13,27,51**;Mar 16, 1998
EN1 ; allow lower & uppercase response to REPORT STATUS field
+1 ; called from [RA REPORT EDIT] & [RA VERIFY REPORT ONLY]
+2 ; " " routine UNVER+2^RARTE1
+3 ;
+4 NEW Y
KILL DIR,DIROUT,DIRUT,DTOUT,DUOUT
+5 ; RAMT=$S(Report status before edit="":0,1:1)
NEW RAMT
SET RAMT=0
+6 DO IARU
+7 IF RATRUE=1
SET DIR(0)="S^V:VERIFIED;R:RELEASED/NOT VERIFIED;PD:PROBLEM DRAFT;D:DRAFT"
+8 IF RATRUE=0
SET DIR(0)="S^V:VERIFIED;PD:PROBLEM DRAFT;D:DRAFT"
+9 SET DIR("A")="REPORT STATUS"
+10 if $PIECE(^RARPT(D0,0),"^",5)=""
SET RAMT=1
+11 if $PIECE(^RARPT(D0,0),"^",5)]""
SET DIR("B")=$PIECE(^RARPT(D0,0),"^",5)
+12 ; default to 'Draft' if missing report status
if RAMT
SET DIR("B")="D"
+13 DO ^DIR
KILL DIR,RATRUE
+14 IF $DATA(DIRUT)
IF (RAMT)
Begin DoDot:1
+15 SET $PIECE(^RARPT(D0,0),"^",5)="D"
DO ENSET^RAXREF(74,5,"D",D0)
+16 ; set Report Status to 'Draft' if originally null, and user times out
+17 ; or '^' out! Make sure xrefs are set!
+18 QUIT
End DoDot:1
+19 if $DATA(DIRUT)
QUIT
+20 IF $EXTRACT(Y)="V"
IF '$DATA(^XUSEC("RA VERIFY",DUZ))
WRITE !!,*7,"You do not have the appropriate privileges to verify a report."
GOTO EN1
+21 SET RASTATX=$EXTRACT(Y)
if RASTATX="P"
SET RASTATX="PD"
+22 QUIT
EN2 ; residents enter report status to pre-verify
+1 ; called from input templates [RA PRE-VERIFY REPORT EDIT] and [RA PRE-
+2 ; VERIFY REPORT ONLY]
+3 NEW Y
KILL DIR,DIROUT,DIRUT,DTOUT,DUOUT
+4 ; RAMT=$S(Report status before edit="":0,1:1)
NEW RAMT
SET RAMT=0
+5 DO IARU
+6 IF RATRUE=1
SET DIR(0)="S^R:RELEASED/NOT VERIFIED;PD:PROBLEM DRAFT;D:DRAFT"
+7 IF RATRUE=0
SET DIR(0)="S^PD:PROBLEM DRAFT;D:DRAFT"
+8 SET DIR("A")="RESIDENT PRE-VERIFICATION REPORT STATUS"
+9 if $PIECE(^RARPT(D0,0),"^",5)=""
SET RAMT=1
+10 if $PIECE(^RARPT(D0,0),"^",5)]""
SET DIR("B")=$PIECE(^RARPT(D0,0),"^",5)
+11 ; default to 'Draft' if missing report status
if RAMT
SET DIR("B")="D"
+12 DO ^DIR
KILL DIR,RATRUE
+13 IF $DATA(DIRUT)
IF (RAMT)
Begin DoDot:1
+14 SET $PIECE(^RARPT(D0,0),"^",5)="D"
DO ENSET^RAXREF(74,5,"D",D0)
+15 ; set Report Status to 'Draft' if originally null, and user times out
+16 ; or '^' out! Make sure xrefs are set!
+17 QUIT
End DoDot:1
+18 if $DATA(DIRUT)
QUIT
+19 SET RASTATX=$EXTRACT(Y)
if RASTATX="P"
SET RASTATX="PD"
+20 QUIT
EN3 ; residents pre-verify a report
+1 NEW Y
KILL DIR,DIROUT,DIRUT,DTOUT,DUOUT
+2 WRITE !
SET DIR(0)="Y"
SET DIR("A")="WANT TO PRE-VERIFY THIS REPORT"
+3 SET DIR("?")="Answer YES to mark this report as pre-verified. Your user ID number, electronic signature code and the current date/time will be stored in the pre-verification fields of this entry."
+4 DO ^DIR
KILL DIR
+5 WRITE !
if $DATA(DIRUT)
QUIT
+6 SET RAYN=+Y
+7 QUIT
EN4 ; re-display report text question
+1 NEW Y
KILL DIR,DIROUT,DIRUT,DTOUT,DUOUT
+2 SET DIR(0)="Y"
SET DIR("A")="Want to View the Report Text again"
DO ^DIR
KILL DIR
+3 WRITE !
if $DATA(DIRUT)
QUIT
+4 SET RAYN=Y
+5 QUIT
EXIST ; Checks if word processing data exists called from [RA REPORT EDIT]
+1 ; and [RA PRE-VERIFY REPORT EDIT] templates.
+2 IF RANODE="H"
IF (($DATA(DTOUT))!($DATA(DUOUT)))
Begin DoDot:1
+3 DO CHRSTOR
End DoDot:1
QUIT
+4 IF RANODE="R"
IF (($DATA(DTOUT))!($DATA(DUOUT)))
QUIT
+5 IF RANODE="I"
IF (($DATA(DTOUT))!($DATA(DUOUT)))
QUIT
+6 IF +$ORDER(^RARPT(DA,RANODE,0))
Begin DoDot:1
+7 NEW CNT,X,X1,X2,X3,X4,RAWPFLG
SET (RAWPFLG,X)=0
+8 FOR
SET X=$ORDER(^RARPT(DA,RANODE,X))
if X'>0
QUIT
Begin DoDot:2
+9 SET (CNT,X2)=0
+10 SET X1=$GET(^RARPT(DA,RANODE,X,0))
if X1']""
QUIT
+11 SET X2=$LENGTH(X1)
+12 FOR X3=1:1:X2
Begin DoDot:3
+13 SET X4=$EXTRACT(X1,X3)
if X4?1AN
SET CNT=CNT+1
+14 if X4'?1AN&(CNT>0)
SET CNT=0
+15 if CNT=2
SET RAWPFLG=1
+16 QUIT
End DoDot:3
if RAWPFLG
QUIT
+17 QUIT
End DoDot:2
if RAWPFLG
QUIT
+18 IF 'RAWPFLG
Begin DoDot:2
+19 SET Y=$SELECT(RANODE="H":"@1",RANODE="R":"@2",1:"@3")
+20 WRITE " ?? Invalid "
+21 WRITE $SELECT(RANODE="H":"Clinical History",RANODE="R":"Report",1:"Impression")
+22 WRITE " text.",$CHAR(7)
+23 ; Clear out bad WP
KILL ^RARPT(DA,RANODE)
+24 QUIT
End DoDot:2
+25 IF RANODE="H"
IF ('RAWPFLG)
DO CHRSTOR
+26 QUIT
End DoDot:1
QUIT
+27 QUIT
CHRSTOR ; Restores original data to the Clinical History field in the
+1 ; Rad/Nuc Med Reports File. Global: ^RARPT( File #: 74
+2 ; Set ^RARPT('DA',"H") array to value in ^TMP($J,"RA Clin Hist")
+3 NEW %X,%Y,Y
+4 SET %X="^TMP($J,""RA Clin Hist"","
SET %Y="^RARPT("_DA_",""H"","
+5 DO %XY^%RCR
KILL ^TMP($JOB,"RA Clin Hist")
+6 QUIT
CHSAVE ; Checks if word processing data exists called from [RA REPORT EDIT]
+1 ; and [RA PRE-VERIFY REPORT EDIT] templates. For the 'Clinical History'
+2 ; field.
+3 ; Save off existing text in a ^TMP global.
+4 KILL ^TMP($JOB,"RA Clin Hist")
NEW %X,%Y
+5 SET %X="^RARPT("_DA_",""H"","
SET %Y="^TMP($J,""RA Clin Hist"","
+6 DO %XY^%RCR
+7 QUIT
CHPRINT ; Prints text from the 'Clinical History' field in file 70
+1 ; from [RA REPORT EDIT] template. Added with patch RA*5*27 - bnt
+2 ;
+3 NEW DIR,DTOUT,DUOUT
+4 DO EN^DDIOL("CLINICAL HISTORY:")
+5 SET DIWL=1
SET DIWF="|WC75"
SET RAV=0
KILL ^UTILITY($JOB,"W")
+6 FOR
SET RAV=$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"H",RAV))
if RAV'>0
QUIT
Begin DoDot:1
+7 SET X=^RADPT(RADFN,"DT",RADTI,"P",RACNI,"H",RAV,0)
+8 DO ^DIWP
End DoDot:1
+9 DO ^DIWW
SET X=""
+10 QUIT
OUTTEXT(X,DIWF,DIWL,DIWR,RAFMAT,RALFF,RATFF) ; Output generic text using DIWP
+1 ;INPUT VARIABLES:
+2 ; 'X' --> Text to be formatted 'DIWF' --> Format control data
+3 ; 'DIWL' --> Left margin 'DIWR' --> Right margin
+4 ; 'RAFMAT' --> Tabs for columns 'RALFF' --> Leading line feed
+5 ; 'RATFF' --> Trailing line feed
+6 NEW DIW,DIWI,DIWT,DIWTC,DIWX,RALFMAT,RATFMAT,Y,Z
+7 if X']""
QUIT
SET RAFMAT=+$GET(RAFMAT)
+8 SET RALFF=$TRANSLATE($GET(RALFF),$GET(RALFF),"!")
+9 SET RATFF=$TRANSLATE($GET(RATFF),$GET(RATFF),"!")
+10 SET RALFMAT=RALFF_"?"_RAFMAT
SET RATFMAT=RATFF
+11 KILL ^UTILITY($JOB,"W",DIWL)
DO ^DIWP
+12 SET Y=0
FOR
SET Y=$ORDER(^UTILITY($JOB,"W",DIWL,Y))
if Y'>0
QUIT
Begin DoDot:1
+13 SET Y(0)=$GET(^UTILITY($JOB,"W",DIWL,Y,0))
WRITE @RALFMAT,Y(0)
+14 SET Z=$ORDER(^UTILITY($JOB,"W",DIWL,Y))
+15 if RATFMAT]""&(Z>0)
WRITE @RATFF
+16 QUIT
End DoDot:1
+17 KILL ^UTILITY($JOB,"W")
+18 QUIT
STOPCHK ; does user want to stop task?
+1 IF $$S^%ZTLOAD
Begin DoDot:1
+2 SET ZTSTOP=1
KILL ZTREQ
+3 WRITE !?10,"*** OUTPUT STOPPED AT USER'S REQUEST ***"
+4 WRITE !?10,"Option Name: ",$SELECT($PIECE($GET(XQY0),"^")]"":$PIECE($GET(XQY0),"^"),1:"Unknown")
+5 WRITE !?10,"Option Menu Text: ",$SELECT($PIECE($GET(XQY0),"^",2)]"":$PIECE($GET(XQY0),"^",2),1:"Unknown")
+6 WRITE !?10,"Task #: ",$SELECT(+$GET(ZTSK)>0:+$GET(ZTSK),1:"Unknown")
+7 QUIT
End DoDot:1
+8 QUIT
UPDTPNT(RAIEN) ; Remove the possibility of broken pointers when a report
+1 ; is deleted from the Rad/Nuc Med Reports file (74). This checks the
+2 ; following files: Report Batches file (74.2) and the
+3 ; Report Distribution file (74.4)
+4 NEW A,B,DA,DIK
+5 IF $DATA(^RABTCH(74.2,"D",RAIEN))
Begin DoDot:1
+6 SET A=0
FOR
SET A=$ORDER(^RABTCH(74.2,"D",RAIEN,A))
if A'>0
QUIT
Begin DoDot:2
+7 SET B=0
FOR
SET B=$ORDER(^RABTCH(74.2,"D",RAIEN,A,B))
if B'>0
QUIT
Begin DoDot:3
+8 SET DA=B
SET DA(1)=A
SET DIK="^RABTCH(74.2,"_DA(1)_",""R"","
+9 DO ^DIK
KILL DA,DIK
+10 QUIT
End DoDot:3
+11 QUIT
End DoDot:2
+12 QUIT
End DoDot:1
+13 IF $DATA(^RABTCH(74.4,"B",RAIEN))
Begin DoDot:1
+14 SET A=0
FOR
SET A=$ORDER(^RABTCH(74.4,"B",RAIEN,A))
if A'>0
QUIT
Begin DoDot:2
+15 SET DA=A
SET DIK="^RABTCH(74.4,"
DO ^DIK
KILL DA,DIK
+16 QUIT
End DoDot:2
+17 QUIT
End DoDot:1
+18 QUIT
IARU ; Imaging Location allows released/unverified
+1 SET RATRUE=$SELECT($PIECE(^RA(79.1,+$PIECE(^RADPT(RADFN,"DT",RADTI,0),U,4),0),U,17)="Y":1,1:0)
+2 QUIT
