PXCEVFI4 ;ISL/dee - 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;;Aug 12, 1996
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
;
PXCEVFI4 ;ISL/dee - 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;;Aug 12, 1996
+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 ;
