- 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 Jan 18, 2025@03:41:34 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