MCARAM6 ;WASH ISC/JKL-MUSE LOOKUP IN DHCP ;5/2/96 12:49
;;2.3;Medicine;;09/13/1996
;
;
;Lookup for last record in EKG file given a date/time and SSN
;USAGE: S X=$$LSSN^MCARAM6(A,B,.C)
;WHERE: A=Date/time of record in FileMan format
; B=Social Security Number in consecutive digits
; .C=Array into which data is placed
; if unsuccessful, returns an error message
; if successful, returns a function value of 0 and a value array:
; C("EKG") = IEN of existing EKG record
; C(1) = PID of patient, field 1, Medical Patient
; C("NAME") = name of patient
;
;variables
;MCERR = error message
;
LSSN(MCDT,MCSS,MCP) ;
; Where MCDT is Date/time of record in FileMan format
; MCSS is Social Security Number in consecutive digits
; MCP is array into which data is placed
;
; Retrieves PID from SSN X-ref of Patient file
N MCI,DIC,D,X,Y S MCP("EKG")=""
S DIC="^DPT(",DIC(0)="XZ",D="SSN",X=MCSS D IX^DIC
I +Y'>0 S MCERR=$$EMPSSN(MCSS,.Y) I +MCERR=55 Q MCERR
S MCP(1)=+Y,MCP("NAME")=$P(Y(0),U)
I '$D(^MCAR(691.5,"B",MCDT)) S MCERR="12-Date/Time not in EKG file" Q $$LOG^MCARAM7(MCERR)
S MCI=0 F S MCI=$O(^MCAR(691.5,"B",MCDT,MCI)) Q:MCI="" I $D(^MCAR(691.5,"C",MCP(1),MCI)) S MCP("EKG")=MCI
I MCP("EKG")="" S MCERR="15-PID does not exist for Date/Time" Q $$LOG^MCARAM7(MCERR)
Q 0
;
ERR ;Error return
Q MCERR
;
EMPSSN(MCSS,Y) ;Determine if unretrievable SSN belongs to an employee
;USAGE: S X=$$EMPSSN^MCARAM6(A,.B)
;WHERE: A=Social Security Number
; if unsuccessful, returns an error message
; if successful, returns a function value of 0 and an array:
; B = patient id , B(0) = patient name
;
N MCEPID,MCEMP,DIC,D,X,Y
S MCERR="55-Social Security Number not in Patient file"
I '$D(^DPT("SSN",MCSS)) Q MCERR
S MCEPID=$O(^DPT("SSN",MCSS,0))
I '$D(^DPT(MCEPID,.36)) G STYPE
; Retrieves Employee entry from Eligibility Code file
SELIG S DIC="^DIC(8,",DIC(0)="XZ",D="B",X="EMPLOYEE" D IX^DIC
I +Y'>0 G STYPE
S MCEMP=+Y
I ^DPT(MCEPID,.36)=MCEMP,$D(^DPT(MCEPID,0)) S Y=MCEPID,Y(0)=$P(^DPT(MCEPID,0),"^") Q 0
STYPE I '$D(^DPT(MCEPID,"TYPE")) Q MCERR
; Retrieves Employee entry from Type of Patient file
S DIC="^DG(391,",DIC(0)="XZ",D="B",X="EMPLOYEE" D IX^DIC
I +Y'>0 Q MCERR
S MCEMP=+Y
I ^DPT(MCEPID,"TYPE")=MCEMP,$D(^DPT(MCEPID,0)) S Y=MCEPID,Y(0)=$P(^DPT(MCEPID,0),"^") Q 0
Q MCERR
;
;Lookup for last record in EKG file given a date/time and full name
;USAGE: S X=$$LNAME^MCARAM6(A,B,.C)
;WHERE: A=Date/time of record in FileMan format
; B=Full Name in DHCP format
; .C=Array into which data is placed
; if unsuccessful, returns an error message
; if successful, returns a function value of 0 and a value array:
; C("EKG") = IEN of existing EKG record
; C(1) = PID of patient, field 1, Medical Patient
; C("NAME") = name of patient
;
;variables
;MCERR = error message
;
LNAME(MCDT,MCNAME,MCP) ;
; Where MCDT is Date/time of record in FileMan format
; MCNAME is Full Name in DHCP format
; MCP is array into which data is placed
;
; Retrieves PID from Name X-ref of Patient file
N MCI,DIC,D,X,Y S MCP("EKG")=""
S DIC="^DPT(",DIC(0)="XZ",D="B",X=MCNAME D IX^DIC
I +Y'>0 S MCERR=$$EMPNAME(MCNAME,.Y) I +MCERR=56 Q MCERR
S MCP(1)=+Y,MCP("NAME")=$P(Y(0),U)
I '$D(^MCAR(691.5,"B",MCDT)) S MCERR="12-Date/Time not in EKG file" Q $$LOG^MCARAM7(MCERR)
S MCI=0 F S MCI=$O(^MCAR(691.5,"B",MCDT,MCI)) Q:MCI="" I $D(^MCAR(691.5,"C",MCP(1),MCI)) S MCP("EKG")=MCI
I MCP("EKG")="" S MCERR="15-PID does not exist for Date/Time" Q $$LOG^MCARAM7(MCERR)
Q 0
;
EMPNAME(MCNAME,Y) ;Determine if unretrievable name belongs to an employee
;USAGE: S X=$$EMPNAME^MCARAM6(A,.B)
;WHERE: A = Name
; if unsuccessful, returns an error message
; if successful, returns a function value of 0 and an array:
; B = patient id , B(0) = patient name
;
N MCEPID,MCEMP,DIC,D,X,Y
S MCERR="56-Name does not match Patient file"
I '$D(^DPT("B",MCNAME)) Q MCERR
S MCEPID=$O(^DPT("B",MCNAME,0))
I '$D(^DPT(MCEPID,.36)) G NTYPE
; Retrieves Employee entry from Eligibility Code file
NELIG S DIC="^DIC(8,",DIC(0)="XZ",D="B",X="EMPLOYEE" D IX^DIC
I +Y'>0 G NTYPE
S MCEMP=+Y
I ^DPT(MCEPID,.36)=MCEMP,$D(^DPT(MCEPID,0)) S Y=MCEPID,Y(0)=$P(^DPT(MCEPID,0),"^") Q 0
NTYPE I '$D(^DPT(MCEPID,"TYPE")) Q MCERR
; Retrieves Employee entry from Type of Patient file
S DIC="^DG(391,",DIC(0)="XZ",D="B",X="EMPLOYEE" D IX^DIC
I +Y'>0 Q MCERR
S MCEMP=+Y
I ^DPT(MCEPID,"TYPE")=MCEMP,$D(^DPT(MCEPID,0)) S Y=MCEPID,Y(0)=$P(^DPT(MCEPID,0),"^") Q 0
Q MCERR
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMCARAM6 4671 printed Apr 09, 2024@21:16:12 Page 2
MCARAM6 ;WASH ISC/JKL-MUSE LOOKUP IN DHCP ;5/2/96 12:49
+1 ;;2.3;Medicine;;09/13/1996
+2 ;
+3 ;
+4 ;Lookup for last record in EKG file given a date/time and SSN
+5 ;USAGE: S X=$$LSSN^MCARAM6(A,B,.C)
+6 ;WHERE: A=Date/time of record in FileMan format
+7 ; B=Social Security Number in consecutive digits
+8 ; .C=Array into which data is placed
+9 ; if unsuccessful, returns an error message
+10 ; if successful, returns a function value of 0 and a value array:
+11 ; C("EKG") = IEN of existing EKG record
+12 ; C(1) = PID of patient, field 1, Medical Patient
+13 ; C("NAME") = name of patient
+14 ;
+15 ;variables
+16 ;MCERR = error message
+17 ;
LSSN(MCDT,MCSS,MCP) ;
+1 ; Where MCDT is Date/time of record in FileMan format
+2 ; MCSS is Social Security Number in consecutive digits
+3 ; MCP is array into which data is placed
+4 ;
+5 ; Retrieves PID from SSN X-ref of Patient file
+6 NEW MCI,DIC,D,X,Y
SET MCP("EKG")=""
+7 SET DIC="^DPT("
SET DIC(0)="XZ"
SET D="SSN"
SET X=MCSS
DO IX^DIC
+8 IF +Y'>0
SET MCERR=$$EMPSSN(MCSS,.Y)
IF +MCERR=55
QUIT MCERR
+9 SET MCP(1)=+Y
SET MCP("NAME")=$PIECE(Y(0),U)
+10 IF '$DATA(^MCAR(691.5,"B",MCDT))
SET MCERR="12-Date/Time not in EKG file"
QUIT $$LOG^MCARAM7(MCERR)
+11 SET MCI=0
FOR
SET MCI=$ORDER(^MCAR(691.5,"B",MCDT,MCI))
if MCI=""
QUIT
IF $DATA(^MCAR(691.5,"C",MCP(1),MCI))
SET MCP("EKG")=MCI
+12 IF MCP("EKG")=""
SET MCERR="15-PID does not exist for Date/Time"
QUIT $$LOG^MCARAM7(MCERR)
+13 QUIT 0
+14 ;
ERR ;Error return
+1 QUIT MCERR
+2 ;
EMPSSN(MCSS,Y) ;Determine if unretrievable SSN belongs to an employee
+1 ;USAGE: S X=$$EMPSSN^MCARAM6(A,.B)
+2 ;WHERE: A=Social Security Number
+3 ; if unsuccessful, returns an error message
+4 ; if successful, returns a function value of 0 and an array:
+5 ; B = patient id , B(0) = patient name
+6 ;
+7 NEW MCEPID,MCEMP,DIC,D,X,Y
+8 SET MCERR="55-Social Security Number not in Patient file"
+9 IF '$DATA(^DPT("SSN",MCSS))
QUIT MCERR
+10 SET MCEPID=$ORDER(^DPT("SSN",MCSS,0))
+11 IF '$DATA(^DPT(MCEPID,.36))
GOTO STYPE
+12 ; Retrieves Employee entry from Eligibility Code file
SELIG SET DIC="^DIC(8,"
SET DIC(0)="XZ"
SET D="B"
SET X="EMPLOYEE"
DO IX^DIC
+1 IF +Y'>0
GOTO STYPE
+2 SET MCEMP=+Y
+3 IF ^DPT(MCEPID,.36)=MCEMP
IF $DATA(^DPT(MCEPID,0))
SET Y=MCEPID
SET Y(0)=$PIECE(^DPT(MCEPID,0),"^")
QUIT 0
STYPE IF '$DATA(^DPT(MCEPID,"TYPE"))
QUIT MCERR
+1 ; Retrieves Employee entry from Type of Patient file
+2 SET DIC="^DG(391,"
SET DIC(0)="XZ"
SET D="B"
SET X="EMPLOYEE"
DO IX^DIC
+3 IF +Y'>0
QUIT MCERR
+4 SET MCEMP=+Y
+5 IF ^DPT(MCEPID,"TYPE")=MCEMP
IF $DATA(^DPT(MCEPID,0))
SET Y=MCEPID
SET Y(0)=$PIECE(^DPT(MCEPID,0),"^")
QUIT 0
+6 QUIT MCERR
+7 ;
+8 ;Lookup for last record in EKG file given a date/time and full name
+9 ;USAGE: S X=$$LNAME^MCARAM6(A,B,.C)
+10 ;WHERE: A=Date/time of record in FileMan format
+11 ; B=Full Name in DHCP format
+12 ; .C=Array into which data is placed
+13 ; if unsuccessful, returns an error message
+14 ; if successful, returns a function value of 0 and a value array:
+15 ; C("EKG") = IEN of existing EKG record
+16 ; C(1) = PID of patient, field 1, Medical Patient
+17 ; C("NAME") = name of patient
+18 ;
+19 ;variables
+20 ;MCERR = error message
+21 ;
LNAME(MCDT,MCNAME,MCP) ;
+1 ; Where MCDT is Date/time of record in FileMan format
+2 ; MCNAME is Full Name in DHCP format
+3 ; MCP is array into which data is placed
+4 ;
+5 ; Retrieves PID from Name X-ref of Patient file
+6 NEW MCI,DIC,D,X,Y
SET MCP("EKG")=""
+7 SET DIC="^DPT("
SET DIC(0)="XZ"
SET D="B"
SET X=MCNAME
DO IX^DIC
+8 IF +Y'>0
SET MCERR=$$EMPNAME(MCNAME,.Y)
IF +MCERR=56
QUIT MCERR
+9 SET MCP(1)=+Y
SET MCP("NAME")=$PIECE(Y(0),U)
+10 IF '$DATA(^MCAR(691.5,"B",MCDT))
SET MCERR="12-Date/Time not in EKG file"
QUIT $$LOG^MCARAM7(MCERR)
+11 SET MCI=0
FOR
SET MCI=$ORDER(^MCAR(691.5,"B",MCDT,MCI))
if MCI=""
QUIT
IF $DATA(^MCAR(691.5,"C",MCP(1),MCI))
SET MCP("EKG")=MCI
+12 IF MCP("EKG")=""
SET MCERR="15-PID does not exist for Date/Time"
QUIT $$LOG^MCARAM7(MCERR)
+13 QUIT 0
+14 ;
EMPNAME(MCNAME,Y) ;Determine if unretrievable name belongs to an employee
+1 ;USAGE: S X=$$EMPNAME^MCARAM6(A,.B)
+2 ;WHERE: A = Name
+3 ; if unsuccessful, returns an error message
+4 ; if successful, returns a function value of 0 and an array:
+5 ; B = patient id , B(0) = patient name
+6 ;
+7 NEW MCEPID,MCEMP,DIC,D,X,Y
+8 SET MCERR="56-Name does not match Patient file"
+9 IF '$DATA(^DPT("B",MCNAME))
QUIT MCERR
+10 SET MCEPID=$ORDER(^DPT("B",MCNAME,0))
+11 IF '$DATA(^DPT(MCEPID,.36))
GOTO NTYPE
+12 ; Retrieves Employee entry from Eligibility Code file
NELIG SET DIC="^DIC(8,"
SET DIC(0)="XZ"
SET D="B"
SET X="EMPLOYEE"
DO IX^DIC
+1 IF +Y'>0
GOTO NTYPE
+2 SET MCEMP=+Y
+3 IF ^DPT(MCEPID,.36)=MCEMP
IF $DATA(^DPT(MCEPID,0))
SET Y=MCEPID
SET Y(0)=$PIECE(^DPT(MCEPID,0),"^")
QUIT 0
NTYPE IF '$DATA(^DPT(MCEPID,"TYPE"))
QUIT MCERR
+1 ; Retrieves Employee entry from Type of Patient file
+2 SET DIC="^DG(391,"
SET DIC(0)="XZ"
SET D="B"
SET X="EMPLOYEE"
DO IX^DIC
+3 IF +Y'>0
QUIT MCERR
+4 SET MCEMP=+Y
+5 IF ^DPT(MCEPID,"TYPE")=MCEMP
IF $DATA(^DPT(MCEPID,0))
SET Y=MCEPID
SET Y(0)=$PIECE(^DPT(MCEPID,0),"^")
QUIT 0
+6 QUIT MCERR
