VAFHUTL ;ALB/CM/PHH/EG/GAH UTILITIES ROUTINE ; 10/18/06
;;5.3;Registration;**91,151,568,585,725**;Jun 06, 1996;Build 12
;
;
LTD(DFN) ;
;This function will find the last time seen at the facility
;
; Input: DFN -- pointer to the patient in file #2
;
; Output: FileMan Date/time ^ I,D,R,A,S ^ HL7 Date/time ^ Variable PTR
;
; I = inpatient, D = discharge, R = Registration, A = Appointment
; S = Stop Code
;
; If Unsuccessful, Output: -1^error message
;
N LTD,X,FLG,LAST,VARPTR
;
S FLG=""
; - need a patient
I '$G(DFN) Q "-1^Missing Parameters for LTD function"
;
; - if current inpatient, set LTD = today and quit
I $G(^DPT(DFN,.105)) S LTD=DT,FLG="I" I $D(^DGPM("ATID1",DFN)) S LAST=9999999.9999999-($O(^DGPM("ATID1",DFN,""))) G LTDQ
;
; - get the last discharge date
S LTD=+$O(^DGPM("ATID3",DFN,"")) S:LTD FLG="D",LAST=9999999.9999999-LTD,LTD=LAST\1 S:LTD>DT (LAST,LTD)=DT
;
; - get the last registration date and compare to LTD
S X=+$O(^DPT(DFN,"DIS",0)) I X S X=9999999-X S:(X\1)>LTD LAST=X,LTD=X\1,FLG="R",VARPTR=DFN_";DPT("
;
; - get the last appointment and compare to LTD
N SDDATE,SDARRAY,SDCLIEN,SDSTAT
S SDDATE=LTD,SDARRAY("FLDS")=3,SDARRAY(4)=DFN
I $$SDAPI^SDAMA301(.SDARRAY)>0 D
.S SDCLIEN=0
.F S SDCLIEN=$O(^TMP($J,"SDAMA301",DFN,SDCLIEN)) Q:'SDCLIEN!(SDDATE>DT) D
..F S SDDATE=$O(^TMP($J,"SDAMA301",DFN,SDCLIEN,SDDATE)) Q:'SDDATE!(SDDATE>DT) D
...S SDSTAT=$P($P(^TMP($J,"SDAMA301",DFN,SDCLIEN,SDDATE),"^",3),";")
...I SDSTAT="R" D
....S LAST=SDDATE,LTD=SDDATE\1,FLG="A"
....I $D(VARPTR) K VARPTR
K ^TMP($J,"SDAMA301")
;
; - get the last standalone after LTD
S X=$$GETLAST^SDOE(DFN,LTD_".9999")
I X S LAST=+$$SCE^DGSDU(X,1,0),LTD=LAST\1,FLG="S",VARPTR=X_";SCE("
;
LTDQ I '$D(LAST) Q "-1^No last date"
I '$D(VARPTR) S VARPTR=$$VPTR(FLG,DFN,LAST)
I +VARPTR<1 Q "-1^No last date"
Q LAST_"^"_FLG_"^"_$$HLDATE^HLFNC(LAST,"TS")_"^"_VARPTR
;
;
VPTR(TYPE,DFN,EDATE) ;
;Gets pointer for inpatient/outpatient event
;
I '$D(TYPE)!('$D(DFN))!('$D(EDATE)) Q "-1^Missing Parameters for VPTR function"
N PTR,IND
I TYPE'="A"&(TYPE'="D")&(TYPE'="I") Q "-1^NOT IN or OUT PATIENT"
I TYPE="I"!(TYPE="D") D
.;inpatient or discharge
.S IND=$O(^DGPM("APID",DFN,"")),PTR=$O(^DGPM("APID",DFN,IND,""))
.I $D(^DGPM(PTR)) S PTR="-1^MISSING ENTRY"
.I +PTR>0 S PTR=PTR_";DGPM("
I TYPE="A" D
.;outpatient appointment
.I $D(^SCE("ADFN",DFN,LAST)) S PTR=$O(^SCE("ADFN",DFN,LAST,"")) S:('$D(^SCE(+PTR,0))) PTR=DFN_";DPT(" S:($D(^SCE(+PTR,0))) PTR=PTR_";SCE("
.I '$D(^SCE("ADFN",DFN,LAST)) S PTR=DFN_";DPT("
Q PTR
;
GETF(SEG) ;NOT USED ANY MORE
;This function will return all of the available fields for the SEG
;segment as found in the HL7 DHCP PARAMETER file, as a string,
;separated by commas
;
;Input: SEG - HL7 Segment
;Output: Successful - string of field numbers seperated by commas
;If unsuccessful, -1^error message will be returned.
;
;NOTE: HL("SAN") must be defined as Sending Application in file 771
;N ENT,FLDS
;I '$D(HLENTRY)!('$D(SEG)) Q "-1^MISSING PARAMETERS"
;do lookup in #771 for HLENTRY
;S DIC="^HL(770,",DIC(0)="MQZ",X=HLENTRY D ^DIC
;I +Y<0 Q "-1^NO ENTRY IN FILE 771"
;S ENT=$P(^HL(770,+Y,0),"^",8) I ENT="" Q "-1^NO ENTRY IN APPLICATION FIELD"
;
N ENT,FLDS
I $G(HL("SAN"))]"",$G(SEG)]""
E Q "-1^MISSING PARAMETERS HL(SAN)!SEG"
;
S ENT=$O(^HL(771,"B",HL("SAN"),0))
I 'ENT Q "-1^NO ENTRY IN FILE 771"
;
S DIC="^HL(771,ENT,""SEG"",",X=SEG,DIC(0)="MQZ" D ^DIC
K DIC,X
I +Y<0 K Y Q "-1^NO ENTRY IN SUBFILE #771.05"
S FLDS=$P(^HL(771,ENT,"SEG",+Y,"F"),"^") K Y
Q FLDS
;
UPDATE(PIVOT,ADATE,APTR,REMOVE) ;
;
;This function will allow the updating of PIVOT number entry, updating
;EVENT DATE/TIME and the VARIABLE POINTER and setting of the DELETED
;field.
;
;Input: PIVOT - Pivot Number
; ADATE - Event Date/Time (new)
; APTR - Variable Pointer (new)
; REMOVE - 1 or null if 1 set DELETED field
;
;Output: 0 if successful
; -1^error message if not successful
;
I '$D(PIVOT) Q "-1^MISSING PARAMETERS"
I '$D(^VAT(391.71,"D",PIVOT)) Q "-1^NO PIVOT ENTRY"
I '$D(REMOVE) S REMOVE=""
I APTR?.N1";".A1"(" D
.I $P(APTR,";",2)="DPT(" S APTR="P.`"_+APTR
.I $P(APTR,";",2)="SCE(" S APTR="O.`"_+APTR
.I $P(APTR,";",2)="DGMP(" S APTR="I.`"_+APTR
S DA=$O(^VAT(391.71,"D",PIVOT,"")) I DA="" Q "-1^BAD CROSS REFERENCE"
S DIE="^VAT(391.71,",DIC(0)="MQZ",DR=""
I ADATE'="" S DR=DR_".01///"_ADATE_";"
I APTR'="" S DR=DR_".05///"_APTR_";"
S DR=DR_".07///"_REMOVE
L +^VAT(391.71,DA,0):5
I '$T Q "-1^Unable to lock entry in Pivot file"
D ^DIE L -^VAT(391.71,DA,0)
K DIE,DR,DIC,DA,X,Y
Q 0
;
SEND(VAR1) ;this function will test for the on/off parameter to send ADT messages.
;OUTPUTS 0 will indicate NOT to send
; 1 will indicate TO send
; 0 in second piece will indicate NOT to send HL7 v2.3
; 1 in second piece will indicate to send HL7 v2.3
N VAR1
S VAR1=$O(^DG(43,0))
I +VAR1 S VAR1=$P($G(^DG(43,VAR1,"HL7")),"^",2,3)
Q VAR1
;
HLQ(DATA) ;this function returns the value passed to it or HLQ
I $G(DATA)="" Q HLQ
Q DATA
;
NOSEND() ;function TURNS OFF the on/off parameter to send ADT messages.
; used by init to disable all ADT HL7 protocols
;
;OUTPUTS 1 will indicate it was SET NOT to send
; 0 will indicate it failed to SET IT NOT to send
;
N VAR1
S VAR1=$O(^DG(43,0))
I +VAR1 S $P(^DG(43,+VAR1,"HL7"),"^",2,3)="0^0" Q 0
Q 1
;
DPROTO(PNAM) ;returns 0 if protocol disabled field is not null, ie disabled
; returns 1 if protocol is NOT disabled
I $G(PNAM)]"",$P($G(^ORD(101,+$O(^ORD(101,"B",PNAM,0)),0)),"^",3)]"" Q 0
Q 1
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVAFHUTL 5813 printed Nov 22, 2024@18:13:50 Page 2
VAFHUTL ;ALB/CM/PHH/EG/GAH UTILITIES ROUTINE ; 10/18/06
+1 ;;5.3;Registration;**91,151,568,585,725**;Jun 06, 1996;Build 12
+2 ;
+3 ;
LTD(DFN) ;
+1 ;This function will find the last time seen at the facility
+2 ;
+3 ; Input: DFN -- pointer to the patient in file #2
+4 ;
+5 ; Output: FileMan Date/time ^ I,D,R,A,S ^ HL7 Date/time ^ Variable PTR
+6 ;
+7 ; I = inpatient, D = discharge, R = Registration, A = Appointment
+8 ; S = Stop Code
+9 ;
+10 ; If Unsuccessful, Output: -1^error message
+11 ;
+12 NEW LTD,X,FLG,LAST,VARPTR
+13 ;
+14 SET FLG=""
+15 ; - need a patient
+16 IF '$GET(DFN)
QUIT "-1^Missing Parameters for LTD function"
+17 ;
+18 ; - if current inpatient, set LTD = today and quit
+19 IF $GET(^DPT(DFN,.105))
SET LTD=DT
SET FLG="I"
IF $DATA(^DGPM("ATID1",DFN))
SET LAST=9999999.9999999-($ORDER(^DGPM("ATID1",DFN,"")))
GOTO LTDQ
+20 ;
+21 ; - get the last discharge date
+22 SET LTD=+$ORDER(^DGPM("ATID3",DFN,""))
if LTD
SET FLG="D"
SET LAST=9999999.9999999-LTD
SET LTD=LAST\1
if LTD>DT
SET (LAST,LTD)=DT
+23 ;
+24 ; - get the last registration date and compare to LTD
+25 SET X=+$ORDER(^DPT(DFN,"DIS",0))
IF X
SET X=9999999-X
if (X\1)>LTD
SET LAST=X
SET LTD=X\1
SET FLG="R"
SET VARPTR=DFN_";DPT("
+26 ;
+27 ; - get the last appointment and compare to LTD
+28 NEW SDDATE,SDARRAY,SDCLIEN,SDSTAT
+29 SET SDDATE=LTD
SET SDARRAY("FLDS")=3
SET SDARRAY(4)=DFN
+30 IF $$SDAPI^SDAMA301(.SDARRAY)>0
Begin DoDot:1
+31 SET SDCLIEN=0
+32 FOR
SET SDCLIEN=$ORDER(^TMP($JOB,"SDAMA301",DFN,SDCLIEN))
if 'SDCLIEN!(SDDATE>DT)
QUIT
Begin DoDot:2
+33 FOR
SET SDDATE=$ORDER(^TMP($JOB,"SDAMA301",DFN,SDCLIEN,SDDATE))
if 'SDDATE!(SDDATE>DT)
QUIT
Begin DoDot:3
+34 SET SDSTAT=$PIECE($PIECE(^TMP($JOB,"SDAMA301",DFN,SDCLIEN,SDDATE),"^",3),";")
+35 IF SDSTAT="R"
Begin DoDot:4
+36 SET LAST=SDDATE
SET LTD=SDDATE\1
SET FLG="A"
+37 IF $DATA(VARPTR)
KILL VARPTR
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+38 KILL ^TMP($JOB,"SDAMA301")
+39 ;
+40 ; - get the last standalone after LTD
+41 SET X=$$GETLAST^SDOE(DFN,LTD_".9999")
+42 IF X
SET LAST=+$$SCE^DGSDU(X,1,0)
SET LTD=LAST\1
SET FLG="S"
SET VARPTR=X_";SCE("
+43 ;
LTDQ IF '$DATA(LAST)
QUIT "-1^No last date"
+1 IF '$DATA(VARPTR)
SET VARPTR=$$VPTR(FLG,DFN,LAST)
+2 IF +VARPTR<1
QUIT "-1^No last date"
+3 QUIT LAST_"^"_FLG_"^"_$$HLDATE^HLFNC(LAST,"TS")_"^"_VARPTR
+4 ;
+5 ;
VPTR(TYPE,DFN,EDATE) ;
+1 ;Gets pointer for inpatient/outpatient event
+2 ;
+3 IF '$DATA(TYPE)!('$DATA(DFN))!('$DATA(EDATE))
QUIT "-1^Missing Parameters for VPTR function"
+4 NEW PTR,IND
+5 IF TYPE'="A"&(TYPE'="D")&(TYPE'="I")
QUIT "-1^NOT IN or OUT PATIENT"
+6 IF TYPE="I"!(TYPE="D")
Begin DoDot:1
+7 ;inpatient or discharge
+8 SET IND=$ORDER(^DGPM("APID",DFN,""))
SET PTR=$ORDER(^DGPM("APID",DFN,IND,""))
+9 IF $DATA(^DGPM(PTR))
SET PTR="-1^MISSING ENTRY"
+10 IF +PTR>0
SET PTR=PTR_";DGPM("
End DoDot:1
+11 IF TYPE="A"
Begin DoDot:1
+12 ;outpatient appointment
+13 IF $DATA(^SCE("ADFN",DFN,LAST))
SET PTR=$ORDER(^SCE("ADFN",DFN,LAST,""))
if ('$DATA(^SCE(+PTR,0)))
SET PTR=DFN_";DPT("
if ($DATA(^SCE(+PTR,0)))
SET PTR=PTR_";SCE("
+14 IF '$DATA(^SCE("ADFN",DFN,LAST))
SET PTR=DFN_";DPT("
End DoDot:1
+15 QUIT PTR
+16 ;
GETF(SEG) ;NOT USED ANY MORE
+1 ;This function will return all of the available fields for the SEG
+2 ;segment as found in the HL7 DHCP PARAMETER file, as a string,
+3 ;separated by commas
+4 ;
+5 ;Input: SEG - HL7 Segment
+6 ;Output: Successful - string of field numbers seperated by commas
+7 ;If unsuccessful, -1^error message will be returned.
+8 ;
+9 ;NOTE: HL("SAN") must be defined as Sending Application in file 771
+10 ;N ENT,FLDS
+11 ;I '$D(HLENTRY)!('$D(SEG)) Q "-1^MISSING PARAMETERS"
+12 ;do lookup in #771 for HLENTRY
+13 ;S DIC="^HL(770,",DIC(0)="MQZ",X=HLENTRY D ^DIC
+14 ;I +Y<0 Q "-1^NO ENTRY IN FILE 771"
+15 ;S ENT=$P(^HL(770,+Y,0),"^",8) I ENT="" Q "-1^NO ENTRY IN APPLICATION FIELD"
+16 ;
+17 NEW ENT,FLDS
+18 IF $GET(HL("SAN"))]""
IF $GET(SEG)]""
+19 IF '$TEST
QUIT "-1^MISSING PARAMETERS HL(SAN)!SEG"
+20 ;
+21 SET ENT=$ORDER(^HL(771,"B",HL("SAN"),0))
+22 IF 'ENT
QUIT "-1^NO ENTRY IN FILE 771"
+23 ;
+24 SET DIC="^HL(771,ENT,""SEG"","
SET X=SEG
SET DIC(0)="MQZ"
DO ^DIC
+25 KILL DIC,X
+26 IF +Y<0
KILL Y
QUIT "-1^NO ENTRY IN SUBFILE #771.05"
+27 SET FLDS=$PIECE(^HL(771,ENT,"SEG",+Y,"F"),"^")
KILL Y
+28 QUIT FLDS
+29 ;
UPDATE(PIVOT,ADATE,APTR,REMOVE) ;
+1 ;
+2 ;This function will allow the updating of PIVOT number entry, updating
+3 ;EVENT DATE/TIME and the VARIABLE POINTER and setting of the DELETED
+4 ;field.
+5 ;
+6 ;Input: PIVOT - Pivot Number
+7 ; ADATE - Event Date/Time (new)
+8 ; APTR - Variable Pointer (new)
+9 ; REMOVE - 1 or null if 1 set DELETED field
+10 ;
+11 ;Output: 0 if successful
+12 ; -1^error message if not successful
+13 ;
+14 IF '$DATA(PIVOT)
QUIT "-1^MISSING PARAMETERS"
+15 IF '$DATA(^VAT(391.71,"D",PIVOT))
QUIT "-1^NO PIVOT ENTRY"
+16 IF '$DATA(REMOVE)
SET REMOVE=""
+17 IF APTR?.N1";".A1"("
Begin DoDot:1
+18 IF $PIECE(APTR,";",2)="DPT("
SET APTR="P.`"_+APTR
+19 IF $PIECE(APTR,";",2)="SCE("
SET APTR="O.`"_+APTR
+20 IF $PIECE(APTR,";",2)="DGMP("
SET APTR="I.`"_+APTR
End DoDot:1
+21 SET DA=$ORDER(^VAT(391.71,"D",PIVOT,""))
IF DA=""
QUIT "-1^BAD CROSS REFERENCE"
+22 SET DIE="^VAT(391.71,"
SET DIC(0)="MQZ"
SET DR=""
+23 IF ADATE'=""
SET DR=DR_".01///"_ADATE_";"
+24 IF APTR'=""
SET DR=DR_".05///"_APTR_";"
+25 SET DR=DR_".07///"_REMOVE
+26 LOCK +^VAT(391.71,DA,0):5
+27 IF '$TEST
QUIT "-1^Unable to lock entry in Pivot file"
+28 DO ^DIE
LOCK -^VAT(391.71,DA,0)
+29 KILL DIE,DR,DIC,DA,X,Y
+30 QUIT 0
+31 ;
SEND(VAR1) ;this function will test for the on/off parameter to send ADT messages.
+1 ;OUTPUTS 0 will indicate NOT to send
+2 ; 1 will indicate TO send
+3 ; 0 in second piece will indicate NOT to send HL7 v2.3
+4 ; 1 in second piece will indicate to send HL7 v2.3
+5 NEW VAR1
+6 SET VAR1=$ORDER(^DG(43,0))
+7 IF +VAR1
SET VAR1=$PIECE($GET(^DG(43,VAR1,"HL7")),"^",2,3)
+8 QUIT VAR1
+9 ;
HLQ(DATA) ;this function returns the value passed to it or HLQ
+1 IF $GET(DATA)=""
QUIT HLQ
+2 QUIT DATA
+3 ;
NOSEND() ;function TURNS OFF the on/off parameter to send ADT messages.
+1 ; used by init to disable all ADT HL7 protocols
+2 ;
+3 ;OUTPUTS 1 will indicate it was SET NOT to send
+4 ; 0 will indicate it failed to SET IT NOT to send
+5 ;
+6 NEW VAR1
+7 SET VAR1=$ORDER(^DG(43,0))
+8 IF +VAR1
SET $PIECE(^DG(43,+VAR1,"HL7"),"^",2,3)="0^0"
QUIT 0
+9 QUIT 1
+10 ;
DPROTO(PNAM) ;returns 0 if protocol disabled field is not null, ie disabled
+1 ; returns 1 if protocol is NOT disabled
+2 IF $GET(PNAM)]""
IF $PIECE($GET(^ORD(101,+$ORDER(^ORD(101,"B",PNAM,0)),0)),"^",3)]""
QUIT 0
+3 QUIT 1
