PXBGVST ;ISL/JVS - GATHER ENCOUNTERS ;8/28/96
;;1.0;PCE PATIENT CARE ENCOUNTER;**1**;Aug 12, 1996
;
;
;
VISITLST(DFN,BEGINDT,ENDDT,HLOC,SCREEN,APPOINT,PROMPT,COSTATUS) ;--GATHER VISITS
;
; DFN = Patient Identification entry number (required)
; BEGINDT = Begining date of date range-INTERNAL FORMAT (optional)
; ENDDT = Ending date of date range-INTERNAL FORMAT (optional)
; HLOC = Hospital Location (pointer to file#44) (optional)
; SCREEN = Code as related to field 15003 (optional)
;
; ..'A'=ANCILLARY
; ..'P'=PRIMARY
; ..'O'=OCCASION OF SERIVCE
; ..'S'=STOP CODES
; ..'X'=All three above plus the 'NULL' Encounters (DEFAULT)
;
; ..'E'=Historical Encounters ('XE' for all historical visits)
;
; APPOINT
; ..-1
; ..0
; ..1
; OUTPUT:
; >0 = VISIT IEN
; =0 = User selected to add a visit
; -1 = No visit selected
; -2^"TEXT" = error of some kind^mesage about error
;
;
;--Validate A PATIENT visit is sent in
I $G(DFN)<1 Q -2_"^"_"NO PATIENT"
I '$D(^AUPNPAT(DFN)) Q -2_"^"_"NO SUCH PATIENT"
;
;--If no date range then default it
I BEGINDT<1500000!(ENDDT<1500000) D
. N X1,X2,%H,%T
. S X1=DT,X2=+$P(^PX(815,1,"LM"),"^",3) D C^%DTC S BEGINDT=$S(BEGINDT>X:BEGINDT,1:X)
. S X1=DT,X2=+$P(^PX(815,1,"LM"),"^",4) D C^%DTC S ENDDT=X
;
N STOP
I $G(HLOC) D Q:$G(STOP) -2_"^"_"NO SUCH HOSPITAL LOCATION"
.I '$D(^SC(HLOC)) S STOP=1
;
;--NEW variables
N IEN,INDATEI,INDATEE,PXBC,PXBCC,VST,PXBI,SCRN,SCRN1,ENDDTT,BEGINDTT
N PXBHIGH,PXBCNT,PXBWIN,PXBSAVE,PXBDT,DEL,NOD0,NOD150,UID,STATUS
N HLOCE,HLOCI,VAL,VAR
S (PXBC,PXBCC)=0
;--KILL variables
K ^TMP("PXBU",$J),^UTILITY("DIQ1",$J),^TMP("PXBKY",$J),^TMP("PXBSAM",$J),^TMP("PXBSKY",$J),GROUP
;--CREATE tmp global
;-SET UP SCREEN
I $D(SCREEN) D
.S PXBI="" F PXBI=1:1:$L(SCREEN) S SCRN($E(SCREEN,PXBI))=""
.I '$D(SCRN) S SCRN("X")=""
I $D(^AUPNVSIT("AA",DFN)) D
.I $G(ENDDT) S ENDDTT=9999999-$P(ENDDT,".",1) S:ENDDT["." ENDDTT=ENDDTT_((ENDDT#1)-(.0001)) S:ENDDT'["." ENDDTT=(ENDDTT)-(.0001) S ENDDT=ENDDTT
.I $G(BEGINDT) S BEGINDTT=9999999-$P(BEGINDT,".",1) S:BEGINDT["." BEGINDTT=BEGINDTT_(BEGINDT#1) S:BEGINDT'["." BEGINDTT=BEGINDTT_".999999" S BEGINDT=BEGINDTT
.I '$G(BEGINDT) S BEGINDT=999999999
.S PXBDT=$S($G(ENDDT):ENDDT,1:"")
.F S PXBDT=$O(^AUPNVSIT("AA",DFN,PXBDT)) Q:PXBDT>BEGINDT Q:PXBDT'>0 D
..S IEN=0 F S IEN=$O(^AUPNVSIT("AA",DFN,PXBDT,IEN)) Q:IEN="" D
...;
...;-----SCREEN-------
...;----BRING IN ALL NODES
...S NOD0=$G(^AUPNVSIT(IEN,0)),NOD150=$G(^AUPNVSIT(IEN,150))
...;--SCREEN OUT HISTORICAL VISITS
...I $D(SCRN("E")),$P(NOD0,"^",7)'="E" Q
...I '$D(SCRN("E")),$P(NOD0,"^",7)="E" Q
...;--SCREEN BASED ON PARAMETER
...S SCRN1=$P(NOD150,"^",3)
...I SCRN1="",'$D(SCRN("X")) Q
...I $D(SCRN("X")) G CON
...I SCRN1="A",'$D(SCRN("A")) Q
...I SCRN1="O",'$D(SCRN("O")) Q
...I SCRN1="P",'$D(SCRN("P")) Q
...I SCRN1="S",'$D(SCRN("S")) Q
...I SCRN1="C",'$D(SCRN("C")) Q
CON ...;--CONTINUE
...;--HOSPITAL LOCATION
...I $G(HLOC) Q:$P(NOD0,"^",22)'=HLOC
...I $G(APPOINT)=0 G END
...;--I RELATED TO APPOINTMENT--APPOINT=1
...;I $G(APPOINT)>0,$P(NOD0,"^",22)'=+$G(^DPT(DFN,"S",$P(NOD0,"^",1),0)) Q
...I $G(APPOINT)>0,'$$VSTAPPT^PXUTL1(DFN,$P(NOD0,"^",1),$P(NOD0,"^",22),IEN) Q
...;--I NOT RELATED TO AN APPOINTMENT--APPOINT=-1
...;I $G(APPOINT)<0,$P(NOD0,"^",22)=+$G(^DPT(DFN,"S",$P(NOD0,"^",1),0)) Q
...I $G(APPOINT)<0,$$VSTAPPT^PXUTL1(DFN,$P(NOD0,"^",1),$P(NOD0,"^",22),IEN) Q
END ...;---END OF SCREENS-----
...;--DISPOSITIONS
...I $$DISPOSIT^PXUTL1(DFN,$P(NOD0,"^",1),IEN) Q
...;
...S PXBC=PXBC+1
...S ^TMP("PXBU",$J,"VST",IEN)=""
K SCRN,SCRN1
;
;
A ;--Set array with the VISITS from the visits
N DIQ,PRIME,PRIMI,PXBDT,VSTDTE,VSTDTI,GROUP
I $D(^TMP("PXBU",$J,"VST")) D
.S IEN=0 F S IEN=$O(^TMP("PXBU",$J,"VST",IEN)) Q:IEN'>0 D
..S DIC=9000010,DR=".01;.22;15003;15001",DA=IEN,DIQ(0)="EI" D EN^DIQ1
..S VSTDTE=$G(^UTILITY("DIQ1",$J,9000010,DA,.01,"E"))
..S VSTDTE=$P(VSTDTE,"@",1)_" "_$P($P(VSTDTE,"@",2),":",1,2)
..S VSTDTI=$G(^UTILITY("DIQ1",$J,9000010,DA,.01,"I"))
..S HLOCE=$G(^UTILITY("DIQ1",$J,9000010,DA,.22,"E"))
..S HLOCI=$G(^UTILITY("DIQ1",$J,9000010,DA,.22,"I"))
..S PRIME=$G(^UTILITY("DIQ1",$J,9000010,DA,15003,"E"))
..S PRIMI=$G(^UTILITY("DIQ1",$J,9000010,DA,15003,"I"))
..S UID=$G(^UTILITY("DIQ1",$J,9000010,DA,15001,"E"))
..S STATUS=$P($$STATUS^SDPCE(IEN),"^",2)
..S GROUP=VSTDTE_"^"_VSTDTI_"^"_HLOCE_"^"_HLOCI_"^"_PRIME_"^"_PRIMI_"^"_UID_"^"_STATUS
..S ^TMP("PXBVSTG",$J,VSTDTI,IEN)=GROUP
K DIC,DR,DA
;
;
B ;--ADD Line Numbers
I $D(^TMP("PXBVSTG",$J)) D
.S PXBCC=PXBC+1,VST="" F S VST=$O(^TMP("PXBVSTG",$J,VST)) Q:VST="" D
..S IEN=0 F S IEN=$O(^TMP("PXBVSTG",$J,VST,IEN)) Q:IEN="" S PXBCC=PXBCC-1 D
...S ^TMP("PXBKY",$J,VST,PXBCC)=$G(^TMP("PXBVSTG",$J,VST,IEN))
...S ^TMP("PXBSAM",$J,PXBCC)=$G(^TMP("PXBVSTG",$J,VST,IEN))
...S ^TMP("PXBSKY",$J,PXBCC,IEN)=""
;
F ;--FINISH UP THE VARIABLES
K ^TMP("PXBU",$J),^UTILITY("DIQ1",$J)
S PXBCNT=+$G(PXBC)
D DISP
Q VAL
;
;---GO TO PROMPTING
DISP ;--DISPLAY
;---------------NEW CURSOR CONTROL VARIABLE-----------------------
N IOARM0,IOARM1,IOAWM0,IOAWM1,IOBOFF,IOBON,IOCOMMA,IOCUB,IOCUD,IOCUF
N IOCUON,IOCUOFF,IOCUU,IODCH,IODHLB,IODHLT,IODL,IODWL,IOECH,IOEDALL
N IOEDBOP,IOEDEOP,IOEFLD,IOELALL,IOELBOL,IOELEOL,IOENTER,IOFIND
N IOHDWN,IOHOME,IOHTS,IOHUP,IOICH,IOIL,IOIND,IOINHI,IOINLOW,IOINORM
N IOINSERT,IOKP0,IOKP1,IOKP2,IOKP3,IOKP4,IOKP5,IOKP6,IOKP7,IOKP8,IOKP9
N IOIRM0,IOIRM1,IOKPAM,IOKPNM,IOMC,IOMINUS,IONEL,IONEXTSC,IOPERIOD
N IOPF1,IOPF2,IOPF3,IOPF4,IOPREVSC,IOPROB,IOPTCH10,IOPTCH12,IOPTCH16
N IORC,IOREMOVE,IORESET,IORI,IORVOFF,IORVON,IOSC,IOSGR0,IOSELECT
N IOSTBM,IOSWL,IOTBC,IOTBCALL,IOUOFF,IOUON,IOIS
;
;------------------------*******----------------------------------
D TERM^PXBCC
D FIX1^PXBCC
D HDR3^PXBUTL(DFN,1)
D REQ^PXBDREQ(8)
D EN0^PXBDVST
D LOC^PXBCC(15,0)
D WIN17^PXBCC(PXBCNT)
D VST^PXBPVST
D FULL0^PXBCC
D CLEAR1^PXBCC
K ^TMP("PXBKY",$J),^TMP("PXBSAM",$J),^TMP("PXBSKY",$J),^TMP("PXBVSTG",$J),^TMP("PXBU",$J),^TMP("PXBDVST",$J)
;
;
Q
;---END OF PROMPTING
PXBGVST ;ISL/JVS - GATHER ENCOUNTERS ;8/28/96
+1 ;;1.0;PCE PATIENT CARE ENCOUNTER;**1**;Aug 12, 1996
+2 ;
+3 ;
+4 ;
VISITLST(DFN,BEGINDT,ENDDT,HLOC,SCREEN,APPOINT,PROMPT,COSTATUS) ;--GATHER VISITS
+1 ;
+2 ; DFN = Patient Identification entry number (required)
+3 ; BEGINDT = Begining date of date range-INTERNAL FORMAT (optional)
+4 ; ENDDT = Ending date of date range-INTERNAL FORMAT (optional)
+5 ; HLOC = Hospital Location (pointer to file#44) (optional)
+6 ; SCREEN = Code as related to field 15003 (optional)
+7 ;
+8 ; ..'A'=ANCILLARY
+9 ; ..'P'=PRIMARY
+10 ; ..'O'=OCCASION OF SERIVCE
+11 ; ..'S'=STOP CODES
+12 ; ..'X'=All three above plus the 'NULL' Encounters (DEFAULT)
+13 ;
+14 ; ..'E'=Historical Encounters ('XE' for all historical visits)
+15 ;
+16 ; APPOINT
+17 ; ..-1
+18 ; ..0
+19 ; ..1
+20 ; OUTPUT:
+21 ; >0 = VISIT IEN
+22 ; =0 = User selected to add a visit
+23 ; -1 = No visit selected
+24 ; -2^"TEXT" = error of some kind^mesage about error
+25 ;
+26 ;
+27 ;--Validate A PATIENT visit is sent in
+28 IF $GET(DFN)<1
QUIT -2_"^"_"NO PATIENT"
+29 IF '$DATA(^AUPNPAT(DFN))
QUIT -2_"^"_"NO SUCH PATIENT"
+30 ;
+31 ;--If no date range then default it
+32 IF BEGINDT<1500000!(ENDDT<1500000)
Begin DoDot:1
+33 NEW X1,X2,%H,%T
+34 SET X1=DT
SET X2=+$PIECE(^PX(815,1,"LM"),"^",3)
DO C^%DTC
SET BEGINDT=$SELECT(BEGINDT>X:BEGINDT,1:X)
+35 SET X1=DT
SET X2=+$PIECE(^PX(815,1,"LM"),"^",4)
DO C^%DTC
SET ENDDT=X
End DoDot:1
+36 ;
+37 NEW STOP
+38 IF $GET(HLOC)
Begin DoDot:1
+39 IF '$DATA(^SC(HLOC))
SET STOP=1
End DoDot:1
IF $GET(STOP)
QUIT -2_"^"_"NO SUCH HOSPITAL LOCATION"
+40 ;
+41 ;--NEW variables
+42 NEW IEN,INDATEI,INDATEE,PXBC,PXBCC,VST,PXBI,SCRN,SCRN1,ENDDTT,BEGINDTT
+43 NEW PXBHIGH,PXBCNT,PXBWIN,PXBSAVE,PXBDT,DEL,NOD0,NOD150,UID,STATUS
+44 NEW HLOCE,HLOCI,VAL,VAR
+45 SET (PXBC,PXBCC)=0
+46 ;--KILL variables
+47 KILL ^TMP("PXBU",$JOB),^UTILITY("DIQ1",$JOB),^TMP("PXBKY",$JOB),^TMP("PXBSAM",$JOB),^TMP("PXBSKY",$JOB),GROUP
+48 ;--CREATE tmp global
+49 ;-SET UP SCREEN
+50 IF $DATA(SCREEN)
Begin DoDot:1
+51 SET PXBI=""
FOR PXBI=1:1:$LENGTH(SCREEN)
SET SCRN($EXTRACT(SCREEN,PXBI))=""
+52 IF '$DATA(SCRN)
SET SCRN("X")=""
End DoDot:1
+53 IF $DATA(^AUPNVSIT("AA",DFN))
Begin DoDot:1
+54 IF $GET(ENDDT)
SET ENDDTT=9999999-$PIECE(ENDDT,".",1)
IF ENDDT["."
SET ENDDTT=ENDDTT_((ENDDT#1)-(.0001))
IF ENDDT'["."
SET ENDDTT=(ENDDTT)-(.0001)
SET ENDDT=ENDDTT
+55 IF $GET(BEGINDT)
SET BEGINDTT=9999999-$PIECE(BEGINDT,".",1)
IF BEGINDT["."
SET BEGINDTT=BEGINDTT_(BEGINDT#1)
IF BEGINDT'["."
SET BEGINDTT=BEGINDTT_".999999"
SET BEGINDT=BEGINDTT
+56 IF '$GET(BEGINDT)
SET BEGINDT=999999999
+57 SET PXBDT=$SELECT($GET(ENDDT):ENDDT,1:"")
+58 FOR
SET PXBDT=$ORDER(^AUPNVSIT("AA",DFN,PXBDT))
IF PXBDT>BEGINDT
QUIT
IF PXBDT'>0
QUIT
Begin DoDot:2
+59 SET IEN=0
FOR
SET IEN=$ORDER(^AUPNVSIT("AA",DFN,PXBDT,IEN))
IF IEN=""
QUIT
Begin DoDot:3
+60 ;
+61 ;-----SCREEN-------
+62 ;----BRING IN ALL NODES
+63 SET NOD0=$GET(^AUPNVSIT(IEN,0))
SET NOD150=$GET(^AUPNVSIT(IEN,150))
+64 ;--SCREEN OUT HISTORICAL VISITS
+65 IF $DATA(SCRN("E"))
IF $PIECE(NOD0,"^",7)'="E"
QUIT
+66 IF '$DATA(SCRN("E"))
IF $PIECE(NOD0,"^",7)="E"
QUIT
+67 ;--SCREEN BASED ON PARAMETER
+68 SET SCRN1=$PIECE(NOD150,"^",3)
+69 IF SCRN1=""
IF '$DATA(SCRN("X"))
QUIT
+70 IF $DATA(SCRN("X"))
GOTO CON
+71 IF SCRN1="A"
IF '$DATA(SCRN("A"))
QUIT
+72 IF SCRN1="O"
IF '$DATA(SCRN("O"))
QUIT
+73 IF SCRN1="P"
IF '$DATA(SCRN("P"))
QUIT
+74 IF SCRN1="S"
IF '$DATA(SCRN("S"))
QUIT
+75 IF SCRN1="C"
IF '$DATA(SCRN("C"))
QUIT
CON ;--CONTINUE
+1 ;--HOSPITAL LOCATION
+2 IF $GET(HLOC)
IF $PIECE(NOD0,"^",22)'=HLOC
QUIT
+3 IF $GET(APPOINT)=0
GOTO END
+4 ;--I RELATED TO APPOINTMENT--APPOINT=1
+5 ;I $G(APPOINT)>0,$P(NOD0,"^",22)'=+$G(^DPT(DFN,"S",$P(NOD0,"^",1),0)) Q
+6 IF $GET(APPOINT)>0
IF '$$VSTAPPT^PXUTL1(DFN,$PIECE(NOD0,"^",1),$PIECE(NOD0,"^",22),IEN)
QUIT
+7 ;--I NOT RELATED TO AN APPOINTMENT--APPOINT=-1
+8 ;I $G(APPOINT)<0,$P(NOD0,"^",22)=+$G(^DPT(DFN,"S",$P(NOD0,"^",1),0)) Q
+9 IF $GET(APPOINT)<0
IF $$VSTAPPT^PXUTL1(DFN,$PIECE(NOD0,"^",1),$PIECE(NOD0,"^",22),IEN)
QUIT
END ;---END OF SCREENS-----
+1 ;--DISPOSITIONS
+2 IF $$DISPOSIT^PXUTL1(DFN,$PIECE(NOD0,"^",1),IEN)
QUIT
+3 ;
+4 SET PXBC=PXBC+1
+5 SET ^TMP("PXBU",$JOB,"VST",IEN)=""
End DoDot:3
End DoDot:2
End DoDot:1
+6 KILL SCRN,SCRN1
+7 ;
+8 ;
A ;--Set array with the VISITS from the visits
+1 NEW DIQ,PRIME,PRIMI,PXBDT,VSTDTE,VSTDTI,GROUP
+2 IF $DATA(^TMP("PXBU",$JOB,"VST"))
Begin DoDot:1
+3 SET IEN=0
FOR
SET IEN=$ORDER(^TMP("PXBU",$JOB,"VST",IEN))
IF IEN'>0
QUIT
Begin DoDot:2
+4 SET DIC=9000010
SET DR=".01;.22;15003;15001"
SET DA=IEN
SET DIQ(0)="EI"
DO EN^DIQ1
+5 SET VSTDTE=$GET(^UTILITY("DIQ1",$JOB,9000010,DA,.01,"E"))
+6 SET VSTDTE=$PIECE(VSTDTE,"@",1)_" "_$PIECE($PIECE(VSTDTE,"@",2),":",1,2)
+7 SET VSTDTI=$GET(^UTILITY("DIQ1",$JOB,9000010,DA,.01,"I"))
+8 SET HLOCE=$GET(^UTILITY("DIQ1",$JOB,9000010,DA,.22,"E"))
+9 SET HLOCI=$GET(^UTILITY("DIQ1",$JOB,9000010,DA,.22,"I"))
+10 SET PRIME=$GET(^UTILITY("DIQ1",$JOB,9000010,DA,15003,"E"))
+11 SET PRIMI=$GET(^UTILITY("DIQ1",$JOB,9000010,DA,15003,"I"))
+12 SET UID=$GET(^UTILITY("DIQ1",$JOB,9000010,DA,15001,"E"))
+13 SET STATUS=$PIECE($$STATUS^SDPCE(IEN),"^",2)
+14 SET GROUP=VSTDTE_"^"_VSTDTI_"^"_HLOCE_"^"_HLOCI_"^"_PRIME_"^"_PRIMI_"^"_UID_"^"_STATUS
+15 SET ^TMP("PXBVSTG",$JOB,VSTDTI,IEN)=GROUP
End DoDot:2
End DoDot:1
+16 KILL DIC,DR,DA
+17 ;
+18 ;
B ;--ADD Line Numbers
+1 IF $DATA(^TMP("PXBVSTG",$JOB))
Begin DoDot:1
+2 SET PXBCC=PXBC+1
SET VST=""
FOR
SET VST=$ORDER(^TMP("PXBVSTG",$JOB,VST))
IF VST=""
QUIT
Begin DoDot:2
+3 SET IEN=0
FOR
SET IEN=$ORDER(^TMP("PXBVSTG",$JOB,VST,IEN))
IF IEN=""
QUIT
SET PXBCC=PXBCC-1
Begin DoDot:3
+4 SET ^TMP("PXBKY",$JOB,VST,PXBCC)=$GET(^TMP("PXBVSTG",$JOB,VST,IEN))
+5 SET ^TMP("PXBSAM",$JOB,PXBCC)=$GET(^TMP("PXBVSTG",$JOB,VST,IEN))
+6 SET ^TMP("PXBSKY",$JOB,PXBCC,IEN)=""
End DoDot:3
End DoDot:2
End DoDot:1
+7 ;
F ;--FINISH UP THE VARIABLES
+1 KILL ^TMP("PXBU",$JOB),^UTILITY("DIQ1",$JOB)
+2 SET PXBCNT=+$GET(PXBC)
+3 DO DISP
+4 QUIT VAL
+5 ;
+6 ;---GO TO PROMPTING
DISP ;--DISPLAY
+1 ;---------------NEW CURSOR CONTROL VARIABLE-----------------------
+2 NEW IOARM0,IOARM1,IOAWM0,IOAWM1,IOBOFF,IOBON,IOCOMMA,IOCUB,IOCUD,IOCUF
+3 NEW IOCUON,IOCUOFF,IOCUU,IODCH,IODHLB,IODHLT,IODL,IODWL,IOECH,IOEDALL
+4 NEW IOEDBOP,IOEDEOP,IOEFLD,IOELALL,IOELBOL,IOELEOL,IOENTER,IOFIND
+5 NEW IOHDWN,IOHOME,IOHTS,IOHUP,IOICH,IOIL,IOIND,IOINHI,IOINLOW,IOINORM
+6 NEW IOINSERT,IOKP0,IOKP1,IOKP2,IOKP3,IOKP4,IOKP5,IOKP6,IOKP7,IOKP8,IOKP9
+7 NEW IOIRM0,IOIRM1,IOKPAM,IOKPNM,IOMC,IOMINUS,IONEL,IONEXTSC,IOPERIOD
+8 NEW IOPF1,IOPF2,IOPF3,IOPF4,IOPREVSC,IOPROB,IOPTCH10,IOPTCH12,IOPTCH16
+9 NEW IORC,IOREMOVE,IORESET,IORI,IORVOFF,IORVON,IOSC,IOSGR0,IOSELECT
+10 NEW IOSTBM,IOSWL,IOTBC,IOTBCALL,IOUOFF,IOUON,IOIS
+11 ;
+12 ;------------------------*******----------------------------------
+13 DO TERM^PXBCC
+14 DO FIX1^PXBCC
+15 DO HDR3^PXBUTL(DFN,1)
+16 DO REQ^PXBDREQ(8)
+17 DO EN0^PXBDVST
+18 DO LOC^PXBCC(15,0)
+19 DO WIN17^PXBCC(PXBCNT)
+20 DO VST^PXBPVST
+21 DO FULL0^PXBCC
+22 DO CLEAR1^PXBCC
+23 KILL ^TMP("PXBKY",$JOB),^TMP("PXBSAM",$JOB),^TMP("PXBSKY",$JOB),^TMP("PXBVSTG",$JOB),^TMP("PXBU",$JOB),^TMP("PXBDVST",$JOB)
+24 ;
+25 ;
+26 QUIT
+27 ;---END OF PROMPTING
