PXQPPUTIL ;SLS/PKR - Utility for primary provider repair. ;08/14/2020
;;1.0;PCE PATIENT CARE ENCOUNTER;**211**;Aug 12, 1996;Build 454
;
;ICR #3125 covers references to ^RADPT, file #70.
;ICR #5605 covers references to ^RARPT, file #74.
;===============
ASKCONTINUE() ;Ask the user if they want to continue.
N DIR,DIRUT,X,Y
S DIR(0)="SABX^0:NO;1:YES"
S DIR("A")="Continue checking encounters? "
S DIR("B")="YES"
D ^DIR
I $D(DIRUT) Q 0
Q Y
;
;===============
DISCLAIMER ;Display the disclaimer.
W !,"=============== NOTE ==============="
W !,"This utility searches for Lab and Radiology Encounters in the specified"
W !,"date range. Those that do not have a primary provider will be processed."
W !,"===================================="
W !
Q
;
;===============
DISPIMPTEXT(VISITIEN) ;
N CASENUM,CPT,CPTLIST,DFN,IENS,IENT,IMPTEXT,IND,INVDT,JND,MSG,NL
N RADCPT,REPORT,RESULT,TEXT,VCPTIEN,X
;Find the Radiology Examination(s) for this Visit.
I '$D(^RADPT("AVSIT",VISITIEN)) D Q
. S ^TMP("PXQPPR",$J,"RAD","NO EXAM",VISITIEN)=""
. W !,"No Radiology exam can be found for Visit IEN ",VISITIEN,"."
. W !,"Therefore, no Impresion Text can be displayed."
. H 2
;Build the list of CPT codes for this encounter.
S VCPTIEN=""
F S VCPTIEN=$O(^AUPNVCPT("AD",VISITIEN,VCPTIEN)) Q:VCPTIEN="" D
. S CPT=$P(^AUPNVCPT(VCPTIEN,0),U,1)
. S CPTLIST(CPT)=""
S DFN=$P(^AUPNVSIT(VISITIEN,0),U,5)
S INVDT=$O(^RADPT("AVSIT",VISITIEN,DFN,""))
S IENT=INVDT_","_DFN_","
S IND=""
F S IND=$O(^RADPT("AVSIT",VISITIEN,DFN,INVDT,IND)) Q:IND="" D
. S IENS=IND_","_IENT
. S RADCPT(IND)=$$GET1^DIQ(70.03,IENS,"2:9","","","MSG")
. I '$D(CPTLIST(RADCPT(IND))) Q
. S REPORT(IND)=$$GET1^DIQ(70.03,IENS,17,"I","","MSG")
I '$D(REPORT) D Q
. W !,"No Radiology Reports were found for this encounter, cannot display the Impression Text."
. H 2
S IND="",NL=0
F S IND=$O(REPORT(IND)) Q:IND="" D
. K IMPTEXT
. S IENS=REPORT(IND)_","
. S NL=NL+1,TEXT(NL)=" "
. S CASENUM=$$GET1^DIQ(74,IENS,4,"","","MSG")
. S NL=NL+1,TEXT(NL)="Case Number - "_CASENUM
. S NL=NL+1,TEXT(NL)="CPT Code - "_RADCPT(IND)
. S NL=NL+1,TEXT(NL)="Impression Text:"
. S RESULT=$$GET1^DIQ(74,IENS,300,"","IMPTEXT","MSG")
. I RESULT'="" D
.. S JND=0
.. F S JND=$O(IMPTEXT(JND)) Q:JND="" S NL=NL+1,TEXT(NL)=IMPTEXT(JND)
S X="IORESET"
D ENDR^%ZISS
D BROWSE^DDBR("TEXT","NR","Radiology Report Impression Text")
W IORESET
D KILL^%ZISS
Q
;
;===============
FINDEXAM(VISITIEN) ;Try to link the Visit to the Radiology Exam.
N CPT,CPTLIST,DFN,FDA,HLOC,IENS,IENT,IMLOC,IND,INVDT,MSG,RADCPT
N VCPTIEN,VISITDT,TEMP
S TEMP=^AUPNVSIT(VISITIEN,0)
S VISITDT=$P(TEMP,U,1)
S DFN=$P(TEMP,U,5)
;ICR #65
I '$D(^RADPT("AR",VISITDT,DFN)) Q
S HLOC=$P(TEMP,U,22)
S INVDT=9999999.9999-VISITDT
S IENT=INVDT_","_DFN_","
S IMLOC=$$GET1^DIQ(70.02,IENT,"4:.01","I","","MSG")
I IMLOC'=HLOC Q
;Build the list of CPT codes for this encounter.
S VCPTIEN=""
F S VCPTIEN=$O(^AUPNVCPT("AD",VISITIEN,VCPTIEN)) Q:VCPTIEN="" D
. S CPT=$P(^AUPNVCPT(VCPTIEN,0),U,1)
. S CPTLIST(CPT)=""
;Look for a match on the CPT code.
S IND=0
F S IND=+$O(^RADPT(DFN,"DT",INVDT,"P",IND)) Q:IND=0 D
. S IENS=IND_","_IENT
. S RADCPT=$$GET1^DIQ(70.03,IENS,"2:9","I","","MSG")
. I RADCPT="" Q
. I '$D(CPTLIST(RADCPT)) Q
. K FDA
.;ICR #7186
. S FDA(70.03,IENS,27)=VISITIEN
. D FILE^DIE("K","FDA","MSG")
. I '$D(MSG) S ^TMP("PXQPPR",$J,"RAD","VISIT",VISITIEN)=IENS
Q
;
;===============
GETDATE(DEFAULT,PROMPT,MINDATE) ;Ask the user for a date.
N DIR,DIRUT,X,Y
S DIR(0)="D::DT:AE"
I $G(MINDATE)>0 S DIR(0)=DIR(0)_U_MINDATE
S DIR("A")=PROMPT
S DIR("B")=DEFAULT
D ^DIR
I $D(DIRUT) S Y="^"
Q Y
;
;===============
OPENENCOUNTER(VISITIEN) ;Open the encounter in List Manger so the primary
;provider can be edited.
N PXCEEXIT,PXCEKEYS,PXCEPKG,PXCESOR,PXCEVIEN,PXCEVIEW
N SPE,TEMP
S TEMP=$G(^AUPNVSIT(VISITIEN,812))
S PXCEPKG=$P(TEMP,U,2),PXCESOR=$P(TEMP,U,3)
S PXCEKEYS="SPCD"
S PXCEVIEN=VISITIEN
S PXCEVIEW="P^V^"
D EN^PXCEAE
Q
;
;===============
PPREPAIR ;Find and repair encounters that do not have a primary provider.
N CONTINUE,DATASOURCE,ENDDATE,LABDS,LABPKG,NPRIM,NPROV
N PACKAGE,PORS,PRIMARY,PROVIDER,PROVIDERLIST,RADPKG,RADDS,RADPROXY
N SC,STARTDATE,TEMP,VISITIEN,VISITDT,VPRVIEN
K ^TMP("PXQPPR",$J)
;ICR #10048
S LABPKG=$$FIND1^DIC(9.4,"","B","LAB SERVICE")
S LABDS=$$FIND1^DIC(839.7,"","B","LAB DATA")
S RADPKG=$$FIND1^DIC(9.4,"","B","RADIOLOGY/NUCLEAR MEDICINE")
S RADDS=$$FIND1^DIC(839.7,"","B","RAD/NUC MED")
S RADPROXY=$$FIND1^DIC(200,"","B","RADIOLOGY,OUTSIDE SERVICE")
S ^TMP("PXQPPR",$J,"REPSTART")=$$NOW^XLFDT
D DISCLAIMER
W !,"Set the date range for searching for encounters."
S STARTDATE=$$GETDATE("","Input the starting date")
I STARTDATE="^" Q
S ENDDATE=$$GETDATE("T","Input the ending date: ",STARTDATE)
I ENDDATE="^" Q
S ENDDATE=ENDDATE+0.235959
S ^TMP("PXQPPR",$J,"STARTDATE")=STARTDATE
S ^TMP("PXQPPR",$J,"ENDDATE")=ENDDATE
S VISITDT=STARTDATE
S CONTINUE=1
F S VISITDT=$O(^AUPNVSIT("B",VISITDT)) Q:(CONTINUE=0)!(VISITDT>ENDDATE)!(VISITDT="") D
. S VISITIEN=0
. F S VISITIEN=$O(^AUPNVSIT("B",VISITDT,VISITIEN)) Q:VISITIEN="" D
.. S SC=$P(^AUPNVSIT(VISITIEN,0),U,7)
..;Historical encounters do not need to be checked.
.. I SC="E" Q
.. S NPRIM=0
..;Get the list of providers for this encounter.
.. K PROVIDERLIST
.. S (NPROV,VPRVIEN)=0
.. F S VPRVIEN=+$O(^AUPNVPRV("AD",VISITIEN,VPRVIEN)) Q:VPRVIEN=0 D
... S NPROV=NPROV+1
... S TEMP=^AUPNVPRV(VPRVIEN,0)
... S PROVIDER=$P(TEMP,U,1)
... S PORS=$P(TEMP,U,4)
... S PROVIDERLIST(PROVIDER)=VPRVIEN_U_PORS
... I PORS="P" S NPRIM=NPRIM+1,PRIMARY=PROVIDER
.. S TEMP=$G(^AUPNVSIT(VISITIEN,812))
.. S PACKAGE=$P(TEMP,U,2)
.. S DATASOURCE=$P(TEMP,U,3)
.. I (PACKAGE=LABPKG)!(DATASOURCE=LABDS) D
... D LAB(VISITIEN,.NPRIM,.PRIMARY,.PROVIDERLIST,.CONTINUE)
.. I (PACKAGE=RADPKG)!(DATASOURCE=RADDS) D
... D RAD(VISITIEN,.NPRIM,.PRIMARY,.PROVIDERLIST,RADPROXY,.CONTINUE)
;Report what was done.
D REPORT^PXQPPUTILR
;ICR #10052
D KILL^XUSCLEAN
K ^TMP("PXQPPR",$J)
Q
;
;===============
LAB(VISITIEN,NPRIM,PRIMARY,PROVIDERLIST,CONTINUE) ;Handle Lab
;encounters that do not have a primary provider.
I NPRIM=1 Q
N ENCPROV,IENS,FDA,MSG,ORDPROV,NENCPROV,NORDPROV,RESULT,TEMP,VCPTIEN
S (NENCPROV,NORDPROV)=0
S VCPTIEN=""
F S VCPTIEN=$O(^AUPNVCPT("AD",VISITIEN,VCPTIEN)) Q:VCPTIEN="" D
. S TEMP=$G(^AUPNVCPT(VCPTIEN,12))
. I TEMP="" Q
. S ORDPROV=$P(TEMP,U,2)
. S ENCPROV=$P(TEMP,U,4)
. I (ORDPROV'=""),('$D(ORDPROVLIST(ORDPROV))) S ORDPROVLIST(ORDPROV)="",NORDPROV=NORDPROV+1
. I (ENCPROV'=""),('$D(ENCPROVLIST(ENCPROV))) S ENCPROVLIST(ENCPROV)="",NENCPROV=NENCPROV+1
;If there is only one ordering provider make sure they are primary.
I NORDPROV=1 D
. S ORDPROV=$O(ORDPROVLIST(""))
. S IENS=$P(PROVIDERLIST(ORDPROV),U,1)_","
. S FDA(9000010.06,IENS,.04)="P"
. D FILE^DIE("K","FDA","MSG")
. S RESULT=$S($D(MSG):FAILED,1:"SUCCESS")
. S ^TMP("PXQPPR",$J,"LAB","SETP",VISITIEN,ORDPROV)=RESULT
;If the number of ordering providers is not one open the encounter for
;editing.
I NORDPROV'=1 D
. D OPENENCOUNTER(VISITIEN)
. S ^TMP("PXQPPR",$J,"LAB","OPEN",VISITIEN)=""
;Ask the user if they want to continue.
S CONTINUE=$$ASKCONTINUE
Q
;
;===============
RAD(VISITIEN,NPRIM,PRIMARY,PROVIDERLIST,RADPROXY,CONTINUE) ;Handle Radiology
;encounters that ;do not have a primary provider or the primary
;provider is the proxy.
;If there is no primary provider set one.
I NPRIM=0 D RADPRIM(VISITIEN,.PROVIDERLIST,.PRIMARY)
;If there is no Radiology exam linked to this Visit try to link it.
I '$D(^RADPT("AVSIT",VISITIEN)) D FINDEXAM(VISITIEN)
;If the Primary Provider is the proxy go to RADPROXYPP so the
;user can easily edit the Primary Provider.
I PRIMARY=RADPROXY D RADPROXYPP(VISITIEN,.CONTINUE)
Q
;
;===============
RADPRIM(VISITIEN,PROVIDERLIST,PRIMARY) ;Set a primary provider for
;Radiology encounters that do not have one.
N ENCDT,ENCPROV,IENS,FDA,MSG,ORDPROV,PERSONCLASS,RESULT,VCPTIEN
;Find the Encounter Provider and Ordering Provider in V CPT.
S VCPTIEN=$O(^AUPNVCPT("AD",VISITIEN,""))
I VCPTIEN="" Q
S ENCPROV=$P(^AUPNVCPT(VCPTIEN,12),U,4)
S ORDPROV=$P(^AUPNVCPT(VCPTIEN,12),U,2)
;If there is an existing V Provider entry for the encounter provider
;make it primary. If not, create a new V Provider entry.
I (ENCPROV'=""),$D(PROVIDERLIST(ENCPROV)) D
. I $P(PROVIDERLIST(ENCPROV),U,2)="P" Q
. S IENS=$P(PROVIDERLIST(ENCPROV),U,1)_","
. S FDA(9000010.06,IENS,.04)="P"
. D FILE^DIE("K","FDA","MSG")
. S RESULT=$S($D(MSG):FAILED,1:"SUCCESS")
. S ^TMP("PXQPPR",$J,"RAD","SETP",VISITIEN,ENCPROV)=RESULT
.;Make Ordering Provider secondary.
I (ORDPROV'=""),$D(PROVIDERLIST(ORDPROV)) D
. I $P(PROVIDERLIST(ORDPROV),U,2)="S" Q
. S IENS=$P(PROVIDERLIST(ORDPROV),U,1)_","
. K FDA,MSG
. S FDA(9000010.06,IENS,.04)="S"
. D FILE^DIE("K","FDA","MSG")
S ENCDT=$P($G(^AUPNVCPT(VCPTIEN,12)),U,1)
I ENCDT="" S ENCDT=$P(^AUPNVSIT(VISITIEN,0),U,1)
;No V Provider entry found.
I (ENCPROV'=""),'$D(PROVIDERLIST(ENCPROV)) D
. K FDA,MSG
.;Get the values for Patient, Visit, Event Date and Time, Comments,
.;Package, and Data Source from the V CPT entry.
. S FDA(9000010.06,"+1,",.01)=ENCPROV
. S FDA(9000010.06,"+1,",.02)=$P(^AUPNVCPT(VCPTIEN,0),U,2)
. S FDA(9000010.06,"+1,",.03)=$P(^AUPNVCPT(VCPTIEN,0),U,3)
. S FDA(9000010.06,"+1,",.04)="P"
. S PERSONCLASS=$P($$GET^XUA4A72(ENCPROV,ENCDT),U,1)
. I +PERSONCLASS>0 S FDA(9000010.06,"+1,",.06)=PERSONCLASS
. S FDA(9000010.06,"+1,",1201)=$P($G(^AUPNVCPT(VCPTIEN,12)),U,1)
. S FDA(9000010.06,"+1,",81101)=$G(^AUPNVCPT(VCPTIEN,811))
. S FDA(9000010.06,"+1,",81202)=$P($G(^AUPNVCPT(VCPTIEN,812)),U,2)
. S FDA(9000010.06,"+1,",81203)=$P($G(^AUPNVCPT(VCPTIEN,812)),U,3)
. D UPDATE^DIE("","FDA","","MSG")
I (ORDPROV'=""),'$D(PROVIDERLIST(ORDPROV)) D
. K FDA,MSG
. S FDA(9000010.06,"+1,",.01)=ORDPROV
. S FDA(9000010.06,"+1,",.02)=$P(^AUPNVCPT(VCPTIEN,0),U,2)
. S FDA(9000010.06,"+1,",.03)=$P(^AUPNVCPT(VCPTIEN,0),U,3)
. S FDA(9000010.06,"+1,",.04)="S"
. S PERSONCLASS=$P($$GET^XUA4A72(ORDPROV,ENCDT),U,1)
. I +PERSONCLASS>0 S FDA(9000010.06,"+1,",.06)=PERSONCLASS
. S FDA(9000010.06,"+1,",1201)=$P($G(^AUPNVCPT(VCPTIEN,12)),U,1)
. S FDA(9000010.06,"+1,",81101)=$G(^AUPNVCPT(VCPTIEN,811))
. S FDA(9000010.06,"+1,",81202)=$P($G(^AUPNVCPT(VCPTIEN,812)),U,2)
. S FDA(9000010.06,"+1,",81203)=$P($G(^AUPNVCPT(VCPTIEN,812)),U,3)
. D UPDATE^DIE("","FDA","","MSG")
S PRIMARY=ENCPROV
Q
;
;===============
RADPROXYPP(VISITIEN,CONTINUE) ;Radiology encounter has the proxy as the primary
;provider.
;Display the Impression Text, it should contain the name and NPI
;of the teleradiology provider.
D DISPIMPTEXT(VISITIEN)
;Open the Encounter for editing.
D OPENENCOUNTER(VISITIEN)
S ^TMP("PXQPPR",$J,"RAD","PROXY",VISITIEN)=""
;Ask the user if they want to continue.
S CONTINUE=$$ASKCONTINUE
Q
;
;===============
SETONEPRIME(PROVIDERLIST) ;There is only one provider for the encounter
;and it is not marked primary provider, make it primary.
N FDA,IENS,MSG,PROVIDER,RESULT
S PROVIDER=$O(PROVIDERLIST(""))
S IENS=$P(PROVIDERLIST(PROVIDER),U,1)_","
S FDA(9000010.06,IENS,.04)="P"
D FILE^DIE("K","FDA","MSG")
S RESULT=$S($D(MSG):"FAILED",1:"SUCCESS")
S ^TMP("PXQPPR",$J,"SET1P",IENS,PROVIDER)=RESULT
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXQPPUTIL 11636 printed Sep 23, 2025@20:06:11 Page 2
PXQPPUTIL ;SLS/PKR - Utility for primary provider repair. ;08/14/2020
+1 ;;1.0;PCE PATIENT CARE ENCOUNTER;**211**;Aug 12, 1996;Build 454
+2 ;
+3 ;ICR #3125 covers references to ^RADPT, file #70.
+4 ;ICR #5605 covers references to ^RARPT, file #74.
+5 ;===============
ASKCONTINUE() ;Ask the user if they want to continue.
+1 NEW DIR,DIRUT,X,Y
+2 SET DIR(0)="SABX^0:NO;1:YES"
+3 SET DIR("A")="Continue checking encounters? "
+4 SET DIR("B")="YES"
+5 DO ^DIR
+6 IF $DATA(DIRUT)
QUIT 0
+7 QUIT Y
+8 ;
+9 ;===============
DISCLAIMER ;Display the disclaimer.
+1 WRITE !,"=============== NOTE ==============="
+2 WRITE !,"This utility searches for Lab and Radiology Encounters in the specified"
+3 WRITE !,"date range. Those that do not have a primary provider will be processed."
+4 WRITE !,"===================================="
+5 WRITE !
+6 QUIT
+7 ;
+8 ;===============
DISPIMPTEXT(VISITIEN) ;
+1 NEW CASENUM,CPT,CPTLIST,DFN,IENS,IENT,IMPTEXT,IND,INVDT,JND,MSG,NL
+2 NEW RADCPT,REPORT,RESULT,TEXT,VCPTIEN,X
+3 ;Find the Radiology Examination(s) for this Visit.
+4 IF '$DATA(^RADPT("AVSIT",VISITIEN))
Begin DoDot:1
+5 SET ^TMP("PXQPPR",$JOB,"RAD","NO EXAM",VISITIEN)=""
+6 WRITE !,"No Radiology exam can be found for Visit IEN ",VISITIEN,"."
+7 WRITE !,"Therefore, no Impresion Text can be displayed."
+8 HANG 2
End DoDot:1
QUIT
+9 ;Build the list of CPT codes for this encounter.
+10 SET VCPTIEN=""
+11 FOR
SET VCPTIEN=$ORDER(^AUPNVCPT("AD",VISITIEN,VCPTIEN))
if VCPTIEN=""
QUIT
Begin DoDot:1
+12 SET CPT=$PIECE(^AUPNVCPT(VCPTIEN,0),U,1)
+13 SET CPTLIST(CPT)=""
End DoDot:1
+14 SET DFN=$PIECE(^AUPNVSIT(VISITIEN,0),U,5)
+15 SET INVDT=$ORDER(^RADPT("AVSIT",VISITIEN,DFN,""))
+16 SET IENT=INVDT_","_DFN_","
+17 SET IND=""
+18 FOR
SET IND=$ORDER(^RADPT("AVSIT",VISITIEN,DFN,INVDT,IND))
if IND=""
QUIT
Begin DoDot:1
+19 SET IENS=IND_","_IENT
+20 SET RADCPT(IND)=$$GET1^DIQ(70.03,IENS,"2:9","","","MSG")
+21 IF '$DATA(CPTLIST(RADCPT(IND)))
QUIT
+22 SET REPORT(IND)=$$GET1^DIQ(70.03,IENS,17,"I","","MSG")
End DoDot:1
+23 IF '$DATA(REPORT)
Begin DoDot:1
+24 WRITE !,"No Radiology Reports were found for this encounter, cannot display the Impression Text."
+25 HANG 2
End DoDot:1
QUIT
+26 SET IND=""
SET NL=0
+27 FOR
SET IND=$ORDER(REPORT(IND))
if IND=""
QUIT
Begin DoDot:1
+28 KILL IMPTEXT
+29 SET IENS=REPORT(IND)_","
+30 SET NL=NL+1
SET TEXT(NL)=" "
+31 SET CASENUM=$$GET1^DIQ(74,IENS,4,"","","MSG")
+32 SET NL=NL+1
SET TEXT(NL)="Case Number - "_CASENUM
+33 SET NL=NL+1
SET TEXT(NL)="CPT Code - "_RADCPT(IND)
+34 SET NL=NL+1
SET TEXT(NL)="Impression Text:"
+35 SET RESULT=$$GET1^DIQ(74,IENS,300,"","IMPTEXT","MSG")
+36 IF RESULT'=""
Begin DoDot:2
+37 SET JND=0
+38 FOR
SET JND=$ORDER(IMPTEXT(JND))
if JND=""
QUIT
SET NL=NL+1
SET TEXT(NL)=IMPTEXT(JND)
End DoDot:2
End DoDot:1
+39 SET X="IORESET"
+40 DO ENDR^%ZISS
+41 DO BROWSE^DDBR("TEXT","NR","Radiology Report Impression Text")
+42 WRITE IORESET
+43 DO KILL^%ZISS
+44 QUIT
+45 ;
+46 ;===============
FINDEXAM(VISITIEN) ;Try to link the Visit to the Radiology Exam.
+1 NEW CPT,CPTLIST,DFN,FDA,HLOC,IENS,IENT,IMLOC,IND,INVDT,MSG,RADCPT
+2 NEW VCPTIEN,VISITDT,TEMP
+3 SET TEMP=^AUPNVSIT(VISITIEN,0)
+4 SET VISITDT=$PIECE(TEMP,U,1)
+5 SET DFN=$PIECE(TEMP,U,5)
+6 ;ICR #65
+7 IF '$DATA(^RADPT("AR",VISITDT,DFN))
QUIT
+8 SET HLOC=$PIECE(TEMP,U,22)
+9 SET INVDT=9999999.9999-VISITDT
+10 SET IENT=INVDT_","_DFN_","
+11 SET IMLOC=$$GET1^DIQ(70.02,IENT,"4:.01","I","","MSG")
+12 IF IMLOC'=HLOC
QUIT
+13 ;Build the list of CPT codes for this encounter.
+14 SET VCPTIEN=""
+15 FOR
SET VCPTIEN=$ORDER(^AUPNVCPT("AD",VISITIEN,VCPTIEN))
if VCPTIEN=""
QUIT
Begin DoDot:1
+16 SET CPT=$PIECE(^AUPNVCPT(VCPTIEN,0),U,1)
+17 SET CPTLIST(CPT)=""
End DoDot:1
+18 ;Look for a match on the CPT code.
+19 SET IND=0
+20 FOR
SET IND=+$ORDER(^RADPT(DFN,"DT",INVDT,"P",IND))
if IND=0
QUIT
Begin DoDot:1
+21 SET IENS=IND_","_IENT
+22 SET RADCPT=$$GET1^DIQ(70.03,IENS,"2:9","I","","MSG")
+23 IF RADCPT=""
QUIT
+24 IF '$DATA(CPTLIST(RADCPT))
QUIT
+25 KILL FDA
+26 ;ICR #7186
+27 SET FDA(70.03,IENS,27)=VISITIEN
+28 DO FILE^DIE("K","FDA","MSG")
+29 IF '$DATA(MSG)
SET ^TMP("PXQPPR",$JOB,"RAD","VISIT",VISITIEN)=IENS
End DoDot:1
+30 QUIT
+31 ;
+32 ;===============
GETDATE(DEFAULT,PROMPT,MINDATE) ;Ask the user for a date.
+1 NEW DIR,DIRUT,X,Y
+2 SET DIR(0)="D::DT:AE"
+3 IF $GET(MINDATE)>0
SET DIR(0)=DIR(0)_U_MINDATE
+4 SET DIR("A")=PROMPT
+5 SET DIR("B")=DEFAULT
+6 DO ^DIR
+7 IF $DATA(DIRUT)
SET Y="^"
+8 QUIT Y
+9 ;
+10 ;===============
OPENENCOUNTER(VISITIEN) ;Open the encounter in List Manger so the primary
+1 ;provider can be edited.
+2 NEW PXCEEXIT,PXCEKEYS,PXCEPKG,PXCESOR,PXCEVIEN,PXCEVIEW
+3 NEW SPE,TEMP
+4 SET TEMP=$GET(^AUPNVSIT(VISITIEN,812))
+5 SET PXCEPKG=$PIECE(TEMP,U,2)
SET PXCESOR=$PIECE(TEMP,U,3)
+6 SET PXCEKEYS="SPCD"
+7 SET PXCEVIEN=VISITIEN
+8 SET PXCEVIEW="P^V^"
+9 DO EN^PXCEAE
+10 QUIT
+11 ;
+12 ;===============
PPREPAIR ;Find and repair encounters that do not have a primary provider.
+1 NEW CONTINUE,DATASOURCE,ENDDATE,LABDS,LABPKG,NPRIM,NPROV
+2 NEW PACKAGE,PORS,PRIMARY,PROVIDER,PROVIDERLIST,RADPKG,RADDS,RADPROXY
+3 NEW SC,STARTDATE,TEMP,VISITIEN,VISITDT,VPRVIEN
+4 KILL ^TMP("PXQPPR",$JOB)
+5 ;ICR #10048
+6 SET LABPKG=$$FIND1^DIC(9.4,"","B","LAB SERVICE")
+7 SET LABDS=$$FIND1^DIC(839.7,"","B","LAB DATA")
+8 SET RADPKG=$$FIND1^DIC(9.4,"","B","RADIOLOGY/NUCLEAR MEDICINE")
+9 SET RADDS=$$FIND1^DIC(839.7,"","B","RAD/NUC MED")
+10 SET RADPROXY=$$FIND1^DIC(200,"","B","RADIOLOGY,OUTSIDE SERVICE")
+11 SET ^TMP("PXQPPR",$JOB,"REPSTART")=$$NOW^XLFDT
+12 DO DISCLAIMER
+13 WRITE !,"Set the date range for searching for encounters."
+14 SET STARTDATE=$$GETDATE("","Input the starting date")
+15 IF STARTDATE="^"
QUIT
+16 SET ENDDATE=$$GETDATE("T","Input the ending date: ",STARTDATE)
+17 IF ENDDATE="^"
QUIT
+18 SET ENDDATE=ENDDATE+0.235959
+19 SET ^TMP("PXQPPR",$JOB,"STARTDATE")=STARTDATE
+20 SET ^TMP("PXQPPR",$JOB,"ENDDATE")=ENDDATE
+21 SET VISITDT=STARTDATE
+22 SET CONTINUE=1
+23 FOR
SET VISITDT=$ORDER(^AUPNVSIT("B",VISITDT))
if (CONTINUE=0)!(VISITDT>ENDDATE)!(VISITDT="")
QUIT
Begin DoDot:1
+24 SET VISITIEN=0
+25 FOR
SET VISITIEN=$ORDER(^AUPNVSIT("B",VISITDT,VISITIEN))
if VISITIEN=""
QUIT
Begin DoDot:2
+26 SET SC=$PIECE(^AUPNVSIT(VISITIEN,0),U,7)
+27 ;Historical encounters do not need to be checked.
+28 IF SC="E"
QUIT
+29 SET NPRIM=0
+30 ;Get the list of providers for this encounter.
+31 KILL PROVIDERLIST
+32 SET (NPROV,VPRVIEN)=0
+33 FOR
SET VPRVIEN=+$ORDER(^AUPNVPRV("AD",VISITIEN,VPRVIEN))
if VPRVIEN=0
QUIT
Begin DoDot:3
+34 SET NPROV=NPROV+1
+35 SET TEMP=^AUPNVPRV(VPRVIEN,0)
+36 SET PROVIDER=$PIECE(TEMP,U,1)
+37 SET PORS=$PIECE(TEMP,U,4)
+38 SET PROVIDERLIST(PROVIDER)=VPRVIEN_U_PORS
+39 IF PORS="P"
SET NPRIM=NPRIM+1
SET PRIMARY=PROVIDER
End DoDot:3
+40 SET TEMP=$GET(^AUPNVSIT(VISITIEN,812))
+41 SET PACKAGE=$PIECE(TEMP,U,2)
+42 SET DATASOURCE=$PIECE(TEMP,U,3)
+43 IF (PACKAGE=LABPKG)!(DATASOURCE=LABDS)
Begin DoDot:3
+44 DO LAB(VISITIEN,.NPRIM,.PRIMARY,.PROVIDERLIST,.CONTINUE)
End DoDot:3
+45 IF (PACKAGE=RADPKG)!(DATASOURCE=RADDS)
Begin DoDot:3
+46 DO RAD(VISITIEN,.NPRIM,.PRIMARY,.PROVIDERLIST,RADPROXY,.CONTINUE)
End DoDot:3
End DoDot:2
End DoDot:1
+47 ;Report what was done.
+48 DO REPORT^PXQPPUTILR
+49 ;ICR #10052
+50 DO KILL^XUSCLEAN
+51 KILL ^TMP("PXQPPR",$JOB)
+52 QUIT
+53 ;
+54 ;===============
LAB(VISITIEN,NPRIM,PRIMARY,PROVIDERLIST,CONTINUE) ;Handle Lab
+1 ;encounters that do not have a primary provider.
+2 IF NPRIM=1
QUIT
+3 NEW ENCPROV,IENS,FDA,MSG,ORDPROV,NENCPROV,NORDPROV,RESULT,TEMP,VCPTIEN
+4 SET (NENCPROV,NORDPROV)=0
+5 SET VCPTIEN=""
+6 FOR
SET VCPTIEN=$ORDER(^AUPNVCPT("AD",VISITIEN,VCPTIEN))
if VCPTIEN=""
QUIT
Begin DoDot:1
+7 SET TEMP=$GET(^AUPNVCPT(VCPTIEN,12))
+8 IF TEMP=""
QUIT
+9 SET ORDPROV=$PIECE(TEMP,U,2)
+10 SET ENCPROV=$PIECE(TEMP,U,4)
+11 IF (ORDPROV'="")
IF ('$DATA(ORDPROVLIST(ORDPROV)))
SET ORDPROVLIST(ORDPROV)=""
SET NORDPROV=NORDPROV+1
+12 IF (ENCPROV'="")
IF ('$DATA(ENCPROVLIST(ENCPROV)))
SET ENCPROVLIST(ENCPROV)=""
SET NENCPROV=NENCPROV+1
End DoDot:1
+13 ;If there is only one ordering provider make sure they are primary.
+14 IF NORDPROV=1
Begin DoDot:1
+15 SET ORDPROV=$ORDER(ORDPROVLIST(""))
+16 SET IENS=$PIECE(PROVIDERLIST(ORDPROV),U,1)_","
+17 SET FDA(9000010.06,IENS,.04)="P"
+18 DO FILE^DIE("K","FDA","MSG")
+19 SET RESULT=$SELECT($DATA(MSG):FAILED,1:"SUCCESS")
+20 SET ^TMP("PXQPPR",$JOB,"LAB","SETP",VISITIEN,ORDPROV)=RESULT
End DoDot:1
+21 ;If the number of ordering providers is not one open the encounter for
+22 ;editing.
+23 IF NORDPROV'=1
Begin DoDot:1
+24 DO OPENENCOUNTER(VISITIEN)
+25 SET ^TMP("PXQPPR",$JOB,"LAB","OPEN",VISITIEN)=""
End DoDot:1
+26 ;Ask the user if they want to continue.
+27 SET CONTINUE=$$ASKCONTINUE
+28 QUIT
+29 ;
+30 ;===============
RAD(VISITIEN,NPRIM,PRIMARY,PROVIDERLIST,RADPROXY,CONTINUE) ;Handle Radiology
+1 ;encounters that ;do not have a primary provider or the primary
+2 ;provider is the proxy.
+3 ;If there is no primary provider set one.
+4 IF NPRIM=0
DO RADPRIM(VISITIEN,.PROVIDERLIST,.PRIMARY)
+5 ;If there is no Radiology exam linked to this Visit try to link it.
+6 IF '$DATA(^RADPT("AVSIT",VISITIEN))
DO FINDEXAM(VISITIEN)
+7 ;If the Primary Provider is the proxy go to RADPROXYPP so the
+8 ;user can easily edit the Primary Provider.
+9 IF PRIMARY=RADPROXY
DO RADPROXYPP(VISITIEN,.CONTINUE)
+10 QUIT
+11 ;
+12 ;===============
RADPRIM(VISITIEN,PROVIDERLIST,PRIMARY) ;Set a primary provider for
+1 ;Radiology encounters that do not have one.
+2 NEW ENCDT,ENCPROV,IENS,FDA,MSG,ORDPROV,PERSONCLASS,RESULT,VCPTIEN
+3 ;Find the Encounter Provider and Ordering Provider in V CPT.
+4 SET VCPTIEN=$ORDER(^AUPNVCPT("AD",VISITIEN,""))
+5 IF VCPTIEN=""
QUIT
+6 SET ENCPROV=$PIECE(^AUPNVCPT(VCPTIEN,12),U,4)
+7 SET ORDPROV=$PIECE(^AUPNVCPT(VCPTIEN,12),U,2)
+8 ;If there is an existing V Provider entry for the encounter provider
+9 ;make it primary. If not, create a new V Provider entry.
+10 IF (ENCPROV'="")
IF $DATA(PROVIDERLIST(ENCPROV))
Begin DoDot:1
+11 IF $PIECE(PROVIDERLIST(ENCPROV),U,2)="P"
QUIT
+12 SET IENS=$PIECE(PROVIDERLIST(ENCPROV),U,1)_","
+13 SET FDA(9000010.06,IENS,.04)="P"
+14 DO FILE^DIE("K","FDA","MSG")
+15 SET RESULT=$SELECT($DATA(MSG):FAILED,1:"SUCCESS")
+16 SET ^TMP("PXQPPR",$JOB,"RAD","SETP",VISITIEN,ENCPROV)=RESULT
+17 ;Make Ordering Provider secondary.
End DoDot:1
+18 IF (ORDPROV'="")
IF $DATA(PROVIDERLIST(ORDPROV))
Begin DoDot:1
+19 IF $PIECE(PROVIDERLIST(ORDPROV),U,2)="S"
QUIT
+20 SET IENS=$PIECE(PROVIDERLIST(ORDPROV),U,1)_","
+21 KILL FDA,MSG
+22 SET FDA(9000010.06,IENS,.04)="S"
+23 DO FILE^DIE("K","FDA","MSG")
End DoDot:1
+24 SET ENCDT=$PIECE($GET(^AUPNVCPT(VCPTIEN,12)),U,1)
+25 IF ENCDT=""
SET ENCDT=$PIECE(^AUPNVSIT(VISITIEN,0),U,1)
+26 ;No V Provider entry found.
+27 IF (ENCPROV'="")
IF '$DATA(PROVIDERLIST(ENCPROV))
Begin DoDot:1
+28 KILL FDA,MSG
+29 ;Get the values for Patient, Visit, Event Date and Time, Comments,
+30 ;Package, and Data Source from the V CPT entry.
+31 SET FDA(9000010.06,"+1,",.01)=ENCPROV
+32 SET FDA(9000010.06,"+1,",.02)=$PIECE(^AUPNVCPT(VCPTIEN,0),U,2)
+33 SET FDA(9000010.06,"+1,",.03)=$PIECE(^AUPNVCPT(VCPTIEN,0),U,3)
+34 SET FDA(9000010.06,"+1,",.04)="P"
+35 SET PERSONCLASS=$PIECE($$GET^XUA4A72(ENCPROV,ENCDT),U,1)
+36 IF +PERSONCLASS>0
SET FDA(9000010.06,"+1,",.06)=PERSONCLASS
+37 SET FDA(9000010.06,"+1,",1201)=$PIECE($GET(^AUPNVCPT(VCPTIEN,12)),U,1)
+38 SET FDA(9000010.06,"+1,",81101)=$GET(^AUPNVCPT(VCPTIEN,811))
+39 SET FDA(9000010.06,"+1,",81202)=$PIECE($GET(^AUPNVCPT(VCPTIEN,812)),U,2)
+40 SET FDA(9000010.06,"+1,",81203)=$PIECE($GET(^AUPNVCPT(VCPTIEN,812)),U,3)
+41 DO UPDATE^DIE("","FDA","","MSG")
End DoDot:1
+42 IF (ORDPROV'="")
IF '$DATA(PROVIDERLIST(ORDPROV))
Begin DoDot:1
+43 KILL FDA,MSG
+44 SET FDA(9000010.06,"+1,",.01)=ORDPROV
+45 SET FDA(9000010.06,"+1,",.02)=$PIECE(^AUPNVCPT(VCPTIEN,0),U,2)
+46 SET FDA(9000010.06,"+1,",.03)=$PIECE(^AUPNVCPT(VCPTIEN,0),U,3)
+47 SET FDA(9000010.06,"+1,",.04)="S"
+48 SET PERSONCLASS=$PIECE($$GET^XUA4A72(ORDPROV,ENCDT),U,1)
+49 IF +PERSONCLASS>0
SET FDA(9000010.06,"+1,",.06)=PERSONCLASS
+50 SET FDA(9000010.06,"+1,",1201)=$PIECE($GET(^AUPNVCPT(VCPTIEN,12)),U,1)
+51 SET FDA(9000010.06,"+1,",81101)=$GET(^AUPNVCPT(VCPTIEN,811))
+52 SET FDA(9000010.06,"+1,",81202)=$PIECE($GET(^AUPNVCPT(VCPTIEN,812)),U,2)
+53 SET FDA(9000010.06,"+1,",81203)=$PIECE($GET(^AUPNVCPT(VCPTIEN,812)),U,3)
+54 DO UPDATE^DIE("","FDA","","MSG")
End DoDot:1
+55 SET PRIMARY=ENCPROV
+56 QUIT
+57 ;
+58 ;===============
RADPROXYPP(VISITIEN,CONTINUE) ;Radiology encounter has the proxy as the primary
+1 ;provider.
+2 ;Display the Impression Text, it should contain the name and NPI
+3 ;of the teleradiology provider.
+4 DO DISPIMPTEXT(VISITIEN)
+5 ;Open the Encounter for editing.
+6 DO OPENENCOUNTER(VISITIEN)
+7 SET ^TMP("PXQPPR",$JOB,"RAD","PROXY",VISITIEN)=""
+8 ;Ask the user if they want to continue.
+9 SET CONTINUE=$$ASKCONTINUE
+10 QUIT
+11 ;
+12 ;===============
SETONEPRIME(PROVIDERLIST) ;There is only one provider for the encounter
+1 ;and it is not marked primary provider, make it primary.
+2 NEW FDA,IENS,MSG,PROVIDER,RESULT
+3 SET PROVIDER=$ORDER(PROVIDERLIST(""))
+4 SET IENS=$PIECE(PROVIDERLIST(PROVIDER),U,1)_","
+5 SET FDA(9000010.06,IENS,.04)="P"
+6 DO FILE^DIE("K","FDA","MSG")
+7 SET RESULT=$SELECT($DATA(MSG):"FAILED",1:"SUCCESS")
+8 SET ^TMP("PXQPPR",$JOB,"SET1P",IENS,PROVIDER)=RESULT
+9 QUIT
+10 ;
