RAMAIN1 ;HISC/CAH,GJC-Radiology Utility File Maintenance ;10/29/97 13:30
;;5.0;Radiology/Nuclear Medicine;**15,21**;Mar 16, 1998
; This routine is a 'helper' routine for 'RAMAIN'.
DSPLNKS ; This subroutine display the links between the wasted/unwasted
; film size types. This subroutine is called from '4^RAMAIN'.
; This subroutine is only accessed if the '^RA(78.4,"AW")' xref
; exists.
N RA,RAFS,RAOUT,X,Y,Z S RAOUT=0
S X=0 F S X=$O(^RA(78.4,"AW",1,X)) Q:X'>0 D
. S RA(0)=$G(^RA(78.4,+X,0)) Q:RA(0)']""
. S RA(1)=$P(RA(0),U),RA(5)=+$P(RA(0),U,5)
. S RA(11)=$P($G(^RA(78.4,RA(5),0)),U)
. I RA(1)]"",(RA(11)]"") D
.. S RAFS("LW",RA(1))=RA(11),RAFS("LU",RA(11))=RA(1)
.. Q
. E D
.. S:RA(11)']"" RAFS("UW",RA(1))=""
.. Q
. Q
S X="" F S X=$O(^RA(78.4,"B",X)) Q:X']"" D
. I '$D(RAFS("LU",X))&('$D(RAFS("LW",X)))&('$D(RAFS("UW",X))) D
.. S RAFS("UU",X)=""
.. Q
. Q
I $D(RAFS("LU"))!($D(RAFS("UU")))!($D(RAFS("UW"))) D
. N X,Y,Y1,Z
. S X(1)="'Unwasted Film Size'",X(2)="'Corresponding Wasted Film Size'"
. S X(0)="Relationship between "_X(1)_" and "_X(2)_":"
. S $P(Y1,"-",($L(X(0))+1))="" D HDR(.X,Y1) ; Print out the list
. F Z(0)="LU","UU","UW" D Q:RAOUT
.. S Z="" F S Z=$O(RAFS(Z(0),Z)) Q:Z']""!(RAOUT) D
... I Z(0)="LU" D
.... W !?5,Z
.... W ?40,$S($G(RAFS(Z(0),Z))]"":$G(RAFS(Z(0),Z)),1:"Error, missing data")
.... Q
... I Z(0)="UU" D
.... W !?5,Z
.... W ?40,"unassociated with a 'Wasted Film' type"
.... Q
... I Z(0)="UW" D
.... W !?5,"*** Error, missing Data ***"
.... W ?40,Z
.... Q
... D:$Y>(IOSL-4) HDH
... Q
.. Q
. Q
I $G(RAOUT)=0 D:($Y>5) HDH
Q
HDH ; EOS prompt
S DIR(0)="E" D ^DIR K DIR,DIRUT,DIROUT,DTOUT,DUOUT
S:'+Y RAOUT=1 Q:RAOUT D:$D(X)\10&($D(Y1)) HDR(.X,Y1)
Q
HDR(X,Y1) ; Header
W @IOF,!?(IOM-$L($G(X(0)))\2),$G(X(0)),!
W !?5,$G(X(1)),?40,$G(X(2)),!?(IOM-$L(Y1)\2),Y1,!
Q
1 ; Set-up/Edit the Examination Status file (72).
N RADATE,RAHDR,RALINE,RANOERR,RAOUT,RAPG
S RADATE=$$FMTE^XLFDT($$DT^XLFDT(),"")
S RAHDR="Data Inconsistency Report For Exam Statuses"
S RANOERR="Exam Status Data Inconsistencies Not Found."
S $P(RALINE,"=",(IOM+1))="",(RAOUT,RAPG)=0
N RAIMGTYI,RAIMGTYJ,RAORDXST S RAORDXST=0
S DIC="^RA(79.2,",DIC(0)="QEAMNZ",DIC("A")="Select an Imaging Type: "
D ^DIC K DIC G:+Y'>0 Q1
; RAIMGTYI=ien of 79.2, RAIMGTYJ=xternal format of the .01
S RAOUT=0,RAIMGTYI=+Y,RAIMGTYJ=$P(Y,U,2)
F D Q:RAOUT
. K DINUM,DLAYGO,DO W !
. S DIC="^RA(72,",DIC(0)="QEALZ",DLAYGO=72
. S DIC("A")="Select an Examination Status: ",DIC("DR")="7////"_RAIMGTYI
. S DIC("S")="I +$P(^(0),U,7)=RAIMGTYI"
. S RADICW(1)="N RA S RA(0)=^(0),RA(3)=$P(RA(0),U,3) "
. S RADICW(2)="W ?35,""Imaging Type: "",?49,RAIMGTYJ"
. S RADICW(3)=",!?35,""Order: "",?42,RA(3)"
. S DIC("W")=RADICW(1)_RADICW(2)_RADICW(3)
. D ^DIC K DIC,DLAYGO,RADICW
. I +Y'>0 S RAOUT=1 Q
. W:$P(Y(0),U,3)=1 !!?5,"* Reminder * ",$P(Y,U,2)," does NOT need data entered for",!?7,"the 'ASK' and 'REQUIRED' fields. Registration automatically",!?7,"sets cases to this status since its ORDER number is 1.",!
. S (DA,RAXSTIEN)=+Y,DIE="^RA(72,",DR="[RA STATUS ENTRY]" D ^DIE
. I $D(DA) S RAEDT72=$G(^RA(72,DA,0)) I $P(RAEDT72,"^",3)="",$$UP^XLFSTR($P(RAEDT72,"^",5))="Y" D
.. W !!,"`"_$P(RAEDT72,"^")_"' is inactive, but appears on Status Tracking.",!,"This is appropriate if you need to use Status Tracking to process cases in"
.. W !,"this status to complete. However, if you have a large number of historic",!,"cases in this status, it will cause response time problems in Status Tracking."
.. Q
. K %,%X,%Y,C,D0,DA,DE,DI,DIE,DQ,DR,RAEDT72,RAEXST,X,Y
. Q
K %,DTOUT,DUOUT,RAOUT,RAXSTIEN,X,Y
N RADASH S $P(RADASH,"_",10)="",RADASH=" "_RADASH_" "
W @IOF
D XAMORD
S RAOUT=$$EOS^RAUTL5() Q:RAOUT
D PRELIM^RAUTL19(RAIMGTYJ) ; check data consistency
Q1 K C,D,DDH,DUOUT,I,POP,RAXSTIEN
Q
XAMORD ; check order number inconsistency for order # 0,1,9
I $Y>(IOSL-6) S RAOUT=$$EOS^RAUTL5() Q:RAOUT D HEAD^RAUTL11
W !!?$L(RADASH),"Checking order numbers",!,RADASH,"and Default Next Status used for status progression",RADASH,!?11,"within : ",RAIMGTYJ
S:'$D(RAOUT)#2 RAOUT=0
N I,J,RA0,RA2,RAORDXNM F I=0,1,9 D Q:RAOUT
. Q:($D(^RA(72,"AA",RAIMGTYJ,I))\10)
. N RASTAT S RAORDXST=1
. S RASTAT=$S(I=0:"Cancelled",I=1:"Waiting For Exam",1:"Complete")
. I $Y>(IOSL-6) S RAOUT=$$EOS^RAUTL5() Q:RAOUT D HEAD^RAUTL11
. W !!?5,"Error: A status with order number '"_I_"' to represent"
. I $Y>(IOSL-6) S RAOUT=$$EOS^RAUTL5() Q:RAOUT D HEAD^RAUTL11
. W !?5,"'"_RASTAT_"' is MISSING for this imaging type.",$C(7)
. I $Y>(IOSL-6) S RAOUT=$$EOS^RAUTL5() Q:RAOUT D HEAD^RAUTL11
; check that the DEFAULT NEXT STATUS has an ORDER no.
S I=0
F S I=$O(^RA(72,"AA",RAIMGTYJ,I)) Q:'I S J=$O(^(I,0)) I +J S RA0=^RA(72,J,0) D ;should always have subscript 5 ?
. Q:$P(RA0,U,3)=9 ;skip check if COMPLETE status
. S RA2=$G(^RA(72,+$P(RA0,U,2),0))
. I $Y>(IOSL-6) S RAOUT=$$EOS^RAUTL5() Q:RAOUT D HEAD^RAUTL11
. I RA2="" W !!?5,$P(RA0,U),"'s Default Next Status (",$P(RA2,U),")'s record is missing" S RAORDXST=1 I $Y>(IOSL-6) S RAOUT=$$EOS^RAUTL5() Q:RAOUT D HEAD^RAUTL11
. I $P(RA2,U,3)="" W !!?5,$P(RA0,U),"'s Default Next Status (",$P(RA2,U),") is missing an ORDER no." S RAORDXST=1 I $Y>(IOSL-6) S RAOUT=$$EOS^RAUTL5() Q:RAOUT D HEAD^RAUTL11
.Q
W:'RAORDXST !!?5,"Required order numbers are in place."
I $Y>(IOSL-6) S RAOUT=$$EOS^RAUTL5() Q:RAOUT D HEAD^RAUTL11
W !
; check that exam status 'COMPLETE','WAITING FOR EXAM' and
; 'CANCELLED' exist
I $Y>(IOSL-6) S RAOUT=$$EOS^RAUTL5() Q:RAOUT D HEAD^RAUTL11
W !!,RADASH_"Checking Exam Status names"_RADASH,!,?$L(RADASH),"within : ",RAIMGTYJ
S RAORDXNM=0 F I=0,1,9 D Q:RAOUT
. S J=$O(^RA(72,"AA",RAIMGTYJ,I,""))
. I I=0,($P(^RA(72,J,0),U)="CANCELLED") Q
. I I=1,($P(^RA(72,J,0),U)="WAITING FOR EXAM") Q
. I I=9,($P(^RA(72,J,0),U)="COMPLETE") Q
. I $Y>(IOSL-6) S RAOUT=$$EOS^RAUTL5() Q:RAOUT D HEAD^RAUTL11
. W !!?5,"Warning : The status with order number '"_I_"' was"
. I $Y>(IOSL-6) S RAOUT=$$EOS^RAUTL5() Q:RAOUT D HEAD^RAUTL11
. W !?5,"named '"_$S(I=0:"CANCELLED",I=1:"WAITING FOR EXAM",1:"COMPLETE")_"', but is now named '",$P(^RA(72,J,0),U),"'",$C(7)
. S RAORDXNM=1
Q:(RAOUT!RAORDXNM)
I $Y>(IOSL-6) S RAOUT=$$EOS^RAUTL5() Q:RAOUT D HEAD^RAUTL11
W !!?5,"Exam Status names check complete"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRAMAIN1 6451 printed Apr 09, 2024@21:37:26 Page 2
RAMAIN1 ;HISC/CAH,GJC-Radiology Utility File Maintenance ;10/29/97 13:30
+1 ;;5.0;Radiology/Nuclear Medicine;**15,21**;Mar 16, 1998
+2 ; This routine is a 'helper' routine for 'RAMAIN'.
DSPLNKS ; This subroutine display the links between the wasted/unwasted
+1 ; film size types. This subroutine is called from '4^RAMAIN'.
+2 ; This subroutine is only accessed if the '^RA(78.4,"AW")' xref
+3 ; exists.
+4 NEW RA,RAFS,RAOUT,X,Y,Z
SET RAOUT=0
+5 SET X=0
FOR
SET X=$ORDER(^RA(78.4,"AW",1,X))
if X'>0
QUIT
Begin DoDot:1
+6 SET RA(0)=$GET(^RA(78.4,+X,0))
if RA(0)']""
QUIT
+7 SET RA(1)=$PIECE(RA(0),U)
SET RA(5)=+$PIECE(RA(0),U,5)
+8 SET RA(11)=$PIECE($GET(^RA(78.4,RA(5),0)),U)
+9 IF RA(1)]""
IF (RA(11)]"")
Begin DoDot:2
+10 SET RAFS("LW",RA(1))=RA(11)
SET RAFS("LU",RA(11))=RA(1)
+11 QUIT
End DoDot:2
+12 IF '$TEST
Begin DoDot:2
+13 if RA(11)']""
SET RAFS("UW",RA(1))=""
+14 QUIT
End DoDot:2
+15 QUIT
End DoDot:1
+16 SET X=""
FOR
SET X=$ORDER(^RA(78.4,"B",X))
if X']""
QUIT
Begin DoDot:1
+17 IF '$DATA(RAFS("LU",X))&('$DATA(RAFS("LW",X)))&('$DATA(RAFS("UW",X)))
Begin DoDot:2
+18 SET RAFS("UU",X)=""
+19 QUIT
End DoDot:2
+20 QUIT
End DoDot:1
+21 IF $DATA(RAFS("LU"))!($DATA(RAFS("UU")))!($DATA(RAFS("UW")))
Begin DoDot:1
+22 NEW X,Y,Y1,Z
+23 SET X(1)="'Unwasted Film Size'"
SET X(2)="'Corresponding Wasted Film Size'"
+24 SET X(0)="Relationship between "_X(1)_" and "_X(2)_":"
+25 ; Print out the list
SET $PIECE(Y1,"-",($LENGTH(X(0))+1))=""
DO HDR(.X,Y1)
+26 FOR Z(0)="LU","UU","UW"
Begin DoDot:2
+27 SET Z=""
FOR
SET Z=$ORDER(RAFS(Z(0),Z))
if Z']""!(RAOUT)
QUIT
Begin DoDot:3
+28 IF Z(0)="LU"
Begin DoDot:4
+29 WRITE !?5,Z
+30 WRITE ?40,$SELECT($GET(RAFS(Z(0),Z))]"":$GET(RAFS(Z(0),Z)),1:"Error, missing data")
+31 QUIT
End DoDot:4
+32 IF Z(0)="UU"
Begin DoDot:4
+33 WRITE !?5,Z
+34 WRITE ?40,"unassociated with a 'Wasted Film' type"
+35 QUIT
End DoDot:4
+36 IF Z(0)="UW"
Begin DoDot:4
+37 WRITE !?5,"*** Error, missing Data ***"
+38 WRITE ?40,Z
+39 QUIT
End DoDot:4
+40 if $Y>(IOSL-4)
DO HDH
+41 QUIT
End DoDot:3
+42 QUIT
End DoDot:2
if RAOUT
QUIT
+43 QUIT
End DoDot:1
+44 IF $GET(RAOUT)=0
if ($Y>5)
DO HDH
+45 QUIT
HDH ; EOS prompt
+1 SET DIR(0)="E"
DO ^DIR
KILL DIR,DIRUT,DIROUT,DTOUT,DUOUT
+2 if '+Y
SET RAOUT=1
if RAOUT
QUIT
if $DATA(X)\10&($DATA(Y1))
DO HDR(.X,Y1)
+3 QUIT
HDR(X,Y1) ; Header
+1 WRITE @IOF,!?(IOM-$LENGTH($GET(X(0)))\2),$GET(X(0)),!
+2 WRITE !?5,$GET(X(1)),?40,$GET(X(2)),!?(IOM-$LENGTH(Y1)\2),Y1,!
+3 QUIT
1 ; Set-up/Edit the Examination Status file (72).
+1 NEW RADATE,RAHDR,RALINE,RANOERR,RAOUT,RAPG
+2 SET RADATE=$$FMTE^XLFDT($$DT^XLFDT(),"")
+3 SET RAHDR="Data Inconsistency Report For Exam Statuses"
+4 SET RANOERR="Exam Status Data Inconsistencies Not Found."
+5 SET $PIECE(RALINE,"=",(IOM+1))=""
SET (RAOUT,RAPG)=0
+6 NEW RAIMGTYI,RAIMGTYJ,RAORDXST
SET RAORDXST=0
+7 SET DIC="^RA(79.2,"
SET DIC(0)="QEAMNZ"
SET DIC("A")="Select an Imaging Type: "
+8 DO ^DIC
KILL DIC
if +Y'>0
GOTO Q1
+9 ; RAIMGTYI=ien of 79.2, RAIMGTYJ=xternal format of the .01
+10 SET RAOUT=0
SET RAIMGTYI=+Y
SET RAIMGTYJ=$PIECE(Y,U,2)
+11 FOR
Begin DoDot:1
+12 KILL DINUM,DLAYGO,DO
WRITE !
+13 SET DIC="^RA(72,"
SET DIC(0)="QEALZ"
SET DLAYGO=72
+14 SET DIC("A")="Select an Examination Status: "
SET DIC("DR")="7////"_RAIMGTYI
+15 SET DIC("S")="I +$P(^(0),U,7)=RAIMGTYI"
+16 SET RADICW(1)="N RA S RA(0)=^(0),RA(3)=$P(RA(0),U,3) "
+17 SET RADICW(2)="W ?35,""Imaging Type: "",?49,RAIMGTYJ"
+18 SET RADICW(3)=",!?35,""Order: "",?42,RA(3)"
+19 SET DIC("W")=RADICW(1)_RADICW(2)_RADICW(3)
+20 DO ^DIC
KILL DIC,DLAYGO,RADICW
+21 IF +Y'>0
SET RAOUT=1
QUIT
+22 if $PIECE(Y(0),U,3)=1
WRITE !!?5,"* Reminder * ",$PIECE(Y,U,2)," does NOT need data entered for",!?7,"the 'ASK' and 'REQUIRED' fields. Registration automatically",!?7,"sets cases to this status since its ORDER number is 1.",!
+23 SET (DA,RAXSTIEN)=+Y
SET DIE="^RA(72,"
SET DR="[RA STATUS ENTRY]"
DO ^DIE
+24 IF $DATA(DA)
SET RAEDT72=$GET(^RA(72,DA,0))
IF $PIECE(RAEDT72,"^",3)=""
IF $$UP^XLFSTR($PIECE(RAEDT72,"^",5))="Y"
Begin DoDot:2
+25 WRITE !!,"`"_$PIECE(RAEDT72,"^")_"' is inactive, but appears on Status Tracking.",!,"This is appropriate if you need to use Status Tracking to process cases in"
+26 WRITE !,"this status to complete. However, if you have a large number of historic",!,"cases in this status, it will cause response time problems in Status Tracking."
+27 QUIT
End DoDot:2
+28 KILL %,%X,%Y,C,D0,DA,DE,DI,DIE,DQ,DR,RAEDT72,RAEXST,X,Y
+29 QUIT
End DoDot:1
if RAOUT
QUIT
+30 KILL %,DTOUT,DUOUT,RAOUT,RAXSTIEN,X,Y
+31 NEW RADASH
SET $PIECE(RADASH,"_",10)=""
SET RADASH=" "_RADASH_" "
+32 WRITE @IOF
+33 DO XAMORD
+34 SET RAOUT=$$EOS^RAUTL5()
if RAOUT
QUIT
+35 ; check data consistency
DO PRELIM^RAUTL19(RAIMGTYJ)
Q1 KILL C,D,DDH,DUOUT,I,POP,RAXSTIEN
+1 QUIT
XAMORD ; check order number inconsistency for order # 0,1,9
+1 IF $Y>(IOSL-6)
SET RAOUT=$$EOS^RAUTL5()
if RAOUT
QUIT
DO HEAD^RAUTL11
+2 WRITE !!?$LENGTH(RADASH),"Checking order numbers",!,RADASH,"and Default Next Status used for status progression",RADASH,!?11,"within : ",RAIMGTYJ
+3 if '$DATA(RAOUT)#2
SET RAOUT=0
+4 NEW I,J,RA0,RA2,RAORDXNM
FOR I=0,1,9
Begin DoDot:1
+5 if ($DATA(^RA(72,"AA",RAIMGTYJ,I))\10)
QUIT
+6 NEW RASTAT
SET RAORDXST=1
+7 SET RASTAT=$SELECT(I=0:"Cancelled",I=1:"Waiting For Exam",1:"Complete")
+8 IF $Y>(IOSL-6)
SET RAOUT=$$EOS^RAUTL5()
if RAOUT
QUIT
DO HEAD^RAUTL11
+9 WRITE !!?5,"Error: A status with order number '"_I_"' to represent"
+10 IF $Y>(IOSL-6)
SET RAOUT=$$EOS^RAUTL5()
if RAOUT
QUIT
DO HEAD^RAUTL11
+11 WRITE !?5,"'"_RASTAT_"' is MISSING for this imaging type.",$CHAR(7)
+12 IF $Y>(IOSL-6)
SET RAOUT=$$EOS^RAUTL5()
if RAOUT
QUIT
DO HEAD^RAUTL11
End DoDot:1
if RAOUT
QUIT
+13 ; check that the DEFAULT NEXT STATUS has an ORDER no.
+14 SET I=0
+15 ;should always have subscript 5 ?
FOR
SET I=$ORDER(^RA(72,"AA",RAIMGTYJ,I))
if 'I
QUIT
SET J=$ORDER(^(I,0))
IF +J
SET RA0=^RA(72,J,0)
Begin DoDot:1
+16 ;skip check if COMPLETE status
if $PIECE(RA0,U,3)=9
QUIT
+17 SET RA2=$GET(^RA(72,+$PIECE(RA0,U,2),0))
+18 IF $Y>(IOSL-6)
SET RAOUT=$$EOS^RAUTL5()
if RAOUT
QUIT
DO HEAD^RAUTL11
+19 IF RA2=""
WRITE !!?5,$PIECE(RA0,U),"'s Default Next Status (",$PIECE(RA2,U),")'s record is missing"
SET RAORDXST=1
IF $Y>(IOSL-6)
SET RAOUT=$$EOS^RAUTL5()
if RAOUT
QUIT
DO HEAD^RAUTL11
+20 IF $PIECE(RA2,U,3)=""
WRITE !!?5,$PIECE(RA0,U),"'s Default Next Status (",$PIECE(RA2,U),") is missing an ORDER no."
SET RAORDXST=1
IF $Y>(IOSL-6)
SET RAOUT=$$EOS^RAUTL5()
if RAOUT
QUIT
DO HEAD^RAUTL11
+21 QUIT
End DoDot:1
+22 if 'RAORDXST
WRITE !!?5,"Required order numbers are in place."
+23 IF $Y>(IOSL-6)
SET RAOUT=$$EOS^RAUTL5()
if RAOUT
QUIT
DO HEAD^RAUTL11
+24 WRITE !
+25 ; check that exam status 'COMPLETE','WAITING FOR EXAM' and
+26 ; 'CANCELLED' exist
+27 IF $Y>(IOSL-6)
SET RAOUT=$$EOS^RAUTL5()
if RAOUT
QUIT
DO HEAD^RAUTL11
+28 WRITE !!,RADASH_"Checking Exam Status names"_RADASH,!,?$LENGTH(RADASH),"within : ",RAIMGTYJ
+29 SET RAORDXNM=0
FOR I=0,1,9
Begin DoDot:1
+30 SET J=$ORDER(^RA(72,"AA",RAIMGTYJ,I,""))
+31 IF I=0
IF ($PIECE(^RA(72,J,0),U)="CANCELLED")
QUIT
+32 IF I=1
IF ($PIECE(^RA(72,J,0),U)="WAITING FOR EXAM")
QUIT
+33 IF I=9
IF ($PIECE(^RA(72,J,0),U)="COMPLETE")
QUIT
+34 IF $Y>(IOSL-6)
SET RAOUT=$$EOS^RAUTL5()
if RAOUT
QUIT
DO HEAD^RAUTL11
+35 WRITE !!?5,"Warning : The status with order number '"_I_"' was"
+36 IF $Y>(IOSL-6)
SET RAOUT=$$EOS^RAUTL5()
if RAOUT
QUIT
DO HEAD^RAUTL11
+37 WRITE !?5,"named '"_$SELECT(I=0:"CANCELLED",I=1:"WAITING FOR EXAM",1:"COMPLETE")_"', but is now named '",$PIECE(^RA(72,J,0),U),"'",$CHAR(7)
+38 SET RAORDXNM=1
End DoDot:1
if RAOUT
QUIT
+39 if (RAOUT!RAORDXNM)
QUIT
+40 IF $Y>(IOSL-6)
SET RAOUT=$$EOS^RAUTL5()
if RAOUT
QUIT
DO HEAD^RAUTL11
+41 WRITE !!?5,"Exam Status names check complete"
+42 QUIT
