- 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
- 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
