Ignore:
Timestamp:
Dec 4, 2009, 12:11:15 AM (15 years ago)
Author:
George Lilly
Message:

revised back to 6/30/08 version

File:
1 edited

Legend:

Unmodified
Added
Removed
  • WorldVistAEHR/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAMAIN2.m

    r613 r623  
    1 RAMAIN2 ;HISC/GJC-Radiology Utility File Maintenance (Part Two) ;8/15/05 10:07am
    2         ;;5.0;Radiology/Nuclear Medicine;**45,62,71,65**;Mar 16, 1998;Build 8
    3         ; 08/12/2005 bay/kam Remedy Call 104630 Patch 62
    4         ; 03/02/2006 BAY/KAM Remedy Call 131482 Patch RA*5*71
    5         ;
    6         ;Supported IA #10141 reference to MES^XPDUTL
    7         ;Supported IA #10142 reference to EN^DDIOL
    8         ;Supported IA #10103 reference to DT^XLFDT
    9         ;
    10 2       ;;Procedure Enter/Edit
    11         ; *** This subroutine once resided in RAMAIN i.e, '2^RAMAIN'. ***
    12         ; RA PROCEDURE option
    13         N RACTIVE,RAENALL,RAY,RAFILE,RASTAT,RAXIT
    14         S (RAENALL,RANEW71,RAXIT)=0
    15         N RADIO,RAPTY,RAASK,RAROUTE ;used by the edit template
    16         F  D  Q:$G(RAXIT)
    17         . K DA,DD,DIC,DINUM,DLAYGO,DO,RACMDIFF,RATRKCMA,RATRKCMB
    18         . S DIC="^RAMIS(71,",DIC(0)="QEAMLZ",DLAYGO=71,DIC("DR")=6
    19         . W ! D ^DIC K D,DD,DIC,DINUM,DLAYGO,DO
    20         . S:+Y<0 RAXIT=1 I $G(RAXIT) K D,X,Y Q
    21         . S (DA,RADA)=+Y,RAY=Y,RAFILE=71
    22         . ;RA*5*71 changed next line for Remedy Call 131482
    23         . S RANEW71=$S($P(Y,U,3)=1:1,1:0) ;used in template, edit CPT Code if new rec.
    24         . L +^RAMIS(RAFILE,RADA):5
    25         . I '$T D  Q
    26         .. W !?5,"This record is currently being edited by another user."
    27         .. W !?5,"Try again later!",$C(7) S RAXIT=1
    28         .. Q
    29         . S RAPNM=$P($G(Y(0)),U) ;proc. name for display purposes in template
    30         . S RACTIVE=$P($G(^RAMIS(71,RADA,"I")),"^")
    31         . S RASTAT=$S(RACTIVE="":1,RACTIVE>DT:1,1:0)
    32         . D TRKCMB^RAMAINU(DA,.RATRKCMB) ;tracks existing
    33         . ; CM definition before editing. RATRKCMB ids the before CM values
    34         . S DIE="^RAMIS(71,",DR="[RA PROCEDURE EDIT]" D ^DIE
    35         . K RAPNM S RAPROC(0)=$G(^RAMIS(71,RADA,0))
    36         . ;
    37         . ;check for data consistency between the 'CONTRAST MEDIA USED' &
    38         . ;'CONTRAST MEDIA' fields.
    39         . D CMINTEG^RAMAINU1(RADA,RAPROC(0))
    40         . ;
    41         . D TRKCMA^RAMAINU(RADA,RATRKCMB,.RATRKCMA,.RACMDIFF)
    42         . I $O(^RAMIS(71,RADA,"NUC",0)),($P(RAPROC(0),"^",2)=1) D DELRADE(RADA)
    43         . S RACTIVE=$P($G(^RAMIS(71,RADA,"I")),"^")
    44         . S RASTAT=RASTAT_"^"_$S(RACTIVE="":1,RACTIVE>DT:1,1:0)
    45         . ; 08/12/2005 104630 KAM - added '$G(RANEW71) to next line
    46         . I RAPROC(0)]"",("^B^P^"'[(U_$P(RAPROC(0),"^",6)_U)),('+$P(RAPROC(0),"^",9)),'+$G(RANEW71) D
    47         .. K %,C,D0,DE,DI,DIE,DQ,DR
    48         .. W !?5,$C(7),"...no CPT code entered..."
    49         .. W !?5,"...will change type to a 'broad' procedure.",!
    50         .. S DA=RADA,DIE="^RAMIS(71,",DR="6///B" D ^DIE
    51         .. Q
    52         . ;08/12/2005 104630 - KAM added next 5 lines
    53         . I RAPROC(0)]"",("^B^P^"'[(U_$P(RAPROC(0),"^",6)_U)),('+$P(RAPROC(0),"^",9)),+$G(RANEW71) D
    54         .. K %,C,D0,DE,DI,DIK,DQ,DR
    55         .. W !?5,$C(7),"...no CPT code entered..."
    56         .. W !?5,"...will delete the record at this time.",!
    57         .. S DIK="^RAMIS(71,",DA=RADA D ^DIK K DIK
    58         . ;if an active parent w/o descendants, inactivate the parent
    59         . I $P(RASTAT,U,2),($P(RAPROC(0),U,6)="P"),('$O(^RAMIS(71,RADA,4,0))) D
    60         .. K D,D0,D1,DA,DI,DIC,DIE,DQ,DR
    61         .. W !!?5,"Inactivating this parent procedure - no descendents.",!,$C(7)
    62         .. S DA=RADA,DIE="^RAMIS(71,",DR="100///"_$S($D(DT):DT,1:$$DT^XLFDT())
    63         .. D ^DIE K D,D0,D1,DA,DI,DIC,DIE,DQ,DR S $P(RASTAT,U,2)=0 ;inactive
    64         .. Q
    65         . I $P($G(^RA(79.2,+$P(RAPROC(0),U,12),0)),U,5)="Y",(+$O(^RAMIS(71,RADA,"NUC",0))) D VRDIO(RADA)
    66         . I "^B^P^"[(U_$P(RAPROC(0),U,6)_U),($P(RAPROC(0),U,9)]"") D
    67         .. K %,D,D0,DA,DE,DIC,DIE,DQ,DR
    68         .. S DA=RADA,DIE="^RAMIS(71,",DR="9///@" D ^DIE
    69         .. W !!?5,"...CPT code deleted because "_$S($P(RAPROC(0),U,6)="B":"Broad",1:"Parent")_" procedures",!?5,"should not have CPT codes.",!,$C(7)
    70         .. Q
    71         . K %,%X,%Y,C,D,D0,D1,DA,DE,DI,DIE,DQ,DR,RAIMAG,RAMIS,RAPROC,X,Y
    72         .;send Orderable Item HL7 msg to CPRS if the ORDER DIALOG (#101.41)
    73         .;file exists unconditionally
    74         .D:$$ORQUIK^RAORDU()=1 PROC^RAO7MFN(RAENALL,RAFILE,RASTAT,RAY)
    75         .;
    76         . L -^RAMIS(RAFILE,RADA) K RADA
    77         .;unconditionally update the parent procedure if the descendent
    78         .I $O(^RAMIS(71,"ADESC",+RAY,0)) D UPDATP^RAO7UTL(RAY)
    79         .;has been edited
    80         . Q
    81         K DIR,RACMDIFF,RATRKCMA,RATRKCMB
    82         S DIR(0)="YA",DIR("B")="NO"
    83         S DIR("A")="Want to run a validity check on CPT and stop codes? "
    84         S DIR("?",1)="Answer 'YES' to print a list of Radiology/Nuclear Medicine Procedures"
    85         S DIR("?",2)="with missing or invalid CPT's and/or Credit Clinic Stop Code(s)."
    86         S DIR("?",3)="Broad procedures with invalid codes are included for information"
    87         S DIR("?",4)="only.  Inactive procedures are not required to have valid codes."
    88         S DIR("?",5)="To be valid, Stop Codes must be in the Imaging Stop Codes file 71.5;"
    89         S DIR("?",6)="CPT's must be nationally active."
    90         S DIR("?")="Please answer 'YES' or 'NO'."
    91         W ! D ^DIR K DIR G:$D(DIRUT) EXIT
    92         D:Y ^RAPERR
    93 EXIT    K RADA,RANEW71,X,Y
    94         Q
    95 13      ;;Rad/Nuc Med Common Procedure File Enter/Edit
    96         ; RA COMMON PROCEDURE option
    97         N RADA,RAENALL,RAY,RAFILE,RALOW,RAMIS713,RASTAT,RAIMGTYI S RAENALL=0
    98         W ! D EN1^RAUTL17 G:Y'>0 Q13 S RAIMGTYI=Y
    99 131     S DIC="^RAMIS(71.3,",DIC(0)="AELMQZ",DLAYGO=71.3
    100         S DIC("S")="N RA S RA=+$P(^(0),U) I RAIMGTYI=$P($G(^RAMIS(71,RA,0)),U,12)"
    101         S DIC("W")="N RA4 S RA4=$P($G(^(0)),""^"",4) W:RA4]"""" ""   (""_RA4_"")"" W:RA4']"""" ""   (no sequence number)"""
    102         W ! D ^DIC K DIC,DLAYGO,D,X
    103         I Y<0 D Q13 G RESEQ
    104         ; If a sequence # exists, the Common Proc. is active
    105         S RADA=+Y,RAY=Y,RAFILE=71.3 L +^RAMIS(RAFILE,RADA):5
    106         I '$T D  G Q13
    107         . W !?5,"This record is currently being edited by another user."
    108         . W !?5,"Try again later!",$C(7)
    109         . Q
    110         S RASTAT=$S($P(Y(0),"^",4)]"":1,1:0)_"^"
    111         I '+$P(RASTAT,"^") S RALOW=$$LOW(RAIMGTYI)
    112         S DA=RADA,DIE="^RAMIS(71.3,",DR="[RA COMMON PROCEDURE EDIT]" D ^DIE
    113         S RAMIS713(0)=$G(^RAMIS(71.3,RADA,0))
    114         ; If the procedure is different than the one originally selected and
    115         ; the CPRS Order Dialog file exists, send the Orderable Item Update
    116         ; message to CPRS.
    117         I $P(RAMIS713(0),"^")'=$P(RAY,"^",2),($$ORQUIK^RAORDU()=1) D
    118         . S RASTAT=RASTAT_0 D PROC^RAO7MFN(RAENALL,RAFILE,RASTAT,RAY)
    119         . S RAY=RADA_"^"_$P($G(^RAMIS(71.3,RADA,0)),"^")_"^"_1,RASTAT=0_"^"
    120         . Q
    121         K %,%X,%Y,C,D,D0,DA,DE,DI,DIE,DQ,DR,X,Y
    122         S RASTAT=RASTAT_$S($P($G(^RAMIS(71.3,+RAY,0)),"^",4)]"":1,1:0)
    123         ; If before & after statuses differ, and the CPRS Order Dialog file
    124         ; exists, send the Orderable Item Update message to CPRS.
    125         I $$ORQUIK^RAORDU()=1,(($P(RASTAT,"^")+$P(RASTAT,"^",2))=1) D
    126         . D PROC^RAO7MFN(RAENALL,RAFILE,RASTAT,RAY)
    127         . Q
    128         L -^RAMIS(RAFILE,RADA)
    129         G 131
    130 Q13     K DDC,DDH,DISYS,I,POP,RA713
    131         Q
    132 RESEQ   ;Resequence the common procedure list
    133         N D,D0,DI,DQ,H,I,J,CNT,DIC,DIE,DR,DA,TXT,X
    134         I $D(XPDNM) D  ; if called during package install
    135         . S TXT(1)=" "
    136         . S TXT(2)="Resequencing the Rad/Nuc Med Common Procedure List."
    137         . Q
    138         E  W !!?5,"Resequencing the Rad/Nuc Med Common Procedure List"
    139         S DIE="^RAMIS(71.3,",(I,CNT)=0
    140         F  S I=$O(^RAMIS(71.3,"AA",RAIMGTYI,I)) Q:I'>0  D
    141         . S J=0
    142         . F  S J=$O(^RAMIS(71.3,"AA",RAIMGTYI,I,J)) Q:J'>0  I $D(^RAMIS(71.3,J,0)) D
    143         .. S DA=J,CNT=CNT+1 N I,J
    144         .. S DR="3////^S X=CNT" D ^DIE W:'$D(XPDNM) "."
    145         .. Q
    146         . Q
    147         I $D(XPDNM) D  ; if called during package install
    148         . S TXT(2)=$G(TXT(2))_"  Done!"
    149         . D MES^XPDUTL(.TXT)
    150         . Q
    151         E  W "  Done!"
    152         Q
    153 LOW(X)  ; Find the lowest available sequence number for a procedure within
    154         ; a specific Imaging Type.  Seq. #'s range from 1 to 40.  If the
    155         ; range changes in the DD i.e, ^DD(71.3,3, this code as well as the
    156         ; code if EN3^RAUTL18 must also be altered.
    157         ; If RAHIT is passed back as "", there is no available sequence number.
    158         N RA,RAHIT S RAHIT=""
    159         F RA=1:1:40 D  Q:RAHIT
    160         . Q:$D(^RAMIS(71.3,"AA",X,RA))
    161         . S:RAHIT="" RAHIT=RA
    162         . Q
    163         Q RAHIT
    164 VRDIO(RADA)     ; Validate the 'Usual Dose' field within the 'Default Radiopha-
    165         ; rmaceuticals' multiple.  'Usual Dose' must fall within the 'Low Adult
    166         ; Dose' & 'High Adult Dose' range.  This subroutine will display the
    167         ; Radiopharmaceutical in question along with the values in question if
    168         ; inconsistencies are found.
    169         ;
    170         ; Input Variable: 'RADA' the ien of the Procedure
    171         N RANUC S RADA(1)=RADA,RADA=0 D EN^DDIOL("","","!")
    172         F  S RADA=$O(^RAMIS(71,RADA(1),"NUC",RADA)) Q:RADA'>0  D
    173         . S RANUC(0)=$G(^RAMIS(71,RADA(1),"NUC",RADA,0))
    174         . Q:$P(RANUC(0),"^",2)=""  ; no need to validate, nothing input
    175         . I '$$USUAL^RADD2(.RADA,$P(RANUC(0),"^",2)) D
    176         .. N RARRY S RARRY(1)="For Radiopharmaceutical: "
    177         .. S RARRY(1)=RARRY(1)_$$EN1^RAPSAPI(+$P(RANUC(0),"^"),.01)_$C(7)
    178         .. S RARRY(2)="" D EN^DDIOL(.RARRY,"")
    179         .. Q
    180         . Q
    181         Q
    182 DELRADE(RADA)   ; Delete the Default Radiopharmaceuticals multiple
    183         N RADA1 S RADA1=0
    184         W !!?3,"Deleting default radiopharmaceuticals for this procedure...",!
    185         F  S RADA1=$O(^RAMIS(71,RADA,"NUC",RADA1)) Q:RADA1'>0  D
    186         . K %,%X,%Y,D,D0,DA,DI,DIC,DIE,DQ,DR,X,Y
    187         . S DA(1)=RADA,DA=RADA1,DIE="^RAMIS(71,"_RADA_",""NUC"","
    188         . S DR=".01///@" D ^DIE
    189         . Q
    190         K %,%X,%Y,D,D0,DA,DI,DIC,DIE,DQ,DR,X,Y
    191         Q
    192         ;
     1RAMAIN2 ;HISC/GJC-Radiology Utility File Maintenance (Part Two) ;8/15/05 10:07am
     2 ;;5.0;Radiology/Nuclear Medicine;**45,62,71**;Mar 16, 1998;Build 10
     3 ; 08/12/2005 bay/kam Remedy Call 104630 Patch 62
     4 ; 03/02/2006 BAY/KAM Remedy Call 131482 Patch RA*5*71
     52 ;;Procedure Enter/Edit
     6 ; *** This subroutine once resided in RAMAIN i.e, '2^RAMAIN'. ***
     7 ; RA PROCEDURE option
     8 N RACTIVE,RAENALL,RAY,RAFILE,RASTAT,RAXIT
     9 S (RAENALL,RANEW71,RAXIT)=0
     10 N RADIO,RAPTY,RAASK,RAROUTE ;used by the edit template
     11 F  D  Q:$G(RAXIT)
     12 . K DA,DD,DIC,DINUM,DLAYGO,DO,RACMDIFF,RATRKCMA,RATRKCMB
     13 . S DIC="^RAMIS(71,",DIC(0)="QEAMLZ",DLAYGO=71,DIC("DR")=6
     14 . W ! D ^DIC K D,DD,DIC,DINUM,DLAYGO,DO
     15 . S:+Y<0 RAXIT=1 I $G(RAXIT) K D,X,Y Q
     16 . S (DA,RADA)=+Y,RAY=Y,RAFILE=71
     17 . ;RA*5*71 changed next line for Remedy Call 131482
     18 . S RANEW71=$S($P(Y,U,3)=1:1,1:0) ;used in template, edit CPT Code if new rec.
     19 . L +^RAMIS(RAFILE,RADA):5
     20 . I '$T D  Q
     21 .. W !?5,"This record is currently being edited by another user."
     22 .. W !?5,"Try again later!",$C(7) S RAXIT=1
     23 .. Q
     24 . S RAPNM=$P($G(Y(0)),U) ;proc. name for display purposes in template
     25 . S RACTIVE=$P($G(^RAMIS(71,RADA,"I")),"^")
     26 . S RASTAT=$S(RACTIVE="":1,RACTIVE>DT:1,1:0)
     27 . D TRKCMB^RAMAINU(DA,.RATRKCMB) ;tracks existing
     28 . ; CM definition before editing. RATRKCMB ids the before CM values
     29 . S DIE="^RAMIS(71,",DR="[RA PROCEDURE EDIT]" D ^DIE
     30 . K RAPNM S RAPROC(0)=$G(^RAMIS(71,RADA,0))
     31 . ;
     32 . ;check for data consistency between the 'CONTRAST MEDIA USED' &
     33 . ;'CONTRAST MEDIA' fields.
     34 . D CMINTEG^RAMAINU1(RADA,RAPROC(0))
     35 . ;
     36 . D TRKCMA^RAMAINU(RADA,RATRKCMB,.RATRKCMA,.RACMDIFF)
     37 . I $O(^RAMIS(71,RADA,"NUC",0)),($P(RAPROC(0),"^",2)=1) D DELRADE(RADA)
     38 . S RACTIVE=$P($G(^RAMIS(71,RADA,"I")),"^")
     39 . S RASTAT=RASTAT_"^"_$S(RACTIVE="":1,RACTIVE>DT:1,1:0)
     40 . ; 08/12/2005 104630 KAM - added '$G(RANEW71) to next line
     41 . I RAPROC(0)]"",("^B^P^"'[(U_$P(RAPROC(0),"^",6)_U)),('+$P(RAPROC(0),"^",9)),'+$G(RANEW71) D
     42 .. K %,C,D0,DE,DI,DIE,DQ,DR
     43 .. W !?5,$C(7),"...no CPT code entered..."
     44 .. W !?5,"...will change type to a 'broad' procedure.",!
     45 .. S DA=RADA,DIE="^RAMIS(71,",DR="6///B" D ^DIE
     46 .. Q
     47 . ;08/12/2005 104630 - KAM added next 5 lines
     48 . I RAPROC(0)]"",("^B^P^"'[(U_$P(RAPROC(0),"^",6)_U)),('+$P(RAPROC(0),"^",9)),+$G(RANEW71) D
     49 .. K %,C,D0,DE,DI,DIK,DQ,DR
     50 .. W !?5,$C(7),"...no CPT code entered..."
     51 .. W !?5,"...will delete the record at this time.",!
     52 .. S DIK="^RAMIS(71,",DA=RADA D ^DIK K DIK
     53 . ;if an active parent w/o descendants, inactivate the parent
     54 . I $P(RASTAT,U,2),($P(RAPROC(0),U,6)="P"),('$O(^RAMIS(71,RADA,4,0))) D
     55 .. K D,D0,D1,DA,DI,DIC,DIE,DQ,DR
     56 .. W !!?5,"Inactivating this parent procedure - no descendents.",!,$C(7)
     57 .. S DA=RADA,DIE="^RAMIS(71,",DR="100///"_$S($D(DT):DT,1:$$DT^XLFDT())
     58 .. D ^DIE K D,D0,D1,DA,DI,DIC,DIE,DQ,DR S $P(RASTAT,U,2)=0 ;inactive
     59 .. Q
     60 . I $P($G(^RA(79.2,+$P(RAPROC(0),U,12),0)),U,5)="Y",(+$O(^RAMIS(71,RADA,"NUC",0))) D VRDIO(RADA)
     61 . I "^B^P^"[(U_$P(RAPROC(0),U,6)_U),($P(RAPROC(0),U,9)]"") D
     62 .. K %,D,D0,DA,DE,DIC,DIE,DQ,DR
     63 .. S DA=RADA,DIE="^RAMIS(71,",DR="9///@" D ^DIE
     64 .. W !!?5,"...CPT code deleted because "_$S($P(RAPROC(0),U,6)="B":"Broad",1:"Parent")_" procedures",!?5,"should not have CPT codes.",!,$C(7)
     65 .. Q
     66 . K %,%X,%Y,C,D,D0,D1,DA,DE,DI,DIE,DQ,DR,RAIMAG,RAMIS,RAPROC,X,Y
     67 .;send Orderable Item HL7 msg to CPRS if the ORDER DIALOG (#101.41)
     68 .;file exists unconditionally
     69 .D:$$ORQUIK^RAORDU()=1 PROC^RAO7MFN(RAENALL,RAFILE,RASTAT,RAY)
     70 .;
     71 . L -^RAMIS(RAFILE,RADA) K RADA
     72 .;unconditionally update the parent procedure if the descendent
     73 .I $O(^RAMIS(71,"ADESC",+RAY,0)) D UPDATP^RAO7UTL(RAY)
     74 .;has been edited
     75 . Q
     76 K DIR,RACMDIFF,RATRKCMA,RATRKCMB
     77 S DIR(0)="YA",DIR("B")="NO"
     78 S DIR("A")="Want to run a validity check on CPT and stop codes? "
     79 S DIR("?",1)="Answer 'YES' to print a list of Radiology/Nuclear Medicine Procedures"
     80 S DIR("?",2)="with missing or invalid CPT's and/or Credit Clinic Stop Code(s)."
     81 S DIR("?",3)="Broad procedures with invalid codes are included for information"
     82 S DIR("?",4)="only.  Inactive procedures are not required to have valid codes."
     83 S DIR("?",5)="To be valid, Stop Codes must be in the Imaging Stop Codes file 71.5;"
     84 S DIR("?",6)="CPT's must be nationally active."
     85 S DIR("?")="Please answer 'YES' or 'NO'."
     86 W ! D ^DIR K DIR G:$D(DIRUT) EXIT
     87 D:Y ^RAPERR
     88EXIT K RADA,RANEW71,X,Y
     89 Q
     9013 ;;Rad/Nuc Med Common Procedure File Enter/Edit
     91 ; RA COMMON PROCEDURE option
     92 N RADA,RAENALL,RAY,RAFILE,RALOW,RAMIS713,RASTAT,RAIMGTYI S RAENALL=0
     93 W ! D EN1^RAUTL17 G:Y'>0 Q13 S RAIMGTYI=Y
     94131 S DIC="^RAMIS(71.3,",DIC(0)="AELMQZ",DLAYGO=71.3
     95 S DIC("S")="N RA S RA=+$P(^(0),U) I RAIMGTYI=$P($G(^RAMIS(71,RA,0)),U,12)"
     96 S DIC("W")="N RA4 S RA4=$P($G(^(0)),""^"",4) W:RA4]"""" ""   (""_RA4_"")"" W:RA4']"""" ""   (no sequence number)"""
     97 W ! D ^DIC K DIC,DLAYGO,D,X
     98 I Y<0 D Q13 G RESEQ
     99 ; If a sequence # exists, the Common Proc. is active
     100 S RADA=+Y,RAY=Y,RAFILE=71.3 L +^RAMIS(RAFILE,RADA):5
     101 I '$T D  G Q13
     102 . W !?5,"This record is currently being edited by another user."
     103 . W !?5,"Try again later!",$C(7)
     104 . Q
     105 S RASTAT=$S($P(Y(0),"^",4)]"":1,1:0)_"^"
     106 I '+$P(RASTAT,"^") S RALOW=$$LOW(RAIMGTYI)
     107 S DA=RADA,DIE="^RAMIS(71.3,",DR="[RA COMMON PROCEDURE EDIT]" D ^DIE
     108 S RAMIS713(0)=$G(^RAMIS(71.3,RADA,0))
     109 ; If the procedure is different than the one originally selected and
     110 ; the CPRS Order Dialog file exists, send the Orderable Item Update
     111 ; message to CPRS.
     112 I $P(RAMIS713(0),"^")'=$P(RAY,"^",2),($$ORQUIK^RAORDU()=1) D
     113 . S RASTAT=RASTAT_0 D PROC^RAO7MFN(RAENALL,RAFILE,RASTAT,RAY)
     114 . S RAY=RADA_"^"_$P($G(^RAMIS(71.3,RADA,0)),"^")_"^"_1,RASTAT=0_"^"
     115 . Q
     116 K %,%X,%Y,C,D,D0,DA,DE,DI,DIE,DQ,DR,X,Y
     117 S RASTAT=RASTAT_$S($P($G(^RAMIS(71.3,+RAY,0)),"^",4)]"":1,1:0)
     118 ; If before & after statuses differ, and the CPRS Order Dialog file
     119 ; exists, send the Orderable Item Update message to CPRS.
     120 I $$ORQUIK^RAORDU()=1,(($P(RASTAT,"^")+$P(RASTAT,"^",2))=1) D
     121 . D PROC^RAO7MFN(RAENALL,RAFILE,RASTAT,RAY)
     122 . Q
     123 L -^RAMIS(RAFILE,RADA)
     124 G 131
     125Q13 K DDC,DDH,DISYS,I,POP,RA713
     126 Q
     127RESEQ ;Resequence the common procedure list
     128 N D,D0,DI,DQ,H,I,J,CNT,DIC,DIE,DR,DA,TXT,X
     129 I $D(XPDNM) D  ; if called during package install
     130 . S TXT(1)=" "
     131 . S TXT(2)="Resequencing the Rad/Nuc Med Common Procedure List."
     132 . Q
     133 E  W !!?5,"Resequencing the Rad/Nuc Med Common Procedure List"
     134 S DIE="^RAMIS(71.3,",(I,CNT)=0
     135 F  S I=$O(^RAMIS(71.3,"AA",RAIMGTYI,I)) Q:I'>0  D
     136 . S J=0
     137 . F  S J=$O(^RAMIS(71.3,"AA",RAIMGTYI,I,J)) Q:J'>0  I $D(^RAMIS(71.3,J,0)) D
     138 .. S DA=J,CNT=CNT+1 N I,J
     139 .. S DR="3////^S X=CNT" D ^DIE W:'$D(XPDNM) "."
     140 .. Q
     141 . Q
     142 I $D(XPDNM) D  ; if called during package install
     143 . S TXT(2)=$G(TXT(2))_"  Done!"
     144 . D MES^XPDUTL(.TXT)
     145 . Q
     146 E  W "  Done!"
     147 Q
     148LOW(X) ; Find the lowest available sequence number for a procedure within
     149 ; a specific Imaging Type.  Seq. #'s range from 1 to 40.  If the
     150 ; range changes in the DD i.e, ^DD(71.3,3, this code as well as the
     151 ; code if EN3^RAUTL18 must also be altered.
     152 ; If RAHIT is passed back as "", there is no available sequence number.
     153 N RA,RAHIT S RAHIT=""
     154 F RA=1:1:40 D  Q:RAHIT
     155 . Q:$D(^RAMIS(71.3,"AA",X,RA))
     156 . S:RAHIT="" RAHIT=RA
     157 . Q
     158 Q RAHIT
     159VRDIO(RADA) ; Validate the 'Usual Dose' field within the 'Default Radiopha-
     160 ; rmaceuticals' multiple.  'Usual Dose' must fall within the 'Low Adult
     161 ; Dose' & 'High Adult Dose' range.  This subroutine will display the
     162 ; Radiopharmaceutical in question along with the values in question if
     163 ; inconsistencies are found.
     164 ;
     165 ; Input Variable: 'RADA' the ien of the Procedure
     166 N RANUC S RADA(1)=RADA,RADA=0 D EN^DDIOL("","","!")
     167 F  S RADA=$O(^RAMIS(71,RADA(1),"NUC",RADA)) Q:RADA'>0  D
     168 . S RANUC(0)=$G(^RAMIS(71,RADA(1),"NUC",RADA,0))
     169 . Q:$P(RANUC(0),"^",2)=""  ; no need to validate, nothing input
     170 . I '$$USUAL^RADD2(.RADA,$P(RANUC(0),"^",2)) D
     171 .. N RARRY S RARRY(1)="For Radiopharmaceutical: "
     172 .. S RARRY(1)=RARRY(1)_$$GET1^DIQ(50,+$P(RANUC(0),"^")_",",.01)_$C(7)
     173 .. S RARRY(2)="" D EN^DDIOL(.RARRY,"")
     174 .. Q
     175 . Q
     176 Q
     177DELRADE(RADA) ; Delete the Default Radiopharmaceuticals multiple
     178 N RADA1 S RADA1=0
     179 W !!?3,"Deleting default radiopharmaceuticals for this procedure...",!
     180 F  S RADA1=$O(^RAMIS(71,RADA,"NUC",RADA1)) Q:RADA1'>0  D
     181 . K %,%X,%Y,D,D0,DA,DI,DIC,DIE,DQ,DR,X,Y
     182 . S DA(1)=RADA,DA=RADA1,DIE="^RAMIS(71,"_RADA_",""NUC"","
     183 . S DR=".01///@" D ^DIE
     184 . Q
     185 K %,%X,%Y,D,D0,DA,DI,DIC,DIE,DQ,DR,X,Y
     186 Q
     187 ;
Note: See TracChangeset for help on using the changeset viewer.