MCARAM3 ;WASH ISC/JKL-MUSE TRANSFER LAB DATA TO LOCAL ;5/2/96 12:49
;;2.3;Medicine;;09/13/1996
;
;
;Modules to return lab data in a local array
; USAGE: S X=$$L#^MCARAM3(.A,B) , where # = integer from 7 to 12
; WHERE: .A=local array into which data is placed
; B=1 line of lab data
; if unsuccessful, returns an error message
; if successful, returns a function value of 0 and a value array:
; MCA(field #) = value of field
; MCA("CONT") = diagnosis line # in alphabetic form
; MCA("DX,#") = line of diagnosis data
; MCA("DT") = date/time in FM format
;
L12(MCA,MCD) ;Returns Field 8 = P Axis, 9 = R Axis, 10 = T Axis,
; 12 = Interpreted By, Pointer to File 200
N MCERR
S MCERR=$$AR^MCARAM4(.MCA,8,MCD,11,15,3)
I +MCERR=2 K MCA(8) S MCERR=$$LOG^MCARAM7("2-P Axis is a null data field")
I +MCERR=1 K MCA(8) S MCERR=$$LOG^MCARAM7("1-P Axis not numeric")
I +MCERR>50 Q MCERR
S MCERR=$$AR^MCARAM4(.MCA,9,MCD,16,19,3)
I +MCERR=2 K MCA(9) S MCERR=$$LOG^MCARAM7("2-R Axis is a null data field")
I +MCERR=1 K MCA(9) S MCERR=$$LOG^MCARAM7("1-R Axis not numeric")
I +MCERR>50 Q MCERR
S MCERR=$$AR^MCARAM4(.MCA,10,MCD,20,31,3)
I +MCERR=2 K MCA(10) S MCERR=$$LOG^MCARAM7("2-T Axis is a null data field")
I +MCERR=1 K MCA(10) S MCERR=$$LOG^MCARAM7("1-T Axis not numeric")
I +MCERR>50 Q MCERR
I $$GRERR^MCARAM7(.MCA)=1 Q MCERR
S MCERR=$$AR^MCARAM4(.MCA,12,MCD,67,134) I +MCERR=2 K MCA(12) S MCERR=$$PROEFF^MCARAM3(MCA("DT"),MCERR) Q $$LOG^MCARAM7(MCERR)
I +MCERR>50 Q MCERR
S MCA(12)=$P(MCA(12),": ",2) I MCA(12)="" K MCA(12) S MCERR=$$PROEFF^MCARAM3(MCA("DT"),MCERR) Q $$LOG^MCARAM7(MCERR)
N MCPH S MCPH=MCA(12),MCERR=$$SLTS^MCARAM4(.MCPH),MCA(12)=MCPH K MCPH
I +MCERR=2 K MCA(12) S MCERR=$$PROEFF^MCARAM3(MCA("DT"),MCERR) Q $$LOG^MCARAM7(MCERR)
I MCA(12)["/",MCA(12)'[" " S MCA(12)=$P(MCA(12),"/")
I MCA(12)["/" N MCA12 S MCA(12)=$P(MCA(12),"/") F MCA12=$L(MCA(12)):-1:1 I $E(MCA(12),MCA12)=" " S MCA(12)=$E(MCA(12),(MCA12+1),$L(MCA(12))) Q
S:MCA(12)[" M.D.," MCA(12)=$P(MCA(12)," M.D.",1)_$P(MCA(12),"M.D.",2,99)
S:MCA(12)[" M.D." MCA(12)=$P(MCA(12)," M.D.",1)_","_$P(MCA(12),"M.D. ",2,99)
S:MCA(12)[" MD " MCA(12)=$P(MCA(12)," MD",1)_","_$P(MCA(12),"MD ",2,99)
I $D(^VA(200,"B",MCA(12))) S MCA(12)=$O(^(MCA(12),0)) Q 0
;allow a match between DHCP provider name length and instrument name length
N MCNAM,MCFNAM,MCLNAM,MC12NAM,MC12FNAM,MC12LNAM
S MC12LNAM=$P(MCA(12),","),MC12FNAM=$P(MCA(12),",",2,99)
I $E(MC12FNAM)=" " S MC12FNAM=$E(MC12FNAM,2,$L(MC12FNAM))
S (MC12LNAM,MCLNAM)=$E(MC12LNAM,1,7),(MC12FNAM,MCFNAM)=$E(MC12FNAM,1,3)
S (MC12NAM,MCNAM)=MC12LNAM_","_MC12FNAM
I $D(^VA(200,"B",MCNAM)) S MCA(12)=$O(^(MCNAM,0)) D KNMK Q 0
K MCA(12) F S MCNAM=$O(^VA(200,"B",MCNAM)) Q:MCNAM="" S MCLNAM=$P(MCNAM,","),MCFNAM=$P(MCNAM,",",2,99) Q:($E(MCLNAM,1,7)'=MC12LNAM) I $E(MCLNAM,1,7)=MC12LNAM,$E(MCFNAM,1,3)=MC12FNAM S MCA(12)=$O(^(MCNAM,0)) Q
D KNMK I $D(MCA(12)) Q 0
I MCA("DT")>2950430 S MCERR="64-Interpreted By does not match name in New Person file" Q $$LOG^MCARAM7(MCERR)
Q $$LOG^MCARAM7("13-Interpreted By does not match name in New Person file")
;
PROEFF(MCEDT,MCERR) ;Starting May 1, 1995, provider match is required to file record
; if provider does not match, returns fatal error message according
; to test date
I MCEDT>2950430 S MCERR="63-Interpreted By is a null data field"
K MCEDT Q MCERR
;
LDHCP(MCA,MCE) ;load local array data into DHCP
; USAGE: S X=$$LDHCP^MCARAM3(.A,.B)
; WHERE: A=local array of data
; B=DHCP data
; including MCE("EKG") =internal record number in EKG file
;transfer local array data into new EKG record in DHCP
S MCERR=$$EKG^MCARAM5(.MCA,.MCE) I +MCERR>50 Q $$LOG^MCARAM7(MCERR)
;transfer local array diagnosis data into EKG record
S MCERR=$$EKGDG^MCARAM5(.MCA,.MCE) I +MCERR>50 Q $$LOG^MCARAM7(MCERR)
;transfer local array medication data into EKG record
S MCERR=$$EKGRX^MCARAM5(.MCA,.MCE) I +MCERR>50 Q $$LOG^MCARAM7(MCERR)
;transfer order and request/consultation data into EKG record
S MCERR=$$EKGOR^MCARAM5(.MCA,.MCE) I +MCERR>50 Q $$LOG^MCARAM7(MCERR)
Q 0
;
KNMK ; Kill name check variables
K MCNAM,MCFNAM,MCLNAM,MC12NAM,MC12FNAM,MC12LNAM,MCA12 Q
;
ERR ;Error return
Q MCERR
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMCARAM3 4295 printed Apr 09, 2024@21:17:45 Page 2
MCARAM3 ;WASH ISC/JKL-MUSE TRANSFER LAB DATA TO LOCAL ;5/2/96 12:49
+1 ;;2.3;Medicine;;09/13/1996
+2 ;
+3 ;
+4 ;Modules to return lab data in a local array
+5 ; USAGE: S X=$$L#^MCARAM3(.A,B) , where # = integer from 7 to 12
+6 ; WHERE: .A=local array into which data is placed
+7 ; B=1 line of lab data
+8 ; if unsuccessful, returns an error message
+9 ; if successful, returns a function value of 0 and a value array:
+10 ; MCA(field #) = value of field
+11 ; MCA("CONT") = diagnosis line # in alphabetic form
+12 ; MCA("DX,#") = line of diagnosis data
+13 ; MCA("DT") = date/time in FM format
+14 ;
L12(MCA,MCD) ;Returns Field 8 = P Axis, 9 = R Axis, 10 = T Axis,
+1 ; 12 = Interpreted By, Pointer to File 200
+2 NEW MCERR
+3 SET MCERR=$$AR^MCARAM4(.MCA,8,MCD,11,15,3)
+4 IF +MCERR=2
KILL MCA(8)
SET MCERR=$$LOG^MCARAM7("2-P Axis is a null data field")
+5 IF +MCERR=1
KILL MCA(8)
SET MCERR=$$LOG^MCARAM7("1-P Axis not numeric")
+6 IF +MCERR>50
QUIT MCERR
+7 SET MCERR=$$AR^MCARAM4(.MCA,9,MCD,16,19,3)
+8 IF +MCERR=2
KILL MCA(9)
SET MCERR=$$LOG^MCARAM7("2-R Axis is a null data field")
+9 IF +MCERR=1
KILL MCA(9)
SET MCERR=$$LOG^MCARAM7("1-R Axis not numeric")
+10 IF +MCERR>50
QUIT MCERR
+11 SET MCERR=$$AR^MCARAM4(.MCA,10,MCD,20,31,3)
+12 IF +MCERR=2
KILL MCA(10)
SET MCERR=$$LOG^MCARAM7("2-T Axis is a null data field")
+13 IF +MCERR=1
KILL MCA(10)
SET MCERR=$$LOG^MCARAM7("1-T Axis not numeric")
+14 IF +MCERR>50
QUIT MCERR
+15 IF $$GRERR^MCARAM7(.MCA)=1
QUIT MCERR
+16 SET MCERR=$$AR^MCARAM4(.MCA,12,MCD,67,134)
IF +MCERR=2
KILL MCA(12)
SET MCERR=$$PROEFF^MCARAM3(MCA("DT"),MCERR)
QUIT $$LOG^MCARAM7(MCERR)
+17 IF +MCERR>50
QUIT MCERR
+18 SET MCA(12)=$PIECE(MCA(12),": ",2)
IF MCA(12)=""
KILL MCA(12)
SET MCERR=$$PROEFF^MCARAM3(MCA("DT"),MCERR)
QUIT $$LOG^MCARAM7(MCERR)
+19 NEW MCPH
SET MCPH=MCA(12)
SET MCERR=$$SLTS^MCARAM4(.MCPH)
SET MCA(12)=MCPH
KILL MCPH
+20 IF +MCERR=2
KILL MCA(12)
SET MCERR=$$PROEFF^MCARAM3(MCA("DT"),MCERR)
QUIT $$LOG^MCARAM7(MCERR)
+21 IF MCA(12)["/"
IF MCA(12)'[" "
SET MCA(12)=$PIECE(MCA(12),"/")
+22 IF MCA(12)["/"
NEW MCA12
SET MCA(12)=$PIECE(MCA(12),"/")
FOR MCA12=$LENGTH(MCA(12)):-1:1
IF $EXTRACT(MCA(12),MCA12)=" "
SET MCA(12)=$EXTRACT(MCA(12),(MCA12+1),$LENGTH(MCA(12)))
QUIT
+23 if MCA(12)[" M.D.,"
SET MCA(12)=$PIECE(MCA(12)," M.D.",1)_$PIECE(MCA(12),"M.D.",2,99)
+24 if MCA(12)[" M.D."
SET MCA(12)=$PIECE(MCA(12)," M.D.",1)_","_$PIECE(MCA(12),"M.D. ",2,99)
+25 if MCA(12)[" MD "
SET MCA(12)=$PIECE(MCA(12)," MD",1)_","_$PIECE(MCA(12),"MD ",2,99)
+26 IF $DATA(^VA(200,"B",MCA(12)))
SET MCA(12)=$ORDER(^(MCA(12),0))
QUIT 0
+27 ;allow a match between DHCP provider name length and instrument name length
+28 NEW MCNAM,MCFNAM,MCLNAM,MC12NAM,MC12FNAM,MC12LNAM
+29 SET MC12LNAM=$PIECE(MCA(12),",")
SET MC12FNAM=$PIECE(MCA(12),",",2,99)
+30 IF $EXTRACT(MC12FNAM)=" "
SET MC12FNAM=$EXTRACT(MC12FNAM,2,$LENGTH(MC12FNAM))
+31 SET (MC12LNAM,MCLNAM)=$EXTRACT(MC12LNAM,1,7)
SET (MC12FNAM,MCFNAM)=$EXTRACT(MC12FNAM,1,3)
+32 SET (MC12NAM,MCNAM)=MC12LNAM_","_MC12FNAM
+33 IF $DATA(^VA(200,"B",MCNAM))
SET MCA(12)=$ORDER(^(MCNAM,0))
DO KNMK
QUIT 0
+34 KILL MCA(12)
FOR
SET MCNAM=$ORDER(^VA(200,"B",MCNAM))
if MCNAM=""
QUIT
SET MCLNAM=$PIECE(MCNAM,",")
SET MCFNAM=$PIECE(MCNAM,",",2,99)
if ($EXTRACT(MCLNAM,1,7)'=MC12LNAM)
QUIT
IF $EXTRACT(MCLNAM,1,7)=MC12LNAM
IF $EXTRACT(MCFNAM,1,3)=MC12FNAM
SET MCA(12)=$ORDER(^(MCNAM,0))
QUIT
+35 DO KNMK
IF $DATA(MCA(12))
QUIT 0
+36 IF MCA("DT")>2950430
SET MCERR="64-Interpreted By does not match name in New Person file"
QUIT $$LOG^MCARAM7(MCERR)
+37 QUIT $$LOG^MCARAM7("13-Interpreted By does not match name in New Person file")
+38 ;
PROEFF(MCEDT,MCERR) ;Starting May 1, 1995, provider match is required to file record
+1 ; if provider does not match, returns fatal error message according
+2 ; to test date
+3 IF MCEDT>2950430
SET MCERR="63-Interpreted By is a null data field"
+4 KILL MCEDT
QUIT MCERR
+5 ;
LDHCP(MCA,MCE) ;load local array data into DHCP
+1 ; USAGE: S X=$$LDHCP^MCARAM3(.A,.B)
+2 ; WHERE: A=local array of data
+3 ; B=DHCP data
+4 ; including MCE("EKG") =internal record number in EKG file
+5 ;transfer local array data into new EKG record in DHCP
+6 SET MCERR=$$EKG^MCARAM5(.MCA,.MCE)
IF +MCERR>50
QUIT $$LOG^MCARAM7(MCERR)
+7 ;transfer local array diagnosis data into EKG record
+8 SET MCERR=$$EKGDG^MCARAM5(.MCA,.MCE)
IF +MCERR>50
QUIT $$LOG^MCARAM7(MCERR)
+9 ;transfer local array medication data into EKG record
+10 SET MCERR=$$EKGRX^MCARAM5(.MCA,.MCE)
IF +MCERR>50
QUIT $$LOG^MCARAM7(MCERR)
+11 ;transfer order and request/consultation data into EKG record
+12 SET MCERR=$$EKGOR^MCARAM5(.MCA,.MCE)
IF +MCERR>50
QUIT $$LOG^MCARAM7(MCERR)
+13 QUIT 0
+14 ;
KNMK ; Kill name check variables
+1 KILL MCNAM,MCFNAM,MCLNAM,MC12NAM,MC12FNAM,MC12LNAM,MCA12
QUIT
+2 ;
ERR ;Error return
+1 QUIT MCERR
