- 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 Jan 18, 2025@03:29: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 ;