- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RADD1.m
r613 r623 1 RADD1 ;HISC/FPT-Radiology Utility Routine ;6/2/98 16:17 2 ;;5.0;Radiology/Nuclear Medicine;**1,5,10,65**;Mar 16, 1998;Build 8 3 ; 4 ;Supported IA #10142 reference to EN^DDIOL 5 ;Supported IA #10103 reference to FMADD^XLFDT 6 ; 7 SECXREF ; sets/kills 'ARES' & 'ASTF' x-refs for secondary resident/staff rads 8 ; called from ^DD(74,5 9 ; 10 Q:'$D(^RARPT(DA,0)) S RADFNZ=^(0) 11 S RADTIZ=9999999.9999-$P(RADFNZ,"^",3),RACNIZ=$O(^RADPT(+$P(RADFNZ,"^",2),"DT",RADTIZ,"P","B",+$P(RADFNZ,"^",4),0)),RADFNZ=+$P(RADFNZ,"^",2) 12 I 'RACNIZ D KILL Q 13 I '$D(^RADPT(RADFNZ,"DT",RADTIZ,"P",RACNIZ,0)) D KILL Q 14 I '$D(^RADPT(RADFNZ,"DT",RADTIZ,"P",RACNIZ,RASECOND,0)) D KILL Q 15 S RASECIEN=0 16 F S RASECIEN=$O(^RADPT(RADFNZ,"DT",RADTIZ,"P",RACNIZ,RASECOND,RASECIEN)) Q:RASECIEN<1 S RARAD=+$P($G(^(RASECIEN,0)),"^",1) I RARAD>0 D 17 .S:$D(RASET) ^RARPT(RAXREF,RARAD,DA)="" K:$D(RAKILL) ^RARPT(RAXREF,RARAD,DA) 18 D XSEC^RAUTL20 19 KILL K RACNIZ,RADFNZ,RADTIZ,RASECOND,RASECIEN 20 Q 21 SCDTC ; status change date/time check 22 ; called from ^DD(70.05,.01 23 ; if X is a date/time prior to the exam date/time, then set Y=0. 24 ; if X is a over a minute in the future, then set Y=0. 25 ; if X is missing the time portion, then set Y=0. 26 I '($D(X)#2) Q 27 I '$F(X,".") D EN^DDIOL("** Time is Required **","","!!?20") S Y=0 Q 28 N RASTATUS,RAORDNUM,RAPLUS1 29 ; eg. da(3)=1128, da(2)=7028970.8743,da(1)=1,da=1 30 S RASTATUS=$P($G(^RADPT(+$G(DA(3)),"DT",+$G(DA(2)),"P",+$G(DA(1)),0)),U,3) 31 S RAORDNUM=$P($G(^RA(72,+RASTATUS,0)),U,3) 32 I X<(9999999.9999-$G(DA(2))),RAORDNUM>1 S Y=0 Q 33 S RADTHOLD=X 34 D NOW^%DTC 35 ; 2/25/98 allow entry to be at most 1 minute after current time 36 S RAPLUS1=%,RAPLUS1=$$FMADD^XLFDT(RAPLUS1,0,0,1,0) 37 I RADTHOLD>RAPLUS1 S Y=0 38 S X=RADTHOLD 39 K RADTHOLD 40 Q 41 PDC() ; do not enter secondary into primary diagnostic code field 42 ; called from ^DD(70.03,13,0) 43 ; do not select inactive diagnostic code 12/23/96 44 I $P(^RA(78.3,+Y,0),U,5)="Y" Q 0 45 I $D(^RADPT(DA(2),"DT",DA(1),"P",DA,"DX","B",+Y)) Q 0 46 Q 1 47 SDC() ; do not enter primary into secondary diagnostic code field 48 ; called from ^DD(70.14,.01,0) 49 ; do not select inactive diagnostic code 12/23/96 50 I $P(^RA(78.3,+Y,0),U,5)="Y" Q 0 51 I '$D(X)!('$D(DA(3))) G SDC2 52 I '$D(^RADPT(DA(3),"DT",DA(2),"P",DA(1),0)) G SDC2 53 I $P(^RADPT(DA(3),"DT",DA(2),"P",DA(1),0),"^",13)=+Y Q 0 54 Q 1 55 SDC2 ; 56 I '$D(X)!('$D(DA(2))) G SDC3 57 I '$D(^RADPT(DA(2),"DT",DA(1),"P",DA,0)) Q 0 58 I $P(^RADPT(DA(2),"DT",DA(1),"P",DA,0),"^",13)=+Y Q 0 59 Q 1 60 SDC3 ; 61 I '$D(RADFN) Q 0 62 S DA(2)=RADFN 63 I '$D(^RADPT(DA(2),"DT",DA(1),"P",DA,0)) Q 0 64 I $P(^RADPT(DA(2),"DT",DA(1),"P",DA,0),"^",13)=+Y Q 0 65 Q 1 66 NODEL ; no deletion of primary dx code, primary resident or staff if there 67 ; is a secondary 68 S RASECCHK=0,RASECCHK=$O(^RADPT(DA(2),"DT",DA(1),"P",DA,RAMULT,RASECCHK)) 69 I RASECCHK W " Required" 70 K RAMULT,RASECCHK 71 Q 72 PRCCPT() ; Displays the procedure type and CPT code if applicable. 73 ; This code is called from ^DD(71,0,"ID","WRITE") and rtn RAPROD 74 N RA,RATXT S RA(0)=$G(^(0)),RA("I")=+$G(^("I")),RATXT="" 75 S RA=$S('RA("I"):0,DT'>RA("I"):0,1:1) 76 S RA(6)=$P(RA(0),U,6),RA(9)=$P(RA(0),U,9) 77 S RA(12)=$P(RA(0),U,12) I 'RA(12) S RA(10)="UNKN " 78 I '$D(RA(10)) S RA(10)=$P(^RA(79.2,+RA(12),0),U,3)_" " 79 I $L(RA(10))<5 F S RA(10)=RA(10)_" " Q:$L(RA(10))>4 80 S RATXT="("_RA(10)_$S(RA:"Inactive",RA(6)="B":"Broad ",RA(6)="D":"Detailed",RA(6)="P":"Parent ",RA(6)="S":"Series ",1:"Unknown ")_")" 81 S:RA(9)]"" RATXT=RATXT_" CPT:"_$P($$NAMCODE^RACPTMSC(RA(9),DT),"^") 82 Q RATXT 83 INDTCHK(RADA) ; Cannot inactivate a procedure if it is a common procedure 84 ; with a valid sequence number. Code resides in ^DD(71,100,0)! 85 ; 'RADA' is the ien of the procedure in file 71. if this procedure is 86 ; a common procedure i.e, $D(^RAMIS(71.3,"B",RADA)) inform the user that 87 ; the sequence number must be deleted. This relies on the "AA" xref in 88 ; the Common Proc. file for the Sequence # fld (#3) 0 node, 4th pce. 89 N RA,RAIEN S RAIEN=+$O(^RAMIS(71.3,"B",RADA,0)) 90 S RA(0)=$G(^RAMIS(71.3,RAIEN,0)) Q:RA(0)']"" 91 S RA(4)=+$P(RA(0),"^",4) ; obtain the sequence number 92 I $D(^RAMIS(71.3,"AA",$$EN3^RAUTL17(RADA),RA(4),RAIEN)) D ; sequence #? 93 . N RATXT S RATXT(1)=" " 94 . S RATXT(2)=" Cannot inactivate - this procedure is currently in the" 95 . S RATXT(3)=" Rad/Nuc Med Common Procedure file with a sequence" 96 . S RATXT(4)=" number. Please remove the sequence number thru the" 97 . S RATXT(5)=" 'Common Procedure Enter/Edit' option before assigning" 98 . S RATXT(6)=" an inactivation date to this procedure." 99 . S RATXT(7)=" " 100 . D EN^DDIOL(.RATXT) K X ; display message, can't input ANY date! 101 . Q 102 Q 103 CPTCHK(RADA) ; Check if the CPT code is inactive nationally. 104 ; 'RADA' assume the value of +Y passed from the input xform, ^DD(71,9,0) 105 ; quit if CPT code is active 106 ; 107 Q:$$ACTCODE^RACPTMSC(RADA,DT) 108 N RATXT S RATXT(1)=" " 109 S RATXT(2)=" Warning - Nationally inactive CPT code." 110 S RATXT(3)=" " D EN^DDIOL(.RATXT) 111 K X 112 Q 113 ; 114 VALADM(RAD0,Y,RADT,RAUTH) ;edit validation 115 ;Used to validate/screen radiopharm dosage administrator, 116 ; radiopharm prescribing phys, person who measured radiopharm dose, 117 ;---------------------------------------------------------------------- 118 ; RAD0 : IEN of entry in question for NUC MED EXAM DATA (70.2) file 119 ; Y : Pointer to the New Person file 120 ; RADT : Xam Date; if not passed, calculate exam date from file 70.2 121 ; RAUTH : 1 - only staff/resid, must be auth'zd to write med orders 122 ; : 0 - staff/resid & tech's 123 ;---------------------------------------------------------------------- 124 ; Output: '1' authorized to write med orders, else '0' 125 ;---------------------------------------------------------------------- 126 Q $$VALADM^RADD4() 127 ; 128 VOL(RAX) ; Validate the format of the value input for volume. 129 ; RAX must be a number followed by a space then text -or- 130 ; a number followed by text 131 ; Input Variable : 'RAX'- user's input 132 ; Output Variable: null if 'RAX' erroneous, formatted version of 'RAX' 133 Q $$VOL^RADD4() 1 RADD1 ;HISC/FPT-Radiology Utility Routine ;6/2/98 16:17 2 ;;5.0;Radiology/Nuclear Medicine;**1,5,10**;Mar 16, 1998 3 SECXREF ; sets/kills 'ARES' & 'ASTF' x-refs for secondary resident/staff rads 4 ; called from ^DD(74,5 5 ; 6 Q:'$D(^RARPT(DA,0)) S RADFNZ=^(0) 7 S RADTIZ=9999999.9999-$P(RADFNZ,"^",3),RACNIZ=$O(^RADPT(+$P(RADFNZ,"^",2),"DT",RADTIZ,"P","B",+$P(RADFNZ,"^",4),0)),RADFNZ=+$P(RADFNZ,"^",2) 8 I 'RACNIZ D KILL Q 9 I '$D(^RADPT(RADFNZ,"DT",RADTIZ,"P",RACNIZ,0)) D KILL Q 10 I '$D(^RADPT(RADFNZ,"DT",RADTIZ,"P",RACNIZ,RASECOND,0)) D KILL Q 11 S RASECIEN=0 12 F S RASECIEN=$O(^RADPT(RADFNZ,"DT",RADTIZ,"P",RACNIZ,RASECOND,RASECIEN)) Q:RASECIEN<1 S RARAD=+$P($G(^(RASECIEN,0)),"^",1) I RARAD>0 D 13 .S:$D(RASET) ^RARPT(RAXREF,RARAD,DA)="" K:$D(RAKILL) ^RARPT(RAXREF,RARAD,DA) 14 D XSEC^RAUTL20 15 KILL K RACNIZ,RADFNZ,RADTIZ,RASECOND,RASECIEN 16 Q 17 SCDTC ; status change date/time check 18 ; called from ^DD(70.05,.01 19 ; if X is a date/time prior to the exam date/time, then set Y=0. 20 ; if X is a over a minute in the future, then set Y=0. 21 ; if X is missing the time portion, then set Y=0. 22 I '($D(X)#2) Q 23 I '$F(X,".") D EN^DDIOL("** Time is Required **","","!!?20") S Y=0 Q 24 N RASTATUS,RAORDNUM,RAPLUS1 25 ; eg. da(3)=1128, da(2)=7028970.8743,da(1)=1,da=1 26 S RASTATUS=$P($G(^RADPT(+$G(DA(3)),"DT",+$G(DA(2)),"P",+$G(DA(1)),0)),U,3) 27 S RAORDNUM=$P($G(^RA(72,+RASTATUS,0)),U,3) 28 I X<(9999999.9999-$G(DA(2))),RAORDNUM>1 S Y=0 Q 29 S RADTHOLD=X 30 D NOW^%DTC 31 ; 2/25/98 allow entry to be at most 1 minute after current time 32 S RAPLUS1=%,RAPLUS1=$$FMADD^XLFDT(RAPLUS1,0,0,1,0) 33 I RADTHOLD>RAPLUS1 S Y=0 34 S X=RADTHOLD 35 K RADTHOLD 36 Q 37 PDC() ; do not enter secondary into primary diagnostic code field 38 ; called from ^DD(70.03,13,0) 39 ; do not select inactive diagnostic code 12/23/96 40 I $P(^RA(78.3,+Y,0),U,5)="Y" Q 0 41 I $D(^RADPT(DA(2),"DT",DA(1),"P",DA,"DX","B",+Y)) Q 0 42 Q 1 43 SDC() ; do not enter primary into secondary diagnostic code field 44 ; called from ^DD(70.14,.01,0) 45 ; do not select inactive diagnostic code 12/23/96 46 I $P(^RA(78.3,+Y,0),U,5)="Y" Q 0 47 I '$D(X)!('$D(DA(3))) G SDC2 48 I '$D(^RADPT(DA(3),"DT",DA(2),"P",DA(1),0)) G SDC2 49 I $P(^RADPT(DA(3),"DT",DA(2),"P",DA(1),0),"^",13)=+Y Q 0 50 Q 1 51 SDC2 ; 52 I '$D(X)!('$D(DA(2))) G SDC3 53 I '$D(^RADPT(DA(2),"DT",DA(1),"P",DA,0)) Q 0 54 I $P(^RADPT(DA(2),"DT",DA(1),"P",DA,0),"^",13)=+Y Q 0 55 Q 1 56 SDC3 ; 57 I '$D(RADFN) Q 0 58 S DA(2)=RADFN 59 I '$D(^RADPT(DA(2),"DT",DA(1),"P",DA,0)) Q 0 60 I $P(^RADPT(DA(2),"DT",DA(1),"P",DA,0),"^",13)=+Y Q 0 61 Q 1 62 NODEL ; no deletion of primary dx code, primary resident or staff if there 63 ; is a secondary 64 S RASECCHK=0,RASECCHK=$O(^RADPT(DA(2),"DT",DA(1),"P",DA,RAMULT,RASECCHK)) 65 I RASECCHK W " Required" 66 K RAMULT,RASECCHK 67 Q 68 PRCCPT() ; Displays the procedure type and CPT code if applicable. 69 ; This code is called from ^DD(71,0,"ID","WRITE") and rtn RAPROD 70 N RA,RATXT S RA(0)=$G(^(0)),RA("I")=+$G(^("I")),RATXT="" 71 S RA=$S('RA("I"):0,DT'>RA("I"):0,1:1) 72 S RA(6)=$P(RA(0),U,6),RA(9)=$P(RA(0),U,9) 73 S RA(12)=$P(RA(0),U,12) I 'RA(12) S RA(10)="UNKN " 74 I '$D(RA(10)) S RA(10)=$P(^RA(79.2,+RA(12),0),U,3)_" " 75 I $L(RA(10))<5 F S RA(10)=RA(10)_" " Q:$L(RA(10))>4 76 S RATXT="("_RA(10)_$S(RA:"Inactive",RA(6)="B":"Broad ",RA(6)="D":"Detailed",RA(6)="P":"Parent ",RA(6)="S":"Series ",1:"Unknown ")_")" 77 S:RA(9)]"" RATXT=RATXT_" CPT:"_$P($$NAMCODE^RACPTMSC(RA(9),DT),"^") 78 Q RATXT 79 INDTCHK(RADA) ; Cannot inactivate a procedure if it is a common procedure 80 ; with a valid sequence number. Code resides in ^DD(71,100,0)! 81 ; 'RADA' is the ien of the procedure in file 71. if this procedure is 82 ; a common procedure i.e, $D(^RAMIS(71.3,"B",RADA)) inform the user that 83 ; the sequence number must be deleted. This relies on the "AA" xref in 84 ; the Common Proc. file for the Sequence # fld (#3) 0 node, 4th pce. 85 N RA,RAIEN S RAIEN=+$O(^RAMIS(71.3,"B",RADA,0)) 86 S RA(0)=$G(^RAMIS(71.3,RAIEN,0)) Q:RA(0)']"" 87 S RA(4)=+$P(RA(0),"^",4) ; obtain the sequence number 88 I $D(^RAMIS(71.3,"AA",$$EN3^RAUTL17(RADA),RA(4),RAIEN)) D ; sequence #? 89 . N RATXT S RATXT(1)=" " 90 . S RATXT(2)=" Cannot inactivate - this procedure is currently in the" 91 . S RATXT(3)=" Rad/Nuc Med Common Procedure file with a sequence" 92 . S RATXT(4)=" number. Please remove the sequence number thru the" 93 . S RATXT(5)=" 'Common Procedure Enter/Edit' option before assigning" 94 . S RATXT(6)=" an inactivation date to this procedure." 95 . S RATXT(7)=" " 96 . D EN^DDIOL(.RATXT) K X ; display message, can't input ANY date! 97 . Q 98 Q 99 CPTCHK(RADA) ; Check if the CPT code is inactive nationally. 100 ; 'RADA' assume the value of +Y passed from the input xform, ^DD(71,9,0) 101 ; quit if CPT code is active 102 ; 103 Q:$$ACTCODE^RACPTMSC(RADA,DT) 104 N RATXT S RATXT(1)=" " 105 S RATXT(2)=" Warning - Nationally inactive CPT code." 106 S RATXT(3)=" " D EN^DDIOL(.RATXT) 107 K X 108 Q 109 DCHK(RADG,RADT,Y) ; Check if drug if DRUG is active AND a Radiopharmaceu- 110 ; tical. 111 ; 'RASTAT=1' if active AND RADG condition met 112 ; 'RASTAT=0' if inactive OR RADG condition not met 113 ; VERSION 5.0 called from ^DD(70.21,.01,12.1) 114 ; 'Y' is the IEN for the Drug file 115 ; 'RADT' is the cutoff date for drugs in the drug file 116 ; 'RADG':$S(RADG="R":Radiopharm,"P":non-Radioharm,1:non-Radiopharm) 117 Q $$DCHK^RADD4() 118 ; 119 VALADM(RAD0,Y,RADT,RAUTH) ;edit validation 120 ;Used to validate/screen radiopharm dosage administrator, 121 ; radiopharm prescribing phys, person who measured radiopharm dose, 122 ;---------------------------------------------------------------------- 123 ; RAD0 : IEN of entry in question for NUC MED EXAM DATA (70.2) file 124 ; Y : Pointer to the New Person file 125 ; RADT : Xam Date; if not passed, calculate exam date from file 70.2 126 ; RAUTH : 1 - only staff/resid, must be auth'zd to write med orders 127 ; : 0 - staff/resid & tech's 128 ;---------------------------------------------------------------------- 129 ; Output: '1' authorized to write med orders, else '0' 130 ;---------------------------------------------------------------------- 131 Q $$VALADM^RADD4() 132 ; 133 VOL(RAX) ; Validate the format of the value input for volume. 134 ; RAX must be a number followed by a space then text -or- 135 ; a number followed by text 136 ; Input Variable : 'RAX'- user's input 137 ; Output Variable: null if 'RAX' erroneous, formatted version of 'RAX' 138 Q $$VOL^RADD4()
Note:
See TracChangeset
for help on using the changeset viewer.
