MCARAM4 ;WASH ISC/JKL-MUSE TRANSFER LAB DATA TO LOCAL ;5/20/94 15:35
;;2.3;Medicine;;09/13/1996
;
;
;Checks format and/or reformats data
AR(MCA,MCAA,MCD,MCFP,MCLP,MCCK) ;Sets l/t stripped data field into an array
; USAGE: S X=$$AR^MCARAM4(.A,B,C,D,E)
; WHERE: .A = array where data is placed
; B = array argument for data field
; C = data field value
; D = first position of data field
; E = last position of data field
; F = 1 to check numeric data field value for positive int value
; 2 to check "" for both positive and negative int value
; 3 to check "" for pos,neg,int, and decimal values
N MCI,MCERR
I '$D(MCCK) S MCCK=""
S MCA(MCAA)=$E(MCD,MCFP,MCLP),MCI=MCA(MCAA),MCERR=$$SLTS^MCARAM4(.MCI),MCA(MCAA)=MCI I +MCERR>0 Q MCERR
I MCCK=1 S MCERR=$$DFCK^MCARAM4(MCA(MCAA),MCCK) I +MCERR>0 Q MCERR
I MCCK=2 S MCERR=$$DFCK^MCARAM4(MCA(MCAA),MCCK) I +MCERR>0 Q MCERR
I MCCK=3 S MCERR=$$DFCK^MCARAM4(MCA(MCAA),MCCK) I +MCERR>0 Q MCERR
Q 0
;
DFCK(MCV,MCCK) ; Checks numeric,negative,positive,integer,decimal value
; USAGE: S X=$$DFCK^MCARAM4(A,B)
; WHERE: A=data field value
; B=1 for positive value numeric (integer) check
; B=2 for positive and negative value numeric (integer) check
; B=3 for positive, negative, decimal, or integer numeric check
; if successful, returns function value of 0
; if unsuccessful, returns error message for incorrect field format
N MCERR
I MCV="" S MCERR="2-Null data field" Q MCERR
I MCV=0 Q 0
I $G(MCCK)=1 I MCV?1N.N Q 0
I $G(MCCK)=2 I MCV?."-"1N.N,$P(MCV,"-",2,99)'["-",-MCV+-MCV'=0 Q 0
I $G(MCCK)=3 I MCV?."-"."."1N.N.".".N,$P(MCV,".",2,99)'[".",$P(MCV,"-",2,99)'["-",-MCV+-MCV'=0 Q 0
S MCERR="1-Data field not numeric" Q MCERR
;
SLTS(MCV) ; Strips leading and trailing spaces from data fields
; USAGE: S X=$$SLTS^MCARAM4(.A)
; WHERE: MCV=data field value
; .A = value where data is placed
; if successful, returns function value of 0 and data field value
; if unsuccessful, returns error message for incorrect field format
N MCERR,MCI,MCJ
I MCV="" S MCERR="2-Null data field" Q MCERR
F MCI=1:1 I $E(MCV,MCI,MCI)'=" " Q
F MCJ=$L(MCV):-1 I $E(MCV,MCJ,MCJ)'=" " Q
S MCV=$E(MCV,MCI,MCJ) I MCV="" S MCERR="2-Null data field" Q MCERR
Q 0
;
DGCK(MCA) ;Removes null lines and resets numbering of diagnosis array
; USAGE: S X=$$DGCK^MCARAM4(.A)
; WHERE: MCA=diagnosis array
; .A=diagnosis array renumbered without null lines
; A("DX,0")=total number of non-null diagnosis lines
; if successful, returns function value of 0 and diagnosis array
; if unsuccessful, returns error message and A("DX,0")=0
N MCI,MCJ,MCK,MCERR
S MCI=0,MCJ="DX,0"
F S MCJ=$O(MCA(MCJ)) Q:MCJ=""!($E(MCJ)'=$E("DX,0")) S:MCA(MCJ)'="" MCI=MCI+1 I MCA(MCJ)="" K MCA(MCJ) S MCK=MCJ F S MCK=$O(MCA(MCK)) Q:MCK=""!($E(MCK)'=$E("DX,0")) I MCA(MCK)'="" S MCA(MCJ)=MCA(MCK),MCI=MCI+1,MCA(MCK)="" Q
S MCA("DX,0")=MCI I MCI>0 Q 0
S MCERR="62-Diagnosis is a null data field" Q MCERR
;
RXCK(MCA) ;Removes null lines and resets numbering of medication array
; USAGE: S X=$$RXCK^MCARAM4(.A)
; WHERE: MCA=medication array
; .A=medication array renumbered without null lines
; A("RX,0")=total number of non-null medication lines
; if successful, returns function value of 0 and medication array
; if unsuccessful, returns error message and A("RX,0")=0
N MCI,MCJ,MCK,MCERR
I MCA("RX,0")="" S MCA("RX,0")=0,MCERR="4-Medication is a null data field" Q MCERR
F MCJ=1:1 S MCK="RX,"_MCJ,MCA(MCK)=$P(MCA("RX,0"),", ",MCJ) Q:MCA(MCK)="" S MCI=$P(MCA(MCK)," ") I MCI'="",$D(^PSDRUG("B",MCI)) S MCA(MCK)=$O(^(MCI,0))_U_$P(MCA(MCK)," ",2)_U_$P(MCA(MCK)," ",3)
K MCA(MCK)
S MCA("RX,0")=MCJ-1 I MCJ-1=0 S MCERR="4-Medication is a null data field" Q MCERR
Q 0
;
DGCT(MCA,MCD,MCL) ;Fill diagnosis array from continuation record
; USAGE: S X=$$DGCT^MCARAM4(.A,B,C)
; WHERE: MCA=diagnosis array
; .A=diagnosis array renumbered without null lines
; B=data field value, C=line number of data
; A("DX,0")=total number of non-null diagnosis lines
; "DX,L"=12th line of diagnosis, "DX,V"=22nd line
; if successful, returns function value of 0 and diagnosis array
; if unsuccessful, returns error message and A("DX,0")=0
N MCI,MCERR
S MCI="DX,"_MCA("CONT")
I MCL=13!(MCL=25) S MCERR=$$AR^MCARAM4(.MCA,MCI,MCD,32,78) Q:+MCERR>0 MCERR Q 0
S MCERR=$$AR^MCARAM4(.MCA,MCI,MCD,32,134) Q:+MCERR>0 MCERR
Q 0
;
ERR ;Error return
Q MCERR
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMCARAM4 4623 printed Apr 09, 2024@21:16:31 Page 2
MCARAM4 ;WASH ISC/JKL-MUSE TRANSFER LAB DATA TO LOCAL ;5/20/94 15:35
+1 ;;2.3;Medicine;;09/13/1996
+2 ;
+3 ;
+4 ;Checks format and/or reformats data
AR(MCA,MCAA,MCD,MCFP,MCLP,MCCK) ;Sets l/t stripped data field into an array
+1 ; USAGE: S X=$$AR^MCARAM4(.A,B,C,D,E)
+2 ; WHERE: .A = array where data is placed
+3 ; B = array argument for data field
+4 ; C = data field value
+5 ; D = first position of data field
+6 ; E = last position of data field
+7 ; F = 1 to check numeric data field value for positive int value
+8 ; 2 to check "" for both positive and negative int value
+9 ; 3 to check "" for pos,neg,int, and decimal values
+10 NEW MCI,MCERR
+11 IF '$DATA(MCCK)
SET MCCK=""
+12 SET MCA(MCAA)=$EXTRACT(MCD,MCFP,MCLP)
SET MCI=MCA(MCAA)
SET MCERR=$$SLTS^MCARAM4(.MCI)
SET MCA(MCAA)=MCI
IF +MCERR>0
QUIT MCERR
+13 IF MCCK=1
SET MCERR=$$DFCK^MCARAM4(MCA(MCAA),MCCK)
IF +MCERR>0
QUIT MCERR
+14 IF MCCK=2
SET MCERR=$$DFCK^MCARAM4(MCA(MCAA),MCCK)
IF +MCERR>0
QUIT MCERR
+15 IF MCCK=3
SET MCERR=$$DFCK^MCARAM4(MCA(MCAA),MCCK)
IF +MCERR>0
QUIT MCERR
+16 QUIT 0
+17 ;
DFCK(MCV,MCCK) ; Checks numeric,negative,positive,integer,decimal value
+1 ; USAGE: S X=$$DFCK^MCARAM4(A,B)
+2 ; WHERE: A=data field value
+3 ; B=1 for positive value numeric (integer) check
+4 ; B=2 for positive and negative value numeric (integer) check
+5 ; B=3 for positive, negative, decimal, or integer numeric check
+6 ; if successful, returns function value of 0
+7 ; if unsuccessful, returns error message for incorrect field format
+8 NEW MCERR
+9 IF MCV=""
SET MCERR="2-Null data field"
QUIT MCERR
+10 IF MCV=0
QUIT 0
+11 IF $GET(MCCK)=1
IF MCV?1N.N
QUIT 0
+12 IF $GET(MCCK)=2
IF MCV?."-"1N.N
IF $PIECE(MCV,"-",2,99)'["-"
IF -MCV+-MCV'=0
QUIT 0
+13 IF $GET(MCCK)=3
IF MCV?."-"."."1N.N.".".N
IF $PIECE(MCV,".",2,99)'["."
IF $PIECE(MCV,"-",2,99)'["-"
IF -MCV+-MCV'=0
QUIT 0
+14 SET MCERR="1-Data field not numeric"
QUIT MCERR
+15 ;
SLTS(MCV) ; Strips leading and trailing spaces from data fields
+1 ; USAGE: S X=$$SLTS^MCARAM4(.A)
+2 ; WHERE: MCV=data field value
+3 ; .A = value where data is placed
+4 ; if successful, returns function value of 0 and data field value
+5 ; if unsuccessful, returns error message for incorrect field format
+6 NEW MCERR,MCI,MCJ
+7 IF MCV=""
SET MCERR="2-Null data field"
QUIT MCERR
+8 FOR MCI=1:1
IF $EXTRACT(MCV,MCI,MCI)'=" "
QUIT
+9 FOR MCJ=$LENGTH(MCV):-1
IF $EXTRACT(MCV,MCJ,MCJ)'=" "
QUIT
+10 SET MCV=$EXTRACT(MCV,MCI,MCJ)
IF MCV=""
SET MCERR="2-Null data field"
QUIT MCERR
+11 QUIT 0
+12 ;
DGCK(MCA) ;Removes null lines and resets numbering of diagnosis array
+1 ; USAGE: S X=$$DGCK^MCARAM4(.A)
+2 ; WHERE: MCA=diagnosis array
+3 ; .A=diagnosis array renumbered without null lines
+4 ; A("DX,0")=total number of non-null diagnosis lines
+5 ; if successful, returns function value of 0 and diagnosis array
+6 ; if unsuccessful, returns error message and A("DX,0")=0
+7 NEW MCI,MCJ,MCK,MCERR
+8 SET MCI=0
SET MCJ="DX,0"
+9 FOR
SET MCJ=$ORDER(MCA(MCJ))
if MCJ=""!($EXTRACT(MCJ)'=$EXTRACT("DX,0"))
QUIT
if MCA(MCJ)'=""
SET MCI=MCI+1
IF MCA(MCJ)=""
KILL MCA(MCJ)
SET MCK=MCJ
FOR
SET MCK=$ORDER(MCA(MCK))
if MCK=""!($EXTRACT(MCK)'=$EXTRACT("DX,0"))
QUIT
IF MCA(MCK)'=""
SET MCA(MCJ)=MCA(MCK)
SET MCI=MCI+1
SET MCA(MCK)=""
QUIT
+10 SET MCA("DX,0")=MCI
IF MCI>0
QUIT 0
+11 SET MCERR="62-Diagnosis is a null data field"
QUIT MCERR
+12 ;
RXCK(MCA) ;Removes null lines and resets numbering of medication array
+1 ; USAGE: S X=$$RXCK^MCARAM4(.A)
+2 ; WHERE: MCA=medication array
+3 ; .A=medication array renumbered without null lines
+4 ; A("RX,0")=total number of non-null medication lines
+5 ; if successful, returns function value of 0 and medication array
+6 ; if unsuccessful, returns error message and A("RX,0")=0
+7 NEW MCI,MCJ,MCK,MCERR
+8 IF MCA("RX,0")=""
SET MCA("RX,0")=0
SET MCERR="4-Medication is a null data field"
QUIT MCERR
+9 FOR MCJ=1:1
SET MCK="RX,"_MCJ
SET MCA(MCK)=$PIECE(MCA("RX,0"),", ",MCJ)
if MCA(MCK)=""
QUIT
SET MCI=$PIECE(MCA(MCK)," ")
IF MCI'=""
IF $DATA(^PSDRUG("B",MCI))
SET MCA(MCK)=$ORDER(^(MCI,0))_U_$PIECE(MCA(MCK)," ",2)_U_$PIECE(MCA(MCK)," ",3)
+10 KILL MCA(MCK)
+11 SET MCA("RX,0")=MCJ-1
IF MCJ-1=0
SET MCERR="4-Medication is a null data field"
QUIT MCERR
+12 QUIT 0
+13 ;
DGCT(MCA,MCD,MCL) ;Fill diagnosis array from continuation record
+1 ; USAGE: S X=$$DGCT^MCARAM4(.A,B,C)
+2 ; WHERE: MCA=diagnosis array
+3 ; .A=diagnosis array renumbered without null lines
+4 ; B=data field value, C=line number of data
+5 ; A("DX,0")=total number of non-null diagnosis lines
+6 ; "DX,L"=12th line of diagnosis, "DX,V"=22nd line
+7 ; if successful, returns function value of 0 and diagnosis array
+8 ; if unsuccessful, returns error message and A("DX,0")=0
+9 NEW MCI,MCERR
+10 SET MCI="DX,"_MCA("CONT")
+11 IF MCL=13!(MCL=25)
SET MCERR=$$AR^MCARAM4(.MCA,MCI,MCD,32,78)
if +MCERR>0
QUIT MCERR
QUIT 0
+12 SET MCERR=$$AR^MCARAM4(.MCA,MCI,MCD,32,134)
if +MCERR>0
QUIT MCERR
+13 QUIT 0
+14 ;
ERR ;Error return
+1 QUIT MCERR
