PXCEVFI4 ;ISL/dee,SLC/ajb - Routine to display a visit or v-file entry and input providers in to V PROVIDER from other V Files ;6/20/96
;;1.0;PCE PATIENT CARE ENCOUNTER;**124,203,199,201**;Aug 12, 1996;Build 41
Q
DISPLAY ; -- display the data
Q:PXCECAT="CSTP"
N PXCELINE,PXCETEXT,PXCEINT,PXCEEXT
I PXCECAT="APPM"!(PXCECAT="HIST") N PXCECODE S PXCECODE="PXCESIT"
W !
F PXCELINE=1:1 S PXCETEXT=$P($T(FORMAT+PXCELINE^@PXCECODE),";;",2) Q:PXCETEXT']"" D
. S (PXCEINT,PXCEEXT)=$P(PXCEAFTR($P(PXCETEXT,"~",1)),"^",$P(PXCETEXT,"~",2))
. I PXCEINT="@" S PXCEEXT="<deleted>"
. E I PXCEINT'="" D
.. I $P(PXCETEXT,"~",6)]"" S @("PXCEEXT="_$P(PXCETEXT,"~",6)_"("""_PXCEINT_""")")
.. E D
... N DIERR,PXCEDILF
... S PXCEEXT=$$EXTERNAL^DILFD(PXCEFILE,$P(PXCETEXT,"~",3),"",PXCEINT,"PXCEDILF")
... S PXCEEXT=$S('$D(DIERR):PXCEEXT,1:PXCEINT)
. I ($L($P(PXCETEXT,"~",5))+$L(PXCEEXT))'>80 D
.. W !,$P(PXCETEXT,"~",5),PXCEEXT
. E D
.. N PXCEWRAP,PXCECOUN
.. D WRAP(PXCEEXT,80-$L($P(PXCETEXT,"~",5)),.PXCEWRAP)
.. W !,$P(PXCETEXT,"~",5),$G(PXCEWRAP(1))
.. S PXCECOUN=1
.. F S PXCECOUN=$O(PXCEWRAP(PXCECOUN)) Q:PXCECOUN']"" D
... W !,$J("",$L($P(PXCETEXT,"~",5))),PXCEWRAP(PXCECOUN)
Q
;
WRAP(X,DIWR,WRAPPED) ;Copies the text in X into the array WRAPPED
N DIWL,DIWF,PXCEINDX
K ^UTILITY($J,"W")
S DIWL=1
S DIRF=""
D ^DIWP
S PXCEINDX=0
F S PXCEINDX=$O(^UTILITY($J,"W",DIWL,PXCEINDX)) Q:'PXCEINDX S WRAPPED(PXCEINDX)=^UTILITY($J,"W",DIWL,PXCEINDX,0)
K ^UTILITY($J,"W")
Q
;
PROVIDER(PXCEPRV) ;See if it is a new provider and if it is add them.
N PXCEVPRV,PXCEKPRV,PXCENPRV,PXCEPRIM
N DIR,DA,X,Y
S (PXCEVPRV,PXCEKPRV)=""
S PXCEPRIM=0
;See if this provider is already in V Provider for this Encounter
F S PXCEVPRV=$O(^AUPNVPRV("AD",PXCEVIEN,PXCEVPRV)) Q:PXCEVPRV'>0 Q:PXCEPRV=$P(^AUPNVPRV(PXCEVPRV,0),"^",1) S:"P"=$P(^AUPNVPRV(PXCEVPRV,0),"^",4) PXCEPRIM=1
Q:PXCEVPRV>0
;See if this provider is in the ^TMP("PXK",$J,
F S PXCEKPRV=$O(^TMP("PXK",$J,"PRV",PXCEKPRV)) Q:PXCEKPRV'>0 Q:PXCEPRV=+^TMP("PXK",$J,"PRV",PXCEKPRV,0,"AFTER") S:"P"=$P(^TMP("PXK",$J,"PRV",PXCEKPRV,0,"AFTER"),"^",4) PXCEPRIM=1
Q:PXCEKPRV>0
I 'PXCEPRIM D I $D(DTOUT)!$D(DUOUT) Q
. N DIR,DA
. S DIR(0)="9000010.06,.04A"
. S DIR("A")="Is this provider Primary or Secondary? "
. S DIR("B")=$S(PXCEPRIM:"S",1:"P")
. D ^DIR
I PXCEPRIM S Y="S"
;Set PXCENPRV to the next provider in ^TMP("PXK",$J,"PRV",
I $Q(^TMP("PXK",$J,"PRV"))["PXK,"_$J_",PRV" S PXCENPRV=+$O(^TMP("PXK",$J,"PRV",""),-1)+1
E S PXCENPRV=1
S ^TMP("PXK",$J,"PRV",PXCENPRV,"IEN")=""
S ^TMP("PXK",$J,"PRV",PXCENPRV,0,"BEFORE")=""
S ^TMP("PXK",$J,"PRV",PXCENPRV,0,"AFTER")=PXCEPRV_"^"_PXCEPAT_"^"_PXCEVIEN_"^"_$P(Y,"^")
S ^TMP("PXK",$J,"PRV",PXCENPRV,812,"BEFORE")=""
S ^TMP("PXK",$J,"PRV",PXCENPRV,812,"AFTER")="^"_PXCEPKG_"^"_PXCESOR
Q
;
DIAGNOS(PXCEPOV,OTHER) ;See if it is a new diagnosis and if it is add them. ; added OTHER ; ajb
N DA,DIR,PXCEDXSC,PXCEKPOV,PXCEMOD,PXCENARR,PXCENPOV,PXCEPMSC,PXCEVDT
N PXCEVPOV,PXCEX,PXCEY,X,Y
S (PXCEVPOV,PXCEKPOV)=""
S PXCEPRIM=$S(+$G(OTHER):0,1:1) S:+PXCEPRIM PXCEPMSC="P" ; set as primary diagnosis unless OTHER DIAGNOSIS is indicated
;See if this diagnosis is already in V POV for this Encounter
F S PXCEVPOV=$O(^AUPNVPOV("AD",PXCEVIEN,PXCEVPOV)) Q:PXCEVPOV'>0 Q:PXCEPOV=$P(^AUPNVPOV(PXCEVPOV,0),"^",1) S:"P"=$P(^AUPNVPOV(PXCEVPOV,0),"^",12) PXCEPRIM=1
Q:PXCEVPOV>0
;See if this diagnosis is in the ^TMP("PXK",$J,
F S PXCEKPOV=$O(^TMP("PXK",$J,"POV",PXCEKPOV)) Q:PXCEKPOV'>0 Q:PXCEPOV=+^TMP("PXK",$J,"POV",PXCEKPOV,0,"AFTER") S:"P"=$P(^TMP("PXK",$J,"POV",PXCEKPOV,0,"AFTER"),"^",12) PXCEPRIM=1
Q:PXCEKPOV>0
;Is this diagnosis primary P/S
I 'PXCEPRIM,'+$G(OTHER) D I $D(DTOUT)!$D(DUOUT) S PXCEEND=1,PXCEQUIT=1 Q ; check if OTHER
. N DIR,DA
. S DIR(0)="9000010.07,.12A"
. S DIR("A")="Diagnosis is Primary? "
. S DIR("B")="P"
. D ^DIR
. S PXCEPMSC=$P(Y,"^",1)
. S:PXCEPMSC="P" PXCEPRIM=1
S:'$D(PXCEPMSC) PXCEPMSC="S"
;Diagnosis narrative
D I $D(DTOUT)!$D(DUOUT) S PXCEEND=1,PXCEQUIT=1 Q
. N DIR,DA
. S DIR(0)="9000010.07,.04AO"
. S DIR("A")="Provider Narrative: "
. D ^DIR
S PXCEX=Y
I PXCEX="" D
. S PXCEVDT=$$CSDATE^PXDXUTL(PXCEVIEN) ; get visit date
. S PXCEX=$$DXNARR^PXUTL1(+PXCEPOV,PXCEVDT) ; get diagnosis description
W !,PXCEX
S PXCEY=$$PROVNARR^PXAPI(PXCEX,9000010.07) I +PXCEY'>0 W "??",$C(7) S PXCEEND=1,PXCEQUIT=1 Q
S PXCENARR=$P(PXCEY,"^",1)
;Diagnosis modifier
D I $D(DTOUT)!$D(DUOUT) S PXCEEND=1,PXCEQUIT=1 Q
. N DIR,DA
. S DIR(0)="9000010.07,.06A"
. S DIR("A")="Diagnosis Modifier: "
. D ^DIR
S PXCEMOD=$P(Y,U,2)
;Diagnosis Service Connected, Clinical Indicators
D GET800^PXCED800
;Set PXCENPOV to the next diagnosis in ^TMP("PXK",$J,"POV",
I $Q(^TMP("PXK",$J,"POV"))["PXK,"_$J_",POV" S PXCENPOV=+$O(^TMP("PXK",$J,"POV",""),-1)+1
E S PXCENPOV=1
S ^TMP("PXK",$J,"POV",PXCENPOV,"IEN")=""
S ^TMP("PXK",$J,"POV",PXCENPOV,0,"BEFORE")=""
S ^TMP("PXK",$J,"POV",PXCENPOV,0,"AFTER")=PXCEPOV_"^"_PXCEPAT_"^"_PXCEVIEN_"^"_PXCENARR_"^^"_PXCEMOD_"^^^^^^"_PXCEPMSC
S ^TMP("PXK",$J,"POV",PXCENPOV,800,"BEFORE")=""
S ^TMP("PXK",$J,"POV",PXCENPOV,800,"AFTER")=PXCEDXSC
S ^TMP("PXK",$J,"POV",PXCENPOV,812,"BEFORE")=""
S ^TMP("PXK",$J,"POV",PXCENPOV,812,"AFTER")="^"_PXCEPKG_"^"_PXCESOR
Q
;
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXCEVFI4 5396 printed Nov 22, 2024@17:38:22 Page 2
PXCEVFI4 ;ISL/dee,SLC/ajb - Routine to display a visit or v-file entry and input providers in to V PROVIDER from other V Files ;6/20/96
+1 ;;1.0;PCE PATIENT CARE ENCOUNTER;**124,203,199,201**;Aug 12, 1996;Build 41
+2 QUIT
DISPLAY ; -- display the data
+1 if PXCECAT="CSTP"
QUIT
+2 NEW PXCELINE,PXCETEXT,PXCEINT,PXCEEXT
+3 IF PXCECAT="APPM"!(PXCECAT="HIST")
NEW PXCECODE
SET PXCECODE="PXCESIT"
+4 WRITE !
+5 FOR PXCELINE=1:1
SET PXCETEXT=$PIECE($TEXT(FORMAT+PXCELINE^@PXCECODE),";;",2)
if PXCETEXT']""
QUIT
Begin DoDot:1
+6 SET (PXCEINT,PXCEEXT)=$PIECE(PXCEAFTR($PIECE(PXCETEXT,"~",1)),"^",$PIECE(PXCETEXT,"~",2))
+7 IF PXCEINT="@"
SET PXCEEXT="<deleted>"
+8 IF '$TEST
IF PXCEINT'=""
Begin DoDot:2
+9 IF $PIECE(PXCETEXT,"~",6)]""
SET @("PXCEEXT="_$PIECE(PXCETEXT,"~",6)_"("""_PXCEINT_""")")
+10 IF '$TEST
Begin DoDot:3
+11 NEW DIERR,PXCEDILF
+12 SET PXCEEXT=$$EXTERNAL^DILFD(PXCEFILE,$PIECE(PXCETEXT,"~",3),"",PXCEINT,"PXCEDILF")
+13 SET PXCEEXT=$SELECT('$DATA(DIERR):PXCEEXT,1:PXCEINT)
End DoDot:3
End DoDot:2
+14 IF ($LENGTH($PIECE(PXCETEXT,"~",5))+$LENGTH(PXCEEXT))'>80
Begin DoDot:2
+15 WRITE !,$PIECE(PXCETEXT,"~",5),PXCEEXT
End DoDot:2
+16 IF '$TEST
Begin DoDot:2
+17 NEW PXCEWRAP,PXCECOUN
+18 DO WRAP(PXCEEXT,80-$LENGTH($PIECE(PXCETEXT,"~",5)),.PXCEWRAP)
+19 WRITE !,$PIECE(PXCETEXT,"~",5),$GET(PXCEWRAP(1))
+20 SET PXCECOUN=1
+21 FOR
SET PXCECOUN=$ORDER(PXCEWRAP(PXCECOUN))
if PXCECOUN']""
QUIT
Begin DoDot:3
+22 WRITE !,$JUSTIFY("",$LENGTH($PIECE(PXCETEXT,"~",5))),PXCEWRAP(PXCECOUN)
End DoDot:3
End DoDot:2
End DoDot:1
+23 QUIT
+24 ;
WRAP(X,DIWR,WRAPPED) ;Copies the text in X into the array WRAPPED
+1 NEW DIWL,DIWF,PXCEINDX
+2 KILL ^UTILITY($JOB,"W")
+3 SET DIWL=1
+4 SET DIRF=""
+5 DO ^DIWP
+6 SET PXCEINDX=0
+7 FOR
SET PXCEINDX=$ORDER(^UTILITY($JOB,"W",DIWL,PXCEINDX))
if 'PXCEINDX
QUIT
SET WRAPPED(PXCEINDX)=^UTILITY($JOB,"W",DIWL,PXCEINDX,0)
+8 KILL ^UTILITY($JOB,"W")
+9 QUIT
+10 ;
PROVIDER(PXCEPRV) ;See if it is a new provider and if it is add them.
+1 NEW PXCEVPRV,PXCEKPRV,PXCENPRV,PXCEPRIM
+2 NEW DIR,DA,X,Y
+3 SET (PXCEVPRV,PXCEKPRV)=""
+4 SET PXCEPRIM=0
+5 ;See if this provider is already in V Provider for this Encounter
+6 FOR
SET PXCEVPRV=$ORDER(^AUPNVPRV("AD",PXCEVIEN,PXCEVPRV))
if PXCEVPRV'>0
QUIT
if PXCEPRV=$PIECE(^AUPNVPRV(PXCEVPRV,0),"^",1)
QUIT
if "P"=$PIECE(^AUPNVPRV(PXCEVPRV,0),"^",4)
SET PXCEPRIM=1
+7 if PXCEVPRV>0
QUIT
+8 ;See if this provider is in the ^TMP("PXK",$J,
+9 FOR
SET PXCEKPRV=$ORDER(^TMP("PXK",$JOB,"PRV",PXCEKPRV))
if PXCEKPRV'>0
QUIT
if PXCEPRV=+^TMP("PXK",$JOB,"PRV",PXCEKPRV,0,"AFTER")
QUIT
if "P"=$PIECE(^TMP("PXK",$JOB,"PRV",PXCEKPRV,0,"AFTER"),"^",4)
SET PXCEPRIM=1
+10 if PXCEKPRV>0
QUIT
+11 IF 'PXCEPRIM
Begin DoDot:1
+12 NEW DIR,DA
+13 SET DIR(0)="9000010.06,.04A"
+14 SET DIR("A")="Is this provider Primary or Secondary? "
+15 SET DIR("B")=$SELECT(PXCEPRIM:"S",1:"P")
+16 DO ^DIR
End DoDot:1
IF $DATA(DTOUT)!$DATA(DUOUT)
QUIT
+17 IF PXCEPRIM
SET Y="S"
+18 ;Set PXCENPRV to the next provider in ^TMP("PXK",$J,"PRV",
+19 IF $QUERY(^TMP("PXK",$JOB,"PRV"))["PXK,"_$JOB_",PRV"
SET PXCENPRV=+$ORDER(^TMP("PXK",$JOB,"PRV",""),-1)+1
+20 IF '$TEST
SET PXCENPRV=1
+21 SET ^TMP("PXK",$JOB,"PRV",PXCENPRV,"IEN")=""
+22 SET ^TMP("PXK",$JOB,"PRV",PXCENPRV,0,"BEFORE")=""
+23 SET ^TMP("PXK",$JOB,"PRV",PXCENPRV,0,"AFTER")=PXCEPRV_"^"_PXCEPAT_"^"_PXCEVIEN_"^"_$PIECE(Y,"^")
+24 SET ^TMP("PXK",$JOB,"PRV",PXCENPRV,812,"BEFORE")=""
+25 SET ^TMP("PXK",$JOB,"PRV",PXCENPRV,812,"AFTER")="^"_PXCEPKG_"^"_PXCESOR
+26 QUIT
+27 ;
DIAGNOS(PXCEPOV,OTHER) ;See if it is a new diagnosis and if it is add them. ; added OTHER ; ajb
+1 NEW DA,DIR,PXCEDXSC,PXCEKPOV,PXCEMOD,PXCENARR,PXCENPOV,PXCEPMSC,PXCEVDT
+2 NEW PXCEVPOV,PXCEX,PXCEY,X,Y
+3 SET (PXCEVPOV,PXCEKPOV)=""
+4 ; set as primary diagnosis unless OTHER DIAGNOSIS is indicated
SET PXCEPRIM=$SELECT(+$GET(OTHER):0,1:1)
if +PXCEPRIM
SET PXCEPMSC="P"
+5 ;See if this diagnosis is already in V POV for this Encounter
+6 FOR
SET PXCEVPOV=$ORDER(^AUPNVPOV("AD",PXCEVIEN,PXCEVPOV))
if PXCEVPOV'>0
QUIT
if PXCEPOV=$PIECE(^AUPNVPOV(PXCEVPOV,0),"^",1)
QUIT
if "P"=$PIECE(^AUPNVPOV(PXCEVPOV,0),"^",12)
SET PXCEPRIM=1
+7 if PXCEVPOV>0
QUIT
+8 ;See if this diagnosis is in the ^TMP("PXK",$J,
+9 FOR
SET PXCEKPOV=$ORDER(^TMP("PXK",$JOB,"POV",PXCEKPOV))
if PXCEKPOV'>0
QUIT
if PXCEPOV=+^TMP("PXK",$JOB,"POV",PXCEKPOV,0,"AFTER")
QUIT
if "P"=$PIECE(^TMP("PXK",$JOB,"POV",PXCEKPOV,0,"AFTER"),"^",12)
SET PXCEPRIM=1
+10 if PXCEKPOV>0
QUIT
+11 ;Is this diagnosis primary P/S
+12 ; check if OTHER
IF 'PXCEPRIM
IF '+$GET(OTHER)
Begin DoDot:1
+13 NEW DIR,DA
+14 SET DIR(0)="9000010.07,.12A"
+15 SET DIR("A")="Diagnosis is Primary? "
+16 SET DIR("B")="P"
+17 DO ^DIR
+18 SET PXCEPMSC=$PIECE(Y,"^",1)
+19 if PXCEPMSC="P"
SET PXCEPRIM=1
End DoDot:1
IF $DATA(DTOUT)!$DATA(DUOUT)
SET PXCEEND=1
SET PXCEQUIT=1
QUIT
+20 if '$DATA(PXCEPMSC)
SET PXCEPMSC="S"
+21 ;Diagnosis narrative
+22 Begin DoDot:1
+23 NEW DIR,DA
+24 SET DIR(0)="9000010.07,.04AO"
+25 SET DIR("A")="Provider Narrative: "
+26 DO ^DIR
End DoDot:1
IF $DATA(DTOUT)!$DATA(DUOUT)
SET PXCEEND=1
SET PXCEQUIT=1
QUIT
+27 SET PXCEX=Y
+28 IF PXCEX=""
Begin DoDot:1
+29 ; get visit date
SET PXCEVDT=$$CSDATE^PXDXUTL(PXCEVIEN)
+30 ; get diagnosis description
SET PXCEX=$$DXNARR^PXUTL1(+PXCEPOV,PXCEVDT)
End DoDot:1
+31 WRITE !,PXCEX
+32 SET PXCEY=$$PROVNARR^PXAPI(PXCEX,9000010.07)
IF +PXCEY'>0
WRITE "??",$CHAR(7)
SET PXCEEND=1
SET PXCEQUIT=1
QUIT
+33 SET PXCENARR=$PIECE(PXCEY,"^",1)
+34 ;Diagnosis modifier
+35 Begin DoDot:1
+36 NEW DIR,DA
+37 SET DIR(0)="9000010.07,.06A"
+38 SET DIR("A")="Diagnosis Modifier: "
+39 DO ^DIR
End DoDot:1
IF $DATA(DTOUT)!$DATA(DUOUT)
SET PXCEEND=1
SET PXCEQUIT=1
QUIT
+40 SET PXCEMOD=$PIECE(Y,U,2)
+41 ;Diagnosis Service Connected, Clinical Indicators
+42 DO GET800^PXCED800
+43 ;Set PXCENPOV to the next diagnosis in ^TMP("PXK",$J,"POV",
+44 IF $QUERY(^TMP("PXK",$JOB,"POV"))["PXK,"_$JOB_",POV"
SET PXCENPOV=+$ORDER(^TMP("PXK",$JOB,"POV",""),-1)+1
+45 IF '$TEST
SET PXCENPOV=1
+46 SET ^TMP("PXK",$JOB,"POV",PXCENPOV,"IEN")=""
+47 SET ^TMP("PXK",$JOB,"POV",PXCENPOV,0,"BEFORE")=""
+48 SET ^TMP("PXK",$JOB,"POV",PXCENPOV,0,"AFTER")=PXCEPOV_"^"_PXCEPAT_"^"_PXCEVIEN_"^"_PXCENARR_"^^"_PXCEMOD_"^^^^^^"_PXCEPMSC
+49 SET ^TMP("PXK",$JOB,"POV",PXCENPOV,800,"BEFORE")=""
+50 SET ^TMP("PXK",$JOB,"POV",PXCENPOV,800,"AFTER")=PXCEDXSC
+51 SET ^TMP("PXK",$JOB,"POV",PXCENPOV,812,"BEFORE")=""
+52 SET ^TMP("PXK",$JOB,"POV",PXCENPOV,812,"AFTER")="^"_PXCEPKG_"^"_PXCESOR
+53 QUIT
+54 ;
+55 ;
