- 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 ;