VAFHCPV ;ALB/CM OUTPATIENT PV1 SEGMENT ; 22 Jan 2002 10:28 AM
;;5.3;Registration;**91,151,298,494,573,1015**;Aug 13, 1993;Build 21
;
;This routine generates the Outpatient PV1 segment
;for the Philly project
;
;07/12/00 ACS - Added Facility and Suffix to sequence 39
;
OPV1(DFN,EVENT,EVDT,VPTR,PSTR,PNUM) ;
;
;B
;DFN - Patient File
;EVENT - event number from pivot file
;EVDT - event date/time in FileMan format
;VPTR - variable pointer
;PSTSR - string of fields (if null - required fields, if "A" - supported
;fields, or string of fields separated by commas")
;PNUM - ID # - always 1 (optional)
;
N RESULT
S RESULT="PV1"_HLFS_HLFS_"O"
I '$D(DFN)!('$D(EVENT))!('$D(EVDT))!('$D(VPTR)) Q RESULT
I $D(EVENT) I EVENT'="" S NODE=$$PIVX^VAFHPIVT(EVENT,DFN,EVDT)
I $D(EVENT) I EVENT="" K EVENT
I '$D(EVENT) S NODE=$$PIVNW^VAFHPIVT(DFN,EVDT,2,VPTR),EVENT=$P(NODE,":")
I EVENT<1 Q RESULT
S NODE=$P(NODE,":",2)
I NODE="" S REMOVED="Y"
;
EN ;
N PV1,EVTY,LOC,LOOP,HLD,PIVOT,QUOT
S QUOT=""""""
I '$D(PNUM) S PNUM=1
I $G(PSTR)="A" S PSTR=",2,3,7,10,44,45,50,"
I $G(PSTR)'="" S PSTR=","_PSTR_","
I $G(PSTR)="" S PSTR=""
I +PSTR=-1 Q RESULT
I $D(REMOVED) S $P(PV1,HLFS,50)=+EVENT,$P(PV1,HLFS,2)="O",$P(PV1,HLFS,1)=PNUM,PV1="PV1"_HLFS_PV1 K REMOVED Q PV1
S (PIVOT,PV1)="",EVTY="O",LOOP=0
; Empty PV1 segment:
S $P(PV1,HLFS,2)="O"
;
;F S LOOP=LOOP+1,HLD=$P(PSTR,",",LOOP) Q:HLD="" D
;.I HLD=2 S $P(PV1,HLFS,2)=EVTY Q
;.I HLD=3 S $P(PV1,HLFS,3)=$$CLINIC(NODE) Q
;.I HLD=7 S $P(PV1,HLFS,7)=$$OUTPRO(NODE) Q
;.;patient type for v2.3
;.I HLD=18 DO Q
;. .I +$G(^DPT(DFN,"TYPE")) DO
;. . .S $P(RESULT,HLFS,18)=$P($G(^DG(391,+^("TYPE"),0)),"^",1)
;. .E S $P(RESULT,HLFS,18)=HLQ
;.I HLD=44 S $P(PV1,HLFS,44)=$$HLDATE^HLFNC(EVDT) Q
;.I HLD=50 S $P(PV1,HLFS,50)=EVENT Q
;
I PSTR[",3," S $P(PV1,HLFS,3)=$$CLINIC(NODE)
I PSTR[",7," S $P(PV1,HLFS,7)=$$OUTPRO(NODE)
;.;patient type for v2.3
I PSTR[18 DO
.I +$G(^DPT(DFN,"TYPE")) DO
. .S $P(PV1,HLFS,18)=$P($G(^DG(391,+^("TYPE"),0)),"^",1)
. .E S $P(PV1,HLFS,18)=HLQ
;
; facility and suffix
;
I PSTR[39 D
. N VAFACSUF,VAMEDCTR,GLOB
. S GLOB="^"_$P(VPTR,";",2)_+VPTR
. ;
. ; If variable pointer is for patient file:
. I GLOB["DPT(" D
. . N PATNODE S PATNODE=""
. . I '$D(^DPT(DFN)) Q
. . F S PATNODE=$O(^DPT(DFN,"DIS",PATNODE)) D Q:PATNODE=""
. . . N PATDATA,VAFILE
. . . Q:PATNODE=""
. . . S PATDATA=$G(^DPT(DFN,"DIS",PATNODE,0))
. . . ; Spin through multiple events and get division pointer
. . . I EVDT=$P(PATDATA,"^",1) D Q:VAFILE="MATCH"
. . . . S VAMEDCTR=$P(PATDATA,"^",4) I VAMEDCTR="" S VAFILE="" Q
. . . . ; get facility/suffix from medical center div file
. . . . S VAFACSUF=$P($G(^DG(40.8,VAMEDCTR,0)),"^",2)
. . . . ; move data into the PV1 segment
. . . . S $P(PV1,HLFS,39)=$S(VAFACSUF]"":VAFACSUF,1:HLQ)
. . . . S VAFILE="MATCH",PATNODE=""
. . . . Q
. . . Q
. . Q
. ; If variable pointer is for outpatient encounter file:
. I GLOB["^SCE(" D
. . N VAFIEN,ENCDATA,ENCDATE
. . ; get encounter date and medical center division
. . S VAFIEN=+VPTR Q:VAFIEN=""
. . I '$D(^SCE(VAFIEN)) Q
. . S ENCDATA=$G(^SCE(VAFIEN,0))
. . S ENCDATE=$P(ENCDATA,"^",1) Q:ENCDATE=""
. . S VAMEDCTR=$P(ENCDATA,"^",11) Q:VAMEDCTR=""
. . ; call below returns: inst pointer^inst name^facility w/suffix
. . S VAFACSUF=$$SITE^VASITE(ENCDATE,VAMEDCTR)
. . S VAFACSUF=$P(VAFACSUF,"^",3)
. . ; move data into the PV1 segment
. . S $P(PV1,HLFS,39)=$S(VAFACSUF]"":VAFACSUF,1:HLQ)
. . Q
. ;
. ; If variable pointer is for patient movement file:
. I GLOB["^DGPM(" D
. . N VAFIEN,VAFDATE,VAWARD
. . ; get movement date and medical center division
. . S VAFIEN=+VPTR Q:VAFIEN=""
. . I '$D(^DGPM(VAFIEN)) Q
. . S VAFDATE=$P($G(^DGPM(VAFIEN,0)),"^",1) Q:VAFDATE=""
. . S VAWARD=$P($G(^DGPM(VAFIEN,0)),"^",6) Q:VAWARD=""
. . S VAMEDCTR=$P($G(^DIC(42,VAWARD,0)),"^",11) Q:VAMEDCTR=""
. . ; call below returns: inst pointer^inst name^facility w/suffix
. . S VAFACSUF=$$SITE^VASITE(VAFDATE,VAMEDCTR)
. . S VAFACSUF=$P(VAFACSUF,"^",3)
. . ; move data into the PV1 segment
. . S $P(PV1,HLFS,39)=$S(VAFACSUF]"":VAFACSUF,1:HLQ)
. . Q
. Q
;
I PSTR[44 S $P(PV1,HLFS,44)=$$HLDATE^HLFNC(EVDT)
I PSTR[50 S $P(PV1,HLFS,50)=EVENT
;
I PV1?1"^"."^" Q RESULT
S $P(PV1,HLFS,1)=PNUM,PV1="PV1"_HLFS_PV1
K NODE,QUOT
Q PV1
;
CLINIC(ZNODE) ;
;Get clinic for appointments and add/edit stop codes
;
N HPTR,HLOC,GLOB,LOC
;
;HPTR=fifth piece in pivot file - Variable pointer
;
S (HLOC,LOC)="",HPTR=$P(ZNODE,"^",5),GLOB="^"_$P(HPTR,";",2)_+HPTR_")"
I $E(GLOB,1,5)="^DPT(" D
.;Patient file, appointment hasn't gotten to outpatient encounter file
.S HLOC=$P($G(@GLOB@("S",$P(NODE,"^"),0)),"^")
;
I $E(GLOB,1,5)="^SCE(" D
.N VAENC0
.;Outpatient Encounter file
.S HLOC=$$SCE^DGSDU(+$P(GLOB,"^SCE(",2),4,0)
;
I HLOC="" Q QUOT
;HLOC is IEN of Hospital Location file
S LOC=$P($G(^SC(HLOC,0)),"^")
I LOC="" S LOC=QUOT
Q LOC
;
OUTPRO(ZNODE) ;
;
N OUTPTR,OPRV,OPTR,FILE,PTR
;
;OUTPTR=fifth piece in pivot file - variable pointer
;
S OUTPTR=$P(ZNODE,"^",5),OPTR=+OUTPTR,FILE=$P(OUTPTR,";",2)
I OPTR=""!(FILE'="SCE(") Q ""
;
;get primary provider
S OPRV=$$GETPRO(OPTR) I OPRV DO Q OPRV
. I $P($G(^VA(200,OPRV,0)),"^")]"" DO
. . N DGNAME S DGNAME("FILE")=200,DGNAME("IENS")=OPRV,DGNAME("FIELD")=.01
. . S OPRV=OPRV_$E(HLECH)_$$HLNAME^XLFNAME(.DGNAME,"S",$E($G(HLECH)))
. E S OPRV=QUOT
;
Q QUOT
;
GETPRO(OPTR) ;get first primary provider Returns OPRV or 0
N VAENC0,VAEPRV,VAP
S VAENC0=$$SCE^DGSDU(OPTR)
I OPTR,+VAENC0,$$DATE^SCDXUTL(+VAENC0)
E Q 0
;
S OPRV=0
D GETPRV^SDOE(OPTR,"VAEPRV")
S VAP=0 F S VAP=$O(VAEPRV(VAP)) Q:'VAP I $P(VAEPRV(VAP),"^",4)="P" S OPRV=+VAEPRV(VAP)_"^P" Q
Q +OPRV
VAFHCPV ;ALB/CM OUTPATIENT PV1 SEGMENT ; 22 Jan 2002 10:28 AM
+1 ;;5.3;Registration;**91,151,298,494,573,1015**;Aug 13, 1993;Build 21
+2 ;
+3 ;This routine generates the Outpatient PV1 segment
+4 ;for the Philly project
+5 ;
+6 ;07/12/00 ACS - Added Facility and Suffix to sequence 39
+7 ;
OPV1(DFN,EVENT,EVDT,VPTR,PSTR,PNUM) ;
+1 ;
+2 ;B
+3 ;DFN - Patient File
+4 ;EVENT - event number from pivot file
+5 ;EVDT - event date/time in FileMan format
+6 ;VPTR - variable pointer
+7 ;PSTSR - string of fields (if null - required fields, if "A" - supported
+8 ;fields, or string of fields separated by commas")
+9 ;PNUM - ID # - always 1 (optional)
+10 ;
+11 NEW RESULT
+12 SET RESULT="PV1"_HLFS_HLFS_"O"
+13 IF '$DATA(DFN)!('$DATA(EVENT))!('$DATA(EVDT))!('$DATA(VPTR))
QUIT RESULT
+14 IF $DATA(EVENT)
IF EVENT'=""
SET NODE=$$PIVX^VAFHPIVT(EVENT,DFN,EVDT)
+15 IF $DATA(EVENT)
IF EVENT=""
KILL EVENT
+16 IF '$DATA(EVENT)
SET NODE=$$PIVNW^VAFHPIVT(DFN,EVDT,2,VPTR)
SET EVENT=$PIECE(NODE,":")
+17 IF EVENT<1
QUIT RESULT
+18 SET NODE=$PIECE(NODE,":",2)
+19 IF NODE=""
SET REMOVED="Y"
+20 ;
EN ;
+1 NEW PV1,EVTY,LOC,LOOP,HLD,PIVOT,QUOT
+2 SET QUOT=""""""
+3 IF '$DATA(PNUM)
SET PNUM=1
+4 IF $GET(PSTR)="A"
SET PSTR=",2,3,7,10,44,45,50,"
+5 IF $GET(PSTR)'=""
SET PSTR=","_PSTR_","
+6 IF $GET(PSTR)=""
SET PSTR=""
+7 IF +PSTR=-1
QUIT RESULT
+8 IF $DATA(REMOVED)
SET $PIECE(PV1,HLFS,50)=+EVENT
SET $PIECE(PV1,HLFS,2)="O"
SET $PIECE(PV1,HLFS,1)=PNUM
SET PV1="PV1"_HLFS_PV1
KILL REMOVED
QUIT PV1
+9 SET (PIVOT,PV1)=""
SET EVTY="O"
SET LOOP=0
+10 ; Empty PV1 segment:
+11 SET $PIECE(PV1,HLFS,2)="O"
+12 ;
+13 ;F S LOOP=LOOP+1,HLD=$P(PSTR,",",LOOP) Q:HLD="" D
+14 ;.I HLD=2 S $P(PV1,HLFS,2)=EVTY Q
+15 ;.I HLD=3 S $P(PV1,HLFS,3)=$$CLINIC(NODE) Q
+16 ;.I HLD=7 S $P(PV1,HLFS,7)=$$OUTPRO(NODE) Q
+17 ;.;patient type for v2.3
+18 ;.I HLD=18 DO Q
+19 ;. .I +$G(^DPT(DFN,"TYPE")) DO
+20 ;. . .S $P(RESULT,HLFS,18)=$P($G(^DG(391,+^("TYPE"),0)),"^",1)
+21 ;. .E S $P(RESULT,HLFS,18)=HLQ
+22 ;.I HLD=44 S $P(PV1,HLFS,44)=$$HLDATE^HLFNC(EVDT) Q
+23 ;.I HLD=50 S $P(PV1,HLFS,50)=EVENT Q
+24 ;
+25 IF PSTR[",3,"
SET $PIECE(PV1,HLFS,3)=$$CLINIC(NODE)
+26 IF PSTR[",7,"
SET $PIECE(PV1,HLFS,7)=$$OUTPRO(NODE)
+27 ;.;patient type for v2.3
+28 IF PSTR[18
Begin DoDot:1
+29 IF +$GET(^DPT(DFN,"TYPE"))
Begin DoDot:2
+30 SET $PIECE(PV1,HLFS,18)=$PIECE($GET(^DG(391,+^("TYPE"),0)),"^",1)
+31 IF '$TEST
SET $PIECE(PV1,HLFS,18)=HLQ
End DoDot:2
End DoDot:1
+32 ;
+33 ; facility and suffix
+34 ;
+35 IF PSTR[39
Begin DoDot:1
+36 NEW VAFACSUF,VAMEDCTR,GLOB
+37 SET GLOB="^"_$PIECE(VPTR,";",2)_+VPTR
+38 ;
+39 ; If variable pointer is for patient file:
+40 IF GLOB["DPT("
Begin DoDot:2
+41 NEW PATNODE
SET PATNODE=""
+42 IF '$DATA(^DPT(DFN))
QUIT
+43 FOR
SET PATNODE=$ORDER(^DPT(DFN,"DIS",PATNODE))
Begin DoDot:3
+44 NEW PATDATA,VAFILE
+45 IF PATNODE=""
QUIT
+46 SET PATDATA=$GET(^DPT(DFN,"DIS",PATNODE,0))
+47 ; Spin through multiple events and get division pointer
+48 IF EVDT=$PIECE(PATDATA,"^",1)
Begin DoDot:4
+49 SET VAMEDCTR=$PIECE(PATDATA,"^",4)
IF VAMEDCTR=""
SET VAFILE=""
QUIT
+50 ; get facility/suffix from medical center div file
+51 SET VAFACSUF=$PIECE($GET(^DG(40.8,VAMEDCTR,0)),"^",2)
+52 ; move data into the PV1 segment
+53 SET $PIECE(PV1,HLFS,39)=$SELECT(VAFACSUF]"":VAFACSUF,1:HLQ)
+54 SET VAFILE="MATCH"
SET PATNODE=""
+55 QUIT
End DoDot:4
IF VAFILE="MATCH"
QUIT
+56 QUIT
End DoDot:3
IF PATNODE=""
QUIT
+57 QUIT
End DoDot:2
+58 ; If variable pointer is for outpatient encounter file:
+59 IF GLOB["^SCE("
Begin DoDot:2
+60 NEW VAFIEN,ENCDATA,ENCDATE
+61 ; get encounter date and medical center division
+62 SET VAFIEN=+VPTR
IF VAFIEN=""
QUIT
+63 IF '$DATA(^SCE(VAFIEN))
QUIT
+64 SET ENCDATA=$GET(^SCE(VAFIEN,0))
+65 SET ENCDATE=$PIECE(ENCDATA,"^",1)
IF ENCDATE=""
QUIT
+66 SET VAMEDCTR=$PIECE(ENCDATA,"^",11)
IF VAMEDCTR=""
QUIT
+67 ; call below returns: inst pointer^inst name^facility w/suffix
+68 SET VAFACSUF=$$SITE^VASITE(ENCDATE,VAMEDCTR)
+69 SET VAFACSUF=$PIECE(VAFACSUF,"^",3)
+70 ; move data into the PV1 segment
+71 SET $PIECE(PV1,HLFS,39)=$SELECT(VAFACSUF]"":VAFACSUF,1:HLQ)
+72 QUIT
End DoDot:2
+73 ;
+74 ; If variable pointer is for patient movement file:
+75 IF GLOB["^DGPM("
Begin DoDot:2
+76 NEW VAFIEN,VAFDATE,VAWARD
+77 ; get movement date and medical center division
+78 SET VAFIEN=+VPTR
IF VAFIEN=""
QUIT
+79 IF '$DATA(^DGPM(VAFIEN))
QUIT
+80 SET VAFDATE=$PIECE($GET(^DGPM(VAFIEN,0)),"^",1)
IF VAFDATE=""
QUIT
+81 SET VAWARD=$PIECE($GET(^DGPM(VAFIEN,0)),"^",6)
IF VAWARD=""
QUIT
+82 SET VAMEDCTR=$PIECE($GET(^DIC(42,VAWARD,0)),"^",11)
IF VAMEDCTR=""
QUIT
+83 ; call below returns: inst pointer^inst name^facility w/suffix
+84 SET VAFACSUF=$$SITE^VASITE(VAFDATE,VAMEDCTR)
+85 SET VAFACSUF=$PIECE(VAFACSUF,"^",3)
+86 ; move data into the PV1 segment
+87 SET $PIECE(PV1,HLFS,39)=$SELECT(VAFACSUF]"":VAFACSUF,1:HLQ)
+88 QUIT
End DoDot:2
+89 QUIT
End DoDot:1
+90 ;
+91 IF PSTR[44
SET $PIECE(PV1,HLFS,44)=$$HLDATE^HLFNC(EVDT)
+92 IF PSTR[50
SET $PIECE(PV1,HLFS,50)=EVENT
+93 ;
+94 IF PV1?1"^"."^"
QUIT RESULT
+95 SET $PIECE(PV1,HLFS,1)=PNUM
SET PV1="PV1"_HLFS_PV1
+96 KILL NODE,QUOT
+97 QUIT PV1
+98 ;
CLINIC(ZNODE) ;
+1 ;Get clinic for appointments and add/edit stop codes
+2 ;
+3 NEW HPTR,HLOC,GLOB,LOC
+4 ;
+5 ;HPTR=fifth piece in pivot file - Variable pointer
+6 ;
+7 SET (HLOC,LOC)=""
SET HPTR=$PIECE(ZNODE,"^",5)
SET GLOB="^"_$PIECE(HPTR,";",2)_+HPTR_")"
+8 IF $EXTRACT(GLOB,1,5)="^DPT("
Begin DoDot:1
+9 ;Patient file, appointment hasn't gotten to outpatient encounter file
+10 SET HLOC=$PIECE($GET(@GLOB@("S",$PIECE(NODE,"^"),0)),"^")
End DoDot:1
+11 ;
+12 IF $EXTRACT(GLOB,1,5)="^SCE("
Begin DoDot:1
+13 NEW VAENC0
+14 ;Outpatient Encounter file
+15 SET HLOC=$$SCE^DGSDU(+$PIECE(GLOB,"^SCE(",2),4,0)
End DoDot:1
+16 ;
+17 IF HLOC=""
QUIT QUOT
+18 ;HLOC is IEN of Hospital Location file
+19 SET LOC=$PIECE($GET(^SC(HLOC,0)),"^")
+20 IF LOC=""
SET LOC=QUOT
+21 QUIT LOC
+22 ;
OUTPRO(ZNODE) ;
+1 ;
+2 NEW OUTPTR,OPRV,OPTR,FILE,PTR
+3 ;
+4 ;OUTPTR=fifth piece in pivot file - variable pointer
+5 ;
+6 SET OUTPTR=$PIECE(ZNODE,"^",5)
SET OPTR=+OUTPTR
SET FILE=$PIECE(OUTPTR,";",2)
+7 IF OPTR=""!(FILE'="SCE(")
QUIT ""
+8 ;
+9 ;get primary provider
+10 SET OPRV=$$GETPRO(OPTR)
IF OPRV
Begin DoDot:1
+11 IF $PIECE($GET(^VA(200,OPRV,0)),"^")]""
Begin DoDot:2
+12 NEW DGNAME
SET DGNAME("FILE")=200
SET DGNAME("IENS")=OPRV
SET DGNAME("FIELD")=.01
+13 SET OPRV=OPRV_$EXTRACT(HLECH)_$$HLNAME^XLFNAME(.DGNAME,"S",$EXTRACT($GET(HLECH)))
End DoDot:2
+14 IF '$TEST
SET OPRV=QUOT
End DoDot:1
QUIT OPRV
+15 ;
+16 QUIT QUOT
+17 ;
GETPRO(OPTR) ;get first primary provider Returns OPRV or 0
+1 NEW VAENC0,VAEPRV,VAP
+2 SET VAENC0=$$SCE^DGSDU(OPTR)
+3 IF OPTR
IF +VAENC0
IF $$DATE^SCDXUTL(+VAENC0)
+4 IF '$TEST
QUIT 0
+5 ;
+6 SET OPRV=0
+7 DO GETPRV^SDOE(OPTR,"VAEPRV")
+8 SET VAP=0
FOR
SET VAP=$ORDER(VAEPRV(VAP))
IF 'VAP
QUIT
IF $PIECE(VAEPRV(VAP),"^",4)="P"
SET OPRV=+VAEPRV(VAP)_"^P"
QUIT
+9 QUIT +OPRV
