IVMUFNC ;ALB/MLI/PHH/SCK,TDM - IVM GENERIC FUNCTIONS ; 6/30/08 4:11pm
;;2.0;INCOME VERIFICATION MATCH;**3,11,17,34,95,94,115**;21-OCT-94;Build 28
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
; This routine contains generic calls for use throughout IVM
;
INIT(EID,HL,INT) ; initialize variables for 1.6 HL7/IVM
S EID=$G(EID),INT=$G(INT)
S HLDAP="IVM" D INIT^HLFNC2(EID,.HL,INT)
S (HLEVN,IVMCT)=0 ; initialize segment and message counters
;;D NOW^%DTC S HLSDT=%
Q
;
;
CLEAN ; clean-up variables for HL7/IVM (as defined by call to INIT)
D KILL^HLTRANS
K HLEVN,HLMTN,HLSDT,IVMCT
Q
;
;
BATCH ; put BHS and BTS segments into TMP global
;
; Input - HLMTN as HL7 message type being sent in this batch (REQUIRED)
; HLEVN as number of HL7 messages in batch (REQUIRED)
; IVMCT as subscript in TMP global where BTS segment goes (REQ)
; HLSEC (optional) as security (see BHS^HLFNC1)
; HLMSA (optional) as message ack variables (see BHS^HLFNC1)
;
; ****Also assumes all HL7 variables returned from****
; INIT^HLTRANS are defined
;
Q ; LINE ADDED FOR HL7 1.6
S HLSEC=$G(HLSEC),HLMSA=$G(HLMSA)
S ^TMP("HLS",$J,HLSDT,0)=$$BHS^HLFNC1(HLMTN,HLSEC,HLMSA)
S ^TMP("HLS",$J,HLSDT,IVMCT)="BTS"_HLFS_HLEVN ; trailer
Q
;
;
IVM(DFN,IVMDT) ; extrinsic function - should this pt be transmitted to IVM?
;
; Input - DFN as internal entry number of PATIENT file
; IVMDT as date of test (default DT)
;
; Output - 1 if pt should be sent to IVM, 0 otherwise
;
N X,Y
S DFN=$G(DFN) I '$D(^DPT(+DFN,0)) G IVMQ
S IVMDT=$S($G(IVMDT):IVMDT,1:DT)
S X=$$LST^DGMTU(DFN,IVMDT)
I $E($P(X,"^",2),1,3)'=$E(IVMDT,1,3) K IVMDT G IVMQ ; not in same year
S X=$G(^DGMT(408.31,+X,0)) I 'X G IVMQ ; can't find MT entry for date
I $P(X,"^",3)=6 S:'$$INS(DFN,IVMDT) Y=1 G IVMQ ; C/no insurance...send
I $P(X,"^",3)'=4 G IVMQ ; not cat A
I ($P(X,"^",4)-$P(X,"^",15)>$P(X,"^",12))!$P(X,"^",10) G IVMQ ; income-deduct expenses>threshold (hardship) or adjudicated
S Y=1
IVMQ Q +$G(Y)
;
;
INS(DFN,IVMDT) ; extrinsic function to see if pt has active insurance
;
; Input - DFN as internal entry number of PATIENT file
; IVMDT [optional] as date to compute ins coverage for
;
; Output - 1 if yes, 0 if no
;
Q $S($$INSUR^IBBAPI(DFN,$G(IVMDT))=1:1,1:0)
;
;
MAIL(IVMGRP) ; Transmit to members of Mail Group. Before D MAIL^IVMUFNC()
; set XMSUB = to subject and set IVMTEXT array to message.
;
;Input:
; IVMGRP - optional parameter, = to name of a mailgroup to send the
; message to. If not sent, the IVM Site Parameter file is
; used to determine the mailgroup.
;
N DIFROM,XMDUZ,XMTEXT,XMSTRIP,XMROU,XMY,XMZ,XMDF
S XMDF=""
S XMDUZ="IVM PACKAGE"
S XMTEXT="IVMTEXT("
I '$L($G(IVMGRP)) D
.S IVMGRP=$P($G(^XMB(3.8,+$P($G(^IVM(301.9,1,0)),"^",2),0)),"^")
S XMY("G."_IVMGRP_"@"_^XMB("NETNAME"))=""
D ^XMD
K IVMTEXT,XMDUZ,XMSUB,XMTEXT,XMY
Q
;
;
LTD(DFN,IVMQUERY) ; Find Last Treatment Date
; Input: DFN -- pointer to the patient in file #2
; IVMQUERY("LTD") -- # of the QUERY that is currently open or
; undefined, zero, or null if no QUERY opened for
; last treatment date
; Output: LTD -- Last Treatment Date (really last date seen at
; the facility)
;
N LTD,SDSTOP,X,Z,IVMQ
;
; - need a patient
S IVMQ=$G(IVMQUERY("LTD"))
I '$G(DFN) S LTD=0 G LTDQ
;
; - if current inpatient, set LTD = today and quit
I $G(^DPT(DFN,.105)) S LTD=DT G LTDQ
;
; - get the last discharge date
S LTD=+$O(^DGPM("ATID3",DFN,"")) S:LTD LTD=9999999.9999999-LTD\1 S:LTD>DT LTD=DT
;
; - get the last registration date and compare to LTD
S X=+$O(^DPT(DFN,"DIS",0)) I X S X=9999999-X\1 S:X>LTD LTD=X
;
; - get the last appointment or stop after LTD (if any)
K ^TMP("DIERR",$J)
I $G(IVMQ) D ACTIVE^SDQ(.IVMQ,"FALSE","SET") ;clear QUERY results
I '$G(IVMQ) D
.D OPEN^SDQ(.IVMQ) Q:'$G(IVMQ)
.D INDEX^SDQ(.IVMQ,"PATIENT/DATE","SET")
.D SCANCB^SDQ(.IVMQ,"I $S($P(SDOE0,U,8)=2:1,$P(SDOE0,U,8)=1:$$APPT^IVMUFNC(SDOE0),1:0) S LTD=SDOE0\1,SDSTOP=1","SET")
.S IVMQUERY("LTD")=IVMQ
;
D PAT^SDQ(.IVMQ,DFN,"SET")
D DATE^SDQ(.IVMQ,LTD+.000001,9999999,"SET")
D ACTIVE^SDQ(.IVMQ,"TRUE","SET")
D SCAN^SDQ(.IVMQ,"BACKWARD")
K ^TMP("DIERR",$J)
;
LTDQ ;
Q $S(LTD:$$HLDATE^HLFNC(LTD),1:HLQ)
;
APPT(SDOE0) ;Determine if appt associated with encounter is in a valid state
; Quit when Outpatient Encounter STATUS is CHECKED OUT
Q:$P(SDOE0,U,12)=2 1
; Quit when Outpatient Encounter STATUS is ACTION REQUIRED and the
; Appointment Status is SCHEDULED/KEPT
N DGARRAY,SDCNT,SDSTAT,SDDTTM S DGARRAY("FLDS")=3,DGARRAY(4)=+$P(SDOE0,U,2)
S DGARRAY(1)=$P(SDOE0,U),DGARRAY("SORT")="P",DGARRAY("MAX")=1
S SDCNT=$$SDAPI^SDAMA301(.DGARRAY),SDSTAT=""
I SDCNT>0 D
.S SDDTTM=$O(^TMP($J,"SDAMA301",DGARRAY(4),0))
.I SDDTTM S SDSTAT=$P($P($G(^TMP($J,"SDAMA301",DGARRAY(4),SDDTTM)),U,3),";")
K ^TMP($J,"SDAMA301")
Q:(($P(SDOE0,U,12)=14)&(SDSTAT="R")) 1
Q 0
;
OUTTR(IVMINT,IVMPAR,IVMST) ; - Transform IVMINT to a displayable value
; Input: IVMINT -- internal value of demographic element
; received from IVM
; IVMPAR -- Zeroth node of the entry in file #301.92
; for the demographic element IVMINT
; IVMST -- [optional] pointer to the STATE (#5) file
; Required to transform the county code
; Output: IVMOUT -- Displayable value for IVMINT
;
N IVMOUT,Z S IVMOUT=IVMINT
I $G(IVMINT)=""!($G(IVMPAR)="") S IVMOUT="" G OUTTRQ
;
; - use special transform for county
I $G(IVMST),$P(IVMPAR,"^",2)="PID12" S IVMOUT=$P($G(^DIC(5,IVMST,1,IVMINT,0)),"^")
;
; - transform the internal value if necessary
I $P(IVMPAR,"^",6) S IVMOUT=$$EXPAND($P(IVMPAR,"^",4),$P(IVMPAR,"^",5),IVMINT)
;
OUTTRQ Q IVMOUT
;
;
EXPAND(FILE,FIELD,VALUE) ; - returns internal data in an output format
N Y,C S Y=VALUE
I 'FILE!('FIELD)!(VALUE="") G EXPQ
S Y=VALUE,C=$P(^DD(FILE,FIELD,0),"^",2) D Y^DIQ
EXPQ Q Y
;
;
GETPAT(DFN,IVMPAT) ;
; Description: Used to obtain identifying information for a patient
; in the PATIENT file and place it in the IVMPAT() array.
;
; Input:
; DFN - ien of patient in PATIENT file
;
; Output:
; Function Value - 1 on success, 0 on failure
; IVMPAT - (pass by reference) On success, this array will contain
; the patient identifing information. Array subscripts are:
; "DFN" - ien PATIENT file
; "NAME" - patient name
; "SSN" - patient Social Security Number
; "DOB" - patient date of birth (FM format)
; "SEX" - patient sex
; "ICN" - patient ICN
;
N IVMNODE
Q:'$G(DFN) 0
K IVMPAT S IVMPAT=""
;
; obtain patient record
S IVMNODE=$G(^DPT(DFN,0))
Q:IVMNODE="" 0
;
S IVMPAT("DFN")=DFN
S IVMPAT("NAME")=$P(IVMNODE,"^")
S IVMPAT("SEX")=$P(IVMNODE,"^",2)
S IVMPAT("DOB")=$P(IVMNODE,"^",3)
S IVMPAT("SSN")=$P(IVMNODE,"^",9)
S IVMPAT("ICN")=$$GETICN^MPIF001(DFN)
Q 1
;
LOOKUP(SSN,DOB,SEX,ERROR) ;
;Description: This function will do a search for the patient based on
;the identifying information provided. The function will be successful
;only if a single patient is found matching the identifiers provided.
;
;Inputs:
; SSN - patient Social Security Number
; DOB - patient date of birth (FM format)
; SEX - patient sex
;Outputs:
; Function Value - patient DFN if successful, 0 otherwise
; ERROR - if unsuccessful, an error message is returned (optional, pass by reference)
;
N DFN,NODE
;
I $G(SSN)="" S ERROR="INVALID SSN" Q 0
S DFN=$O(^DPT("SSN",SSN,0))
I 'DFN S ERROR="SSN NOT FOUND" Q 0
I $O(^DPT("SSN",SSN,DFN)) S ERROR="MULTIPLE PATIENTS MATCHING SSN" Q 0
S NODE=$G(^DPT(DFN,0))
I $P(NODE,"^",2)'=SEX S ERROR="SEX DOES NOT MATCH" Q 0
I $E($P(NODE,"^",3),1,3)'=$E(DOB,1,3) S ERROR="DOB DOES NOT MATCH" Q 0
I $E($P(NODE,"^",3),4,5),$E($P(NODE,"^",3),4,5)'=$E(DOB,4,5) S ERROR="DOB DOES NOT MATCH" Q 0
Q DFN
;
MATCH(DFN,ICN,DOB,SEX,CFLG,ERROR) ;
;Description: This function will try to match the patient based on
;the identifying information provided. The function will be
;successful only if the patient is found matching the identifiers
;provided.
;
;Inputs:
; DFN - patient DFN
; ICN - patient ICN
; DOB - patient date of birth (FM format)
; SEX - patient sex
; CFLG - Compare Flag (Default="IDS", I=ICN, D=DOB, S=Sex)
;Outputs:
; Function Value: 1 - patient matched successfully, 0 - otherwise
; ERROR - if unsuccessful, an error message is returned (optional, pass by reference)
N NODE
I $G(DFN)="" S ERROR="INVALID DFN" Q 0
I $G(CFLG)="" S CFLG="IDS"
S NODE=$G(^DPT(DFN,0)) I NODE="" S ERROR="DFN NOT FOUND" Q 0
I CFLG["I",$$GETICN^MPIF001(DFN)'=$G(ICN) S ERROR="ICN DOES NOT MATCH" Q 0
I CFLG["S",$P(NODE,"^",2)'=$G(SEX) S ERROR="SEX DOES NOT MATCH" Q 0
I CFLG["D",$E($P(NODE,"^",3),1,3)'=$E($G(DOB),1,3) S ERROR="DOB DOES NOT MATCH" Q 0
I CFLG["D",$E($P(NODE,"^",3),4,5),$E($P(NODE,"^",3),4,5)'=$E($G(DOB),4,5) S ERROR="DOB DOES NOT MATCH" Q 0
Q 1
PARSPID3(PID3,PID3ARY) ;
;Description: This function will parse seq 3 of PID segment
;Input : PID3 - Array for seq. 3 of PID segment
;Output: PID3ARY("NI") - Value - ICN
; PID3ARY("PI") - Value - DFN
I $D(PID3(3)) D
.I $O(PID3(3,"")) D Q
..S COMP=0 F S COMP=$O(PID3(3,COMP)) Q:COMP="" D
...I $P(PID3(3,COMP),$E(HLECH),5)="PI" S PID3ARY("PI")=$P(PID3(3,COMP),$E(HLECH))
...I $P(PID3(3,COMP),$E(HLECH),5)="NI" S PID3ARY("NI")=$P(PID3(3,COMP),$E(HLECH))
.I $P(PID3(3),$E(HLECH),5)="PI" S PID3ARY("PI")=$P(PID3(3),$E(HLECH))
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIVMUFNC 9933 printed Jan 18, 2025@03:03:13 Page 2
IVMUFNC ;ALB/MLI/PHH/SCK,TDM - IVM GENERIC FUNCTIONS ; 6/30/08 4:11pm
+1 ;;2.0;INCOME VERIFICATION MATCH;**3,11,17,34,95,94,115**;21-OCT-94;Build 28
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
+4 ; This routine contains generic calls for use throughout IVM
+5 ;
INIT(EID,HL,INT) ; initialize variables for 1.6 HL7/IVM
+1 SET EID=$GET(EID)
SET INT=$GET(INT)
+2 SET HLDAP="IVM"
DO INIT^HLFNC2(EID,.HL,INT)
+3 ; initialize segment and message counters
SET (HLEVN,IVMCT)=0
+4 ;;D NOW^%DTC S HLSDT=%
+5 QUIT
+6 ;
+7 ;
CLEAN ; clean-up variables for HL7/IVM (as defined by call to INIT)
+1 DO KILL^HLTRANS
+2 KILL HLEVN,HLMTN,HLSDT,IVMCT
+3 QUIT
+4 ;
+5 ;
BATCH ; put BHS and BTS segments into TMP global
+1 ;
+2 ; Input - HLMTN as HL7 message type being sent in this batch (REQUIRED)
+3 ; HLEVN as number of HL7 messages in batch (REQUIRED)
+4 ; IVMCT as subscript in TMP global where BTS segment goes (REQ)
+5 ; HLSEC (optional) as security (see BHS^HLFNC1)
+6 ; HLMSA (optional) as message ack variables (see BHS^HLFNC1)
+7 ;
+8 ; ****Also assumes all HL7 variables returned from****
+9 ; INIT^HLTRANS are defined
+10 ;
+11 ; LINE ADDED FOR HL7 1.6
QUIT
+12 SET HLSEC=$GET(HLSEC)
SET HLMSA=$GET(HLMSA)
+13 SET ^TMP("HLS",$JOB,HLSDT,0)=$$BHS^HLFNC1(HLMTN,HLSEC,HLMSA)
+14 ; trailer
SET ^TMP("HLS",$JOB,HLSDT,IVMCT)="BTS"_HLFS_HLEVN
+15 QUIT
+16 ;
+17 ;
IVM(DFN,IVMDT) ; extrinsic function - should this pt be transmitted to IVM?
+1 ;
+2 ; Input - DFN as internal entry number of PATIENT file
+3 ; IVMDT as date of test (default DT)
+4 ;
+5 ; Output - 1 if pt should be sent to IVM, 0 otherwise
+6 ;
+7 NEW X,Y
+8 SET DFN=$GET(DFN)
IF '$DATA(^DPT(+DFN,0))
GOTO IVMQ
+9 SET IVMDT=$SELECT($GET(IVMDT):IVMDT,1:DT)
+10 SET X=$$LST^DGMTU(DFN,IVMDT)
+11 ; not in same year
IF $EXTRACT($PIECE(X,"^",2),1,3)'=$EXTRACT(IVMDT,1,3)
KILL IVMDT
GOTO IVMQ
+12 ; can't find MT entry for date
SET X=$GET(^DGMT(408.31,+X,0))
IF 'X
GOTO IVMQ
+13 ; C/no insurance...send
IF $PIECE(X,"^",3)=6
if '$$INS(DFN,IVMDT)
SET Y=1
GOTO IVMQ
+14 ; not cat A
IF $PIECE(X,"^",3)'=4
GOTO IVMQ
+15 ; income-deduct expenses>threshold (hardship) or adjudicated
IF ($PIECE(X,"^",4)-$PIECE(X,"^",15)>$PIECE(X,"^",12))!$PIECE(X,"^",10)
GOTO IVMQ
+16 SET Y=1
IVMQ QUIT +$GET(Y)
+1 ;
+2 ;
INS(DFN,IVMDT) ; extrinsic function to see if pt has active insurance
+1 ;
+2 ; Input - DFN as internal entry number of PATIENT file
+3 ; IVMDT [optional] as date to compute ins coverage for
+4 ;
+5 ; Output - 1 if yes, 0 if no
+6 ;
+7 QUIT $SELECT($$INSUR^IBBAPI(DFN,$GET(IVMDT))=1:1,1:0)
+8 ;
+9 ;
MAIL(IVMGRP) ; Transmit to members of Mail Group. Before D MAIL^IVMUFNC()
+1 ; set XMSUB = to subject and set IVMTEXT array to message.
+2 ;
+3 ;Input:
+4 ; IVMGRP - optional parameter, = to name of a mailgroup to send the
+5 ; message to. If not sent, the IVM Site Parameter file is
+6 ; used to determine the mailgroup.
+7 ;
+8 NEW DIFROM,XMDUZ,XMTEXT,XMSTRIP,XMROU,XMY,XMZ,XMDF
+9 SET XMDF=""
+10 SET XMDUZ="IVM PACKAGE"
+11 SET XMTEXT="IVMTEXT("
+12 IF '$LENGTH($GET(IVMGRP))
Begin DoDot:1
+13 SET IVMGRP=$PIECE($GET(^XMB(3.8,+$PIECE($GET(^IVM(301.9,1,0)),"^",2),0)),"^")
End DoDot:1
+14 SET XMY("G."_IVMGRP_"@"_^XMB("NETNAME"))=""
+15 DO ^XMD
+16 KILL IVMTEXT,XMDUZ,XMSUB,XMTEXT,XMY
+17 QUIT
+18 ;
+19 ;
LTD(DFN,IVMQUERY) ; Find Last Treatment Date
+1 ; Input: DFN -- pointer to the patient in file #2
+2 ; IVMQUERY("LTD") -- # of the QUERY that is currently open or
+3 ; undefined, zero, or null if no QUERY opened for
+4 ; last treatment date
+5 ; Output: LTD -- Last Treatment Date (really last date seen at
+6 ; the facility)
+7 ;
+8 NEW LTD,SDSTOP,X,Z,IVMQ
+9 ;
+10 ; - need a patient
+11 SET IVMQ=$GET(IVMQUERY("LTD"))
+12 IF '$GET(DFN)
SET LTD=0
GOTO LTDQ
+13 ;
+14 ; - if current inpatient, set LTD = today and quit
+15 IF $GET(^DPT(DFN,.105))
SET LTD=DT
GOTO LTDQ
+16 ;
+17 ; - get the last discharge date
+18 SET LTD=+$ORDER(^DGPM("ATID3",DFN,""))
if LTD
SET LTD=9999999.9999999-LTD\1
if LTD>DT
SET LTD=DT
+19 ;
+20 ; - get the last registration date and compare to LTD
+21 SET X=+$ORDER(^DPT(DFN,"DIS",0))
IF X
SET X=9999999-X\1
if X>LTD
SET LTD=X
+22 ;
+23 ; - get the last appointment or stop after LTD (if any)
+24 KILL ^TMP("DIERR",$JOB)
+25 ;clear QUERY results
IF $GET(IVMQ)
DO ACTIVE^SDQ(.IVMQ,"FALSE","SET")
+26 IF '$GET(IVMQ)
Begin DoDot:1
+27 DO OPEN^SDQ(.IVMQ)
if '$GET(IVMQ)
QUIT
+28 DO INDEX^SDQ(.IVMQ,"PATIENT/DATE","SET")
+29 DO SCANCB^SDQ(.IVMQ,"I $S($P(SDOE0,U,8)=2:1,$P(SDOE0,U,8)=1:$$APPT^IVMUFNC(SDOE0),1:0) S LTD=SDOE0\1,SDSTOP=1","SET")
+30 SET IVMQUERY("LTD")=IVMQ
End DoDot:1
+31 ;
+32 DO PAT^SDQ(.IVMQ,DFN,"SET")
+33 DO DATE^SDQ(.IVMQ,LTD+.000001,9999999,"SET")
+34 DO ACTIVE^SDQ(.IVMQ,"TRUE","SET")
+35 DO SCAN^SDQ(.IVMQ,"BACKWARD")
+36 KILL ^TMP("DIERR",$JOB)
+37 ;
LTDQ ;
+1 QUIT $SELECT(LTD:$$HLDATE^HLFNC(LTD),1:HLQ)
+2 ;
APPT(SDOE0) ;Determine if appt associated with encounter is in a valid state
+1 ; Quit when Outpatient Encounter STATUS is CHECKED OUT
+2 if $PIECE(SDOE0,U,12)=2
QUIT 1
+3 ; Quit when Outpatient Encounter STATUS is ACTION REQUIRED and the
+4 ; Appointment Status is SCHEDULED/KEPT
+5 NEW DGARRAY,SDCNT,SDSTAT,SDDTTM
SET DGARRAY("FLDS")=3
SET DGARRAY(4)=+$PIECE(SDOE0,U,2)
+6 SET DGARRAY(1)=$PIECE(SDOE0,U)
SET DGARRAY("SORT")="P"
SET DGARRAY("MAX")=1
+7 SET SDCNT=$$SDAPI^SDAMA301(.DGARRAY)
SET SDSTAT=""
+8 IF SDCNT>0
Begin DoDot:1
+9 SET SDDTTM=$ORDER(^TMP($JOB,"SDAMA301",DGARRAY(4),0))
+10 IF SDDTTM
SET SDSTAT=$PIECE($PIECE($GET(^TMP($JOB,"SDAMA301",DGARRAY(4),SDDTTM)),U,3),";")
End DoDot:1
+11 KILL ^TMP($JOB,"SDAMA301")
+12 if (($PIECE(SDOE0,U,12)=14)&(SDSTAT="R"))
QUIT 1
+13 QUIT 0
+14 ;
OUTTR(IVMINT,IVMPAR,IVMST) ; - Transform IVMINT to a displayable value
+1 ; Input: IVMINT -- internal value of demographic element
+2 ; received from IVM
+3 ; IVMPAR -- Zeroth node of the entry in file #301.92
+4 ; for the demographic element IVMINT
+5 ; IVMST -- [optional] pointer to the STATE (#5) file
+6 ; Required to transform the county code
+7 ; Output: IVMOUT -- Displayable value for IVMINT
+8 ;
+9 NEW IVMOUT,Z
SET IVMOUT=IVMINT
+10 IF $GET(IVMINT)=""!($GET(IVMPAR)="")
SET IVMOUT=""
GOTO OUTTRQ
+11 ;
+12 ; - use special transform for county
+13 IF $GET(IVMST)
IF $PIECE(IVMPAR,"^",2)="PID12"
SET IVMOUT=$PIECE($GET(^DIC(5,IVMST,1,IVMINT,0)),"^")
+14 ;
+15 ; - transform the internal value if necessary
+16 IF $PIECE(IVMPAR,"^",6)
SET IVMOUT=$$EXPAND($PIECE(IVMPAR,"^",4),$PIECE(IVMPAR,"^",5),IVMINT)
+17 ;
OUTTRQ QUIT IVMOUT
+1 ;
+2 ;
EXPAND(FILE,FIELD,VALUE) ; - returns internal data in an output format
+1 NEW Y,C
SET Y=VALUE
+2 IF 'FILE!('FIELD)!(VALUE="")
GOTO EXPQ
+3 SET Y=VALUE
SET C=$PIECE(^DD(FILE,FIELD,0),"^",2)
DO Y^DIQ
EXPQ QUIT Y
+1 ;
+2 ;
GETPAT(DFN,IVMPAT) ;
+1 ; Description: Used to obtain identifying information for a patient
+2 ; in the PATIENT file and place it in the IVMPAT() array.
+3 ;
+4 ; Input:
+5 ; DFN - ien of patient in PATIENT file
+6 ;
+7 ; Output:
+8 ; Function Value - 1 on success, 0 on failure
+9 ; IVMPAT - (pass by reference) On success, this array will contain
+10 ; the patient identifing information. Array subscripts are:
+11 ; "DFN" - ien PATIENT file
+12 ; "NAME" - patient name
+13 ; "SSN" - patient Social Security Number
+14 ; "DOB" - patient date of birth (FM format)
+15 ; "SEX" - patient sex
+16 ; "ICN" - patient ICN
+17 ;
+18 NEW IVMNODE
+19 if '$GET(DFN)
QUIT 0
+20 KILL IVMPAT
SET IVMPAT=""
+21 ;
+22 ; obtain patient record
+23 SET IVMNODE=$GET(^DPT(DFN,0))
+24 if IVMNODE=""
QUIT 0
+25 ;
+26 SET IVMPAT("DFN")=DFN
+27 SET IVMPAT("NAME")=$PIECE(IVMNODE,"^")
+28 SET IVMPAT("SEX")=$PIECE(IVMNODE,"^",2)
+29 SET IVMPAT("DOB")=$PIECE(IVMNODE,"^",3)
+30 SET IVMPAT("SSN")=$PIECE(IVMNODE,"^",9)
+31 SET IVMPAT("ICN")=$$GETICN^MPIF001(DFN)
+32 QUIT 1
+33 ;
LOOKUP(SSN,DOB,SEX,ERROR) ;
+1 ;Description: This function will do a search for the patient based on
+2 ;the identifying information provided. The function will be successful
+3 ;only if a single patient is found matching the identifiers provided.
+4 ;
+5 ;Inputs:
+6 ; SSN - patient Social Security Number
+7 ; DOB - patient date of birth (FM format)
+8 ; SEX - patient sex
+9 ;Outputs:
+10 ; Function Value - patient DFN if successful, 0 otherwise
+11 ; ERROR - if unsuccessful, an error message is returned (optional, pass by reference)
+12 ;
+13 NEW DFN,NODE
+14 ;
+15 IF $GET(SSN)=""
SET ERROR="INVALID SSN"
QUIT 0
+16 SET DFN=$ORDER(^DPT("SSN",SSN,0))
+17 IF 'DFN
SET ERROR="SSN NOT FOUND"
QUIT 0
+18 IF $ORDER(^DPT("SSN",SSN,DFN))
SET ERROR="MULTIPLE PATIENTS MATCHING SSN"
QUIT 0
+19 SET NODE=$GET(^DPT(DFN,0))
+20 IF $PIECE(NODE,"^",2)'=SEX
SET ERROR="SEX DOES NOT MATCH"
QUIT 0
+21 IF $EXTRACT($PIECE(NODE,"^",3),1,3)'=$EXTRACT(DOB,1,3)
SET ERROR="DOB DOES NOT MATCH"
QUIT 0
+22 IF $EXTRACT($PIECE(NODE,"^",3),4,5)
IF $EXTRACT($PIECE(NODE,"^",3),4,5)'=$EXTRACT(DOB,4,5)
SET ERROR="DOB DOES NOT MATCH"
QUIT 0
+23 QUIT DFN
+24 ;
MATCH(DFN,ICN,DOB,SEX,CFLG,ERROR) ;
+1 ;Description: This function will try to match the patient based on
+2 ;the identifying information provided. The function will be
+3 ;successful only if the patient is found matching the identifiers
+4 ;provided.
+5 ;
+6 ;Inputs:
+7 ; DFN - patient DFN
+8 ; ICN - patient ICN
+9 ; DOB - patient date of birth (FM format)
+10 ; SEX - patient sex
+11 ; CFLG - Compare Flag (Default="IDS", I=ICN, D=DOB, S=Sex)
+12 ;Outputs:
+13 ; Function Value: 1 - patient matched successfully, 0 - otherwise
+14 ; ERROR - if unsuccessful, an error message is returned (optional, pass by reference)
+15 NEW NODE
+16 IF $GET(DFN)=""
SET ERROR="INVALID DFN"
QUIT 0
+17 IF $GET(CFLG)=""
SET CFLG="IDS"
+18 SET NODE=$GET(^DPT(DFN,0))
IF NODE=""
SET ERROR="DFN NOT FOUND"
QUIT 0
+19 IF CFLG["I"
IF $$GETICN^MPIF001(DFN)'=$GET(ICN)
SET ERROR="ICN DOES NOT MATCH"
QUIT 0
+20 IF CFLG["S"
IF $PIECE(NODE,"^",2)'=$GET(SEX)
SET ERROR="SEX DOES NOT MATCH"
QUIT 0
+21 IF CFLG["D"
IF $EXTRACT($PIECE(NODE,"^",3),1,3)'=$EXTRACT($GET(DOB),1,3)
SET ERROR="DOB DOES NOT MATCH"
QUIT 0
+22 IF CFLG["D"
IF $EXTRACT($PIECE(NODE,"^",3),4,5)
IF $EXTRACT($PIECE(NODE,"^",3),4,5)'=$EXTRACT($GET(DOB),4,5)
SET ERROR="DOB DOES NOT MATCH"
QUIT 0
+23 QUIT 1
PARSPID3(PID3,PID3ARY) ;
+1 ;Description: This function will parse seq 3 of PID segment
+2 ;Input : PID3 - Array for seq. 3 of PID segment
+3 ;Output: PID3ARY("NI") - Value - ICN
+4 ; PID3ARY("PI") - Value - DFN
+5 IF $DATA(PID3(3))
Begin DoDot:1
+6 IF $ORDER(PID3(3,""))
Begin DoDot:2
+7 SET COMP=0
FOR
SET COMP=$ORDER(PID3(3,COMP))
if COMP=""
QUIT
Begin DoDot:3
+8 IF $PIECE(PID3(3,COMP),$EXTRACT(HLECH),5)="PI"
SET PID3ARY("PI")=$PIECE(PID3(3,COMP),$EXTRACT(HLECH))
+9 IF $PIECE(PID3(3,COMP),$EXTRACT(HLECH),5)="NI"
SET PID3ARY("NI")=$PIECE(PID3(3,COMP),$EXTRACT(HLECH))
End DoDot:3
End DoDot:2
QUIT
+10 IF $PIECE(PID3(3),$EXTRACT(HLECH),5)="PI"
SET PID3ARY("PI")=$PIECE(PID3(3),$EXTRACT(HLECH))
End DoDot:1
+11 QUIT
