PXBPPRV ;ISL/JVS,ESW - PROMPT PROVIDER ; 7/12/07 11:14am
;;1.0;PCE PATIENT CARE ENCOUNTER;**1,7,11,19,108,141,152,186**;Aug 12, 1996;Build 3
;
; VARIABLE LIST
; SELINE= Line number of selected item
;
PRV ;--PROVIDER
I $D(PXBUT),$G(PXBUT) S PXBUT=0 ; patch *186*
I $D(PXBNPRVL) W IOSC D LOC^PXBCC(2,0) W IOUON,"Previous Entry: ",$G(PXBNPRVL(1)) F I=1:1:10 W " "
I $D(PXBNPRVL) W IORC
W IOUOFF
N TIMED,EDATA,DIC,LINE,XFLAG,SELINE,UDATA,ECHO
I '$D(^DISV(DUZ,"PXBPRV-4")) S ^DISV(DUZ,"PXBPRV-4")=" "
I '$D(IOSC) D TERM^PXBCC
S DOUBLEQQ=0
S TIMED="I '$T!(DATA=""^"")"
P ;--Second Entry point
W IOSC
;--DYNAMIC HEADER--
I '$D(CYCL) D
.I PXBCNT=0,DOUBLEQQ=0,$G(WHAT)'["PRV" D LOC^PXBCC(1,10) W "...There are "_$G(PXBCNT)_" PROVIDER(S) associated with this encounter."
.I PXBCNT=1,DOUBLEQQ=0,$G(WHAT)'["PRV" D LOC^PXBCC(1,10) W "...There is "_$G(PXBCNT)_" PROVIDER associated with this encounter."
.I PXBCNT>1,DOUBLEQQ=0,$G(WHAT)'["PRV" D LOC^PXBCC(1,10) W "...There are "_$G(PXBCNT)_" PROVIDERS associated with this encounter."
;
I $G(FROM)'="PL" D LOC^PXBCC(15,0)
I $G(FROM)'["PRV" N PXBNPRVL
I $D(FROM),FROM="PL" W IORC
I $G(FROM)'="PL",PXBCNT>10&('$G(DOUBLEQQ)) W IOELEOL,!,"Enter '+' for next page, '-' for previous page."
;--Dynamic prompting for the provider--
I '$D(^TMP("PXK",$J,"PRV")),'$D(FROM) W !,"Enter PROVIDER: " W IOELEOL
I '$D(FROM),$D(^TMP("PXK",$J,"PRV")) W !,"Enter ",IOINHI,"NEXT",IOINLOW," PROVIDER: " W IOELEOL
I $D(FROM),FROM="CPT",'$D(^TMP("PXK",$J,"PRV")) W IORC,!,"Enter PROVIDER associated with PROCEDURE: " W IOELEOL
I $D(FROM),FROM="PRV" W !,"Enter PROVIDER: " W IOELEOL
I $D(FROM),FROM="CPT",$D(^TMP("PXK",$J,"PRV")) W IORC,!,"Enter PROVIDER associated with PROCEDURES: " W IOELEOL
I $D(FROM),FROM="PL" W !,"Enter PROVIDER associated with PROBLEM: " W IOELEOL
I $D(FROM),FROM="PL" S PXBDPRV="^"_$P($G(PRVDR("PRIMARY")),U) ;;108
;I $D(PRVDR) S PXBDPRV="^"_$P(PRVDR("PRIMARY"),U) S:$G(PXBCNT)>1&($P($G(REQE),U)=0) D0=$P($G(PRVDR("PRIMARY")),U,3)
I $D(PRVDR) S PXBDPRV="^"_$P(PRVDR("PRIMARY"),U),D0=$P($G(PRVDR("PRIMARY")),U,3)
I $D(FROM),FROM="CPT",$P(REQI,U,1),$P(REQE,U,1)'["..." S $P(PXBDPRV,U,2)=$P(REQE,U,1)
I $P($G(REQI),U,8)'="",$G(FROM)'="CPT" S D0=$P($G(^AUPNVCPT($P(REQI,U,8),12)),U,4),PXBDPRV="^"_$P(REQE,U)
; begin patch *186*
; W $P($G(PXBDPRV),"^",2) W:$D(PXBDPRV) " // ",IOELEOL
W $P($G(PXBDPRV),"^",2) W:$D(PXBDPRV)&($G(PXBDPRV)'="^") " // ",IOELEOL
; end patch *186*
;
R DATA:DTIME S (EDATA,ECHO)=DATA
P1 ;--Third entry point
X TIMED I S PXBUT=1 S:DATA="^" LEAVE=1 G PRVX
I DATA?1.N1"E".NAP S DATA=" "_DATA
I $L(DATA)>200 S (DATA,EDATA)=$E(DATA,1,199)
I DATA?24.N S (DATA,EDATA)=$E(DATA,1,24)
D CASE^PXBUTL
;---SPACE BAR
I DATA=" ",$D(^DISV(DUZ,"PXBPRV-4")) S (DATA,EDATA)=^DISV(DUZ,"PXBPRV-4") W DATA
;-----------
I DATA="^^" S PXBEXIT=0 G PRVX
;---I Prompt can jump to others put symbols in here
I DATA["^P" G PRVX
I DATA["^I" G PRVX
; PX*1.0*152 - need to flag if default has been chosen. PXBDPRV gets killed so can't be used as flag.
N PXDEF152 S PXDEF152=0
I DATA="",$D(PXBDPRV) S DATA=$P($G(PXBDPRV),"^",2),PXDEF152=1 I DATA="" S PXBUT=1 G PRVX
I DATA="",'$D(PXBDPRV) S PXBUT=1 G PRVX
;
I PXBCNT>10&((DATA="+")!(DATA="-")) D DPRV4^PXBDPRV(DATA) W IORC D WIN17^PXBCC(PXBCNT) G P
;
K PRVN1 S VIEN=0 F I=1:1 S VIEN=$O(PXBSAM(VIEN)) Q:VIEN="" S PRVN1=PXBSAM(VIEN),PRVN1($P(PRVN1,U,4))=PRVN1_"^"_VIEN
M ;--IF Multiple entries have been entered
;--CAN'T DO!!!!
;--IF Multiple deleting of entries
D DELM^PXBPPRV1
I $G(NF) G P1
;
LI ;--If picked a line number
I (DATA>0)&(DATA<(PXBCNT+1))&($L(DATA)'>$L(PXBCNT)) S XFLAG=1 D REVPRV^PXBCC(DATA) S SELINE=DATA D
.I $G(FROM)["PL" Q
.I $G(FROM)["CPT" K SELINE S DATA="NOT VALID" Q
.F I=1:1:$L(DATA) W IOCUB,IOECH
.S PRISEC=$P($G(PXBSAM(DATA)),U,2) S:PRISEC["PRI" FPRI=0
.S DATA=$P($G(PXBSAM(DATA)),U,1)
I $D(XFLAG),XFLAG=1 S Y=DATA G PFIN
;
;--If PRV is already in the file
I DATA="" S PXBUT=1 G PRVX
I $G(FROM)'="CPT",'$G(DOUBLEQQ),$D(PXBKY(DATA)) D
.I PXBCNT>10 D DPRV4^PXBDPRV($O(PXBKY(DATA,0)))
.K Q D TIMES^PXBUTL(DATA)
.I Q=1 S LINE=$O(PXBKY(DATA,0)) S XFLAG=1 D:$G(FROM)'="PL" REVPRV^PXBCC(LINE) S PRISEC=$P($G(PXBSAM(LINE)),"^",2) I $P(PXBSAM(LINE),"^",2)["PRI" S FPRI=0
.I Q>1 S NLINE=0 F S NLINE=$O(Q(NLINE)) Q:NLINE="" D REVPRV^PXBCC(NLINE)
I $D(Q),Q>1 D WHICH^PXBPWCH G LI
I $D(XFLAG),XFLAG=1 S Y=DATA S:"CPT:PRV"[FROM&($G(D0)>0) Y="`"_D0 G PFIN
;--Need to do a DIC lookup on data
;
K FIRST
I DATA'="??" D:DATA="?" EN1^PXBHLP0("PXB","PRV",1,"",1) G:DATA="^P" P I DATA="?" G P
I DATA="??" S DOUBLEQQ=1 D EN1^PXBHLP0("PXB","PRV","",1,2) S:DATA="P" UDATA="^P" S:$L(DATA,"^")>1 (Y,DATA,EDATA)=$P(DATA,U,2) S:$G(UDATA)="" UDATA="^P" S:UDATA="^P" (DATA,EDATA,Y)=UDATA G:UDATA="^P" P1 G PFIN
;
;--If a "?" is NOT entered during lookup
;----PX*1.0*152
;----If PXDEF152 is 1 then the user has hit the enter key with a specific provider provided as the default.
;----There should be no need to prompt again.
I PXDEF152 D
.S X=DATA,DIC="^VA(200,",DIC(0)="O"
.D ^DIC S VAL=Y
.I Y<1 S PXDEF152=0
; begin patch *186*
; I 'PXDEF152 S FROM="PRV",(VAL,Y)=$$DOUBLE1^PXBGPRV2(FROM)
I 'PXDEF152 N PXOFROM S PXOFROM=FROM D S FROM=PXOFROM ;save FROM
. S FROM="PRV",(VAL,Y)=$$DOUBLE1^PXBGPRV2(FROM)
. I Y<1,$G(ERROR)=1,$G(CYCL)=1 D
. . D HELP1^PXBUTL1("CON") R X:DTIME
. . I PXOFROM'="CPT" D LOC^PXBCC(3,1) W IOEDEOP D EN0^PXBDPRV K CYCL
. . I PXOFROM="CPT" D LOC^PXBCC(4,1) W IOEDEOP N Y D HEADER^PXBMCPT2
; end patch *186*
I Y<1 S DATA="^P",DOUBLEQQ=1 G P1
;S (X,DATA,EDATA)=$P(VAL,U,2),DIC="^VA(200,",DIC(0)="MZ" D ^DIC
; begin patch *186*
; S X="`"_+Y,(DATA,EDATA)=$P(VAL,U,2),DIC="^VA(200,",DIC(0)="MZ" D ^DIC
; I Y=-1 S PXBUT=1 G PRVX
S DIC("S")="I $$ACTIVPRV^PXAPI(Y,$G(IDATE,DT))"
S X="`"_+Y,(DATA,EDATA)=$P(VAL,U,2),DIC="^VA(200,",DIC(0)="MZ" D ^DIC
I Y=-1 D G PRVX
. D LOC^PXBCC(16,0),HELP^PXBUTL0("PRVM")
. D HELP1^PXBUTL1("CON") R X:DTIME
. D LOC^PXBCC(3,1) W IOEDEOP
. D LOC^PXBCC(15,0)
. S DATA="^P",PXBUT=1,FIRST=1
. D:FROM="CPT" HEADER^PXBMCPT2
; end patch *186*
;--If Y is good and already in file...
;I '$G(DOUBLEQQ),$D(Y),$D(PXBKY($P(Y,"^",2))) D
I '$G(DOUBLEQQ),($P($G(Y),U)>0),$D(PRVN1($P(Y,U))) D
.S LINE=$P(PRVN1($P(Y,U)),U,5)
.S PRISEC=$P($G(PXBSAM(LINE)),"^",2) S:PRISEC["PRI" FPRI=0
S PRV=Y(0)
;
PFIN ;--Finish the Provider
I $L(Y,"^")'>1,$G(SELINE) S X="`"_$P(^AUPNVPRV($O(PXBSKY(SELINE,0)),0),"^",1),DIC="^VA(200,",DIC(0)="MZ" D ^DIC
I $L(Y,"^")'>1,'$G(SELINE) S X=Y,DIC="^VA(200,",DIC(0)="MZ" D ^DIC
I +Y<0 D HELP^PXBUTL0("PRVM") W IOCUU G P
S PRV=Y(0)
S PXBNPRV($P(PRV,U,1))=""
S PXBNPRVL(1)=$P(PRV,U,1) S ^DISV(DUZ,"PXBPRV-4")=$P(PRV,U,1)
I $D(PRVN1($P(Y,U))),$G(SELINE) S $P(REQI,U,7)=$O(PXBSKY(SELINE,0)),$P(REQI,U,2)=$P($G(PXBSAM(SELINE)),U,2)
I $D(PRVN1($P(Y,U))),'$G(SELINE) S PRVN1=PRVN1($P(Y,U)) D
.S $P(REQI,U,7)=$O(PXBSKY($P(PRVN1,U,5),0))
.S PAT=$P(Y(0),U,1),ITEM=$P(PRVN1,U,5),$P(REQI,U,2)=$E($P(PRVN1,U,2),1),$P(REQE,U,2)=$P(PRVN1,U,2)
S $P(REQI,U,1)=+Y
I $P(REQI,U,2)']"" S $P(REQI,U,2)="S",$P(REQE,U,2)="SECONDARY"
S $P(REQE,U,1)=$P(PRV,U,1)
I '$D(REQI) S REQI=""
;---IF INACTIVE ISSUE A WARNING
I DATA]"" D ACTIVE^PXBPPRV1 K DIR
PRVX ;--EXIT AND CLEAN UP
K PRVN1,VIEN,D0
I $G(WHAT)="INTV",DATA="^" S PXBEXIT="^^"
I '$D(REQI) S REQI=""
I '$D(REQE) S REQE=""
I $P(REQE,U,1)="" S $P(REQE,U,1)="...No Provider Selected..."
; begin patch *186*
; I FROM="PRV",$L(EDATA)<40 D
I "CPT:PL:PRV"[FROM,$L(EDATA)<40 D
.F I=1:1:$L(ECHO) W IOCUB,IOELEOL
.F I=1:1:$L(ECHO) W IOCUF
.I $P(REQE,U,1)'["...No" W $P(REQE,U,1)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXBPPRV 7761 printed Apr 09, 2024@21:27:56 Page 2
PXBPPRV ;ISL/JVS,ESW - PROMPT PROVIDER ; 7/12/07 11:14am
+1 ;;1.0;PCE PATIENT CARE ENCOUNTER;**1,7,11,19,108,141,152,186**;Aug 12, 1996;Build 3
+2 ;
+3 ; VARIABLE LIST
+4 ; SELINE= Line number of selected item
+5 ;
PRV ;--PROVIDER
+1 ; patch *186*
IF $DATA(PXBUT)
IF $GET(PXBUT)
SET PXBUT=0
+2 IF $DATA(PXBNPRVL)
WRITE IOSC
DO LOC^PXBCC(2,0)
WRITE IOUON,"Previous Entry: ",$GET(PXBNPRVL(1))
FOR I=1:1:10
WRITE " "
+3 IF $DATA(PXBNPRVL)
WRITE IORC
+4 WRITE IOUOFF
+5 NEW TIMED,EDATA,DIC,LINE,XFLAG,SELINE,UDATA,ECHO
+6 IF '$DATA(^DISV(DUZ,"PXBPRV-4"))
SET ^DISV(DUZ,"PXBPRV-4")=" "
+7 IF '$DATA(IOSC)
DO TERM^PXBCC
+8 SET DOUBLEQQ=0
+9 SET TIMED="I '$T!(DATA=""^"")"
P ;--Second Entry point
+1 WRITE IOSC
+2 ;--DYNAMIC HEADER--
+3 IF '$DATA(CYCL)
Begin DoDot:1
+4 IF PXBCNT=0
IF DOUBLEQQ=0
IF $GET(WHAT)'["PRV"
DO LOC^PXBCC(1,10)
WRITE "...There are "_$GET(PXBCNT)_" PROVIDER(S) associated with this encounter."
+5 IF PXBCNT=1
IF DOUBLEQQ=0
IF $GET(WHAT)'["PRV"
DO LOC^PXBCC(1,10)
WRITE "...There is "_$GET(PXBCNT)_" PROVIDER associated with this encounter."
+6 IF PXBCNT>1
IF DOUBLEQQ=0
IF $GET(WHAT)'["PRV"
DO LOC^PXBCC(1,10)
WRITE "...There are "_$GET(PXBCNT)_" PROVIDERS associated with this encounter."
End DoDot:1
+7 ;
+8 IF $GET(FROM)'="PL"
DO LOC^PXBCC(15,0)
+9 IF $GET(FROM)'["PRV"
NEW PXBNPRVL
+10 IF $DATA(FROM)
IF FROM="PL"
WRITE IORC
+11 IF $GET(FROM)'="PL"
IF PXBCNT>10&('$GET(DOUBLEQQ))
WRITE IOELEOL,!,"Enter '+' for next page, '-' for previous page."
+12 ;--Dynamic prompting for the provider--
+13 IF '$DATA(^TMP("PXK",$JOB,"PRV"))
IF '$DATA(FROM)
WRITE !,"Enter PROVIDER: "
WRITE IOELEOL
+14 IF '$DATA(FROM)
IF $DATA(^TMP("PXK",$JOB,"PRV"))
WRITE !,"Enter ",IOINHI,"NEXT",IOINLOW," PROVIDER: "
WRITE IOELEOL
+15 IF $DATA(FROM)
IF FROM="CPT"
IF '$DATA(^TMP("PXK",$JOB,"PRV"))
WRITE IORC,!,"Enter PROVIDER associated with PROCEDURE: "
WRITE IOELEOL
+16 IF $DATA(FROM)
IF FROM="PRV"
WRITE !,"Enter PROVIDER: "
WRITE IOELEOL
+17 IF $DATA(FROM)
IF FROM="CPT"
IF $DATA(^TMP("PXK",$JOB,"PRV"))
WRITE IORC,!,"Enter PROVIDER associated with PROCEDURES: "
WRITE IOELEOL
+18 IF $DATA(FROM)
IF FROM="PL"
WRITE !,"Enter PROVIDER associated with PROBLEM: "
WRITE IOELEOL
+19 ;;108
IF $DATA(FROM)
IF FROM="PL"
SET PXBDPRV="^"_$PIECE($GET(PRVDR("PRIMARY")),U)
+20 ;I $D(PRVDR) S PXBDPRV="^"_$P(PRVDR("PRIMARY"),U) S:$G(PXBCNT)>1&($P($G(REQE),U)=0) D0=$P($G(PRVDR("PRIMARY")),U,3)
+21 IF $DATA(PRVDR)
SET PXBDPRV="^"_$PIECE(PRVDR("PRIMARY"),U)
SET D0=$PIECE($GET(PRVDR("PRIMARY")),U,3)
+22 IF $DATA(FROM)
IF FROM="CPT"
IF $PIECE(REQI,U,1)
IF $PIECE(REQE,U,1)'["..."
SET $PIECE(PXBDPRV,U,2)=$PIECE(REQE,U,1)
+23 IF $PIECE($GET(REQI),U,8)'=""
IF $GET(FROM)'="CPT"
SET D0=$PIECE($GET(^AUPNVCPT($PIECE(REQI,U,8),12)),U,4)
SET PXBDPRV="^"_$PIECE(REQE,U)
+24 ; begin patch *186*
+25 ; W $P($G(PXBDPRV),"^",2) W:$D(PXBDPRV) " // ",IOELEOL
+26 WRITE $PIECE($GET(PXBDPRV),"^",2)
if $DATA(PXBDPRV)&($GET(PXBDPRV)'="^")
WRITE " // ",IOELEOL
+27 ; end patch *186*
+28 ;
+29 READ DATA:DTIME
SET (EDATA,ECHO)=DATA
P1 ;--Third entry point
+1 XECUTE TIMED
IF $TEST
SET PXBUT=1
if DATA="^"
SET LEAVE=1
GOTO PRVX
+2 IF DATA?1.N1"E".NAP
SET DATA=" "_DATA
+3 IF $LENGTH(DATA)>200
SET (DATA,EDATA)=$EXTRACT(DATA,1,199)
+4 IF DATA?24.N
SET (DATA,EDATA)=$EXTRACT(DATA,1,24)
+5 DO CASE^PXBUTL
+6 ;---SPACE BAR
+7 IF DATA=" "
IF $DATA(^DISV(DUZ,"PXBPRV-4"))
SET (DATA,EDATA)=^DISV(DUZ,"PXBPRV-4")
WRITE DATA
+8 ;-----------
+9 IF DATA="^^"
SET PXBEXIT=0
GOTO PRVX
+10 ;---I Prompt can jump to others put symbols in here
+11 IF DATA["^P"
GOTO PRVX
+12 IF DATA["^I"
GOTO PRVX
+13 ; PX*1.0*152 - need to flag if default has been chosen. PXBDPRV gets killed so can't be used as flag.
+14 NEW PXDEF152
SET PXDEF152=0
+15 IF DATA=""
IF $DATA(PXBDPRV)
SET DATA=$PIECE($GET(PXBDPRV),"^",2)
SET PXDEF152=1
IF DATA=""
SET PXBUT=1
GOTO PRVX
+16 IF DATA=""
IF '$DATA(PXBDPRV)
SET PXBUT=1
GOTO PRVX
+17 ;
+18 IF PXBCNT>10&((DATA="+")!(DATA="-"))
DO DPRV4^PXBDPRV(DATA)
WRITE IORC
DO WIN17^PXBCC(PXBCNT)
GOTO P
+19 ;
+20 KILL PRVN1
SET VIEN=0
FOR I=1:1
SET VIEN=$ORDER(PXBSAM(VIEN))
if VIEN=""
QUIT
SET PRVN1=PXBSAM(VIEN)
SET PRVN1($PIECE(PRVN1,U,4))=PRVN1_"^"_VIEN
M ;--IF Multiple entries have been entered
+1 ;--CAN'T DO!!!!
+2 ;--IF Multiple deleting of entries
+3 DO DELM^PXBPPRV1
+4 IF $GET(NF)
GOTO P1
+5 ;
LI ;--If picked a line number
+1 IF (DATA>0)&(DATA<(PXBCNT+1))&($LENGTH(DATA)'>$LENGTH(PXBCNT))
SET XFLAG=1
DO REVPRV^PXBCC(DATA)
SET SELINE=DATA
Begin DoDot:1
+2 IF $GET(FROM)["PL"
QUIT
+3 IF $GET(FROM)["CPT"
KILL SELINE
SET DATA="NOT VALID"
QUIT
+4 FOR I=1:1:$LENGTH(DATA)
WRITE IOCUB,IOECH
+5 SET PRISEC=$PIECE($GET(PXBSAM(DATA)),U,2)
if PRISEC["PRI"
SET FPRI=0
+6 SET DATA=$PIECE($GET(PXBSAM(DATA)),U,1)
End DoDot:1
+7 IF $DATA(XFLAG)
IF XFLAG=1
SET Y=DATA
GOTO PFIN
+8 ;
+9 ;--If PRV is already in the file
+10 IF DATA=""
SET PXBUT=1
GOTO PRVX
+11 IF $GET(FROM)'="CPT"
IF '$GET(DOUBLEQQ)
IF $DATA(PXBKY(DATA))
Begin DoDot:1
+12 IF PXBCNT>10
DO DPRV4^PXBDPRV($ORDER(PXBKY(DATA,0)))
+13 KILL Q
DO TIMES^PXBUTL(DATA)
+14 IF Q=1
SET LINE=$ORDER(PXBKY(DATA,0))
SET XFLAG=1
if $GET(FROM)'="PL"
DO REVPRV^PXBCC(LINE)
SET PRISEC=$PIECE($GET(PXBSAM(LINE)),"^",2)
IF $PIECE(PXBSAM(LINE),"^",2)["PRI"
SET FPRI=0
+15 IF Q>1
SET NLINE=0
FOR
SET NLINE=$ORDER(Q(NLINE))
if NLINE=""
QUIT
DO REVPRV^PXBCC(NLINE)
End DoDot:1
+16 IF $DATA(Q)
IF Q>1
DO WHICH^PXBPWCH
GOTO LI
+17 IF $DATA(XFLAG)
IF XFLAG=1
SET Y=DATA
if "CPT
SET Y="`"_D0
GOTO PFIN
+18 ;--Need to do a DIC lookup on data
+19 ;
+20 KILL FIRST
+21 IF DATA'="??"
if DATA="?"
DO EN1^PXBHLP0("PXB","PRV",1,"",1)
if DATA="^P"
GOTO P
IF DATA="?"
GOTO P
+22 IF DATA="??"
SET DOUBLEQQ=1
DO EN1^PXBHLP0("PXB","PRV","",1,2)
if DATA="P"
SET UDATA="^P"
if $LENGTH(DATA,"^")>1
SET (Y,DATA,EDATA)=$PIECE(DATA,U,2)
if $GET(UDATA)=""
SET UDATA="^P"
if UDATA="^P"
SET (DATA,EDATA,Y)=UDATA
if UDATA="^P"
GOTO P1
GOTO PFIN
+23 ;
+24 ;--If a "?" is NOT entered during lookup
+25 ;----PX*1.0*152
+26 ;----If PXDEF152 is 1 then the user has hit the enter key with a specific provider provided as the default.
+27 ;----There should be no need to prompt again.
+28 IF PXDEF152
Begin DoDot:1
+29 SET X=DATA
SET DIC="^VA(200,"
SET DIC(0)="O"
+30 DO ^DIC
SET VAL=Y
+31 IF Y<1
SET PXDEF152=0
End DoDot:1
+32 ; begin patch *186*
+33 ; I 'PXDEF152 S FROM="PRV",(VAL,Y)=$$DOUBLE1^PXBGPRV2(FROM)
+34 ;save FROM
IF 'PXDEF152
NEW PXOFROM
SET PXOFROM=FROM
Begin DoDot:1
+35 SET FROM="PRV"
SET (VAL,Y)=$$DOUBLE1^PXBGPRV2(FROM)
+36 IF Y<1
IF $GET(ERROR)=1
IF $GET(CYCL)=1
Begin DoDot:2
+37 DO HELP1^PXBUTL1("CON")
READ X:DTIME
+38 IF PXOFROM'="CPT"
DO LOC^PXBCC(3,1)
WRITE IOEDEOP
DO EN0^PXBDPRV
KILL CYCL
+39 IF PXOFROM="CPT"
DO LOC^PXBCC(4,1)
WRITE IOEDEOP
NEW Y
DO HEADER^PXBMCPT2
End DoDot:2
End DoDot:1
SET FROM=PXOFROM
+40 ; end patch *186*
+41 IF Y<1
SET DATA="^P"
SET DOUBLEQQ=1
GOTO P1
+42 ;S (X,DATA,EDATA)=$P(VAL,U,2),DIC="^VA(200,",DIC(0)="MZ" D ^DIC
+43 ; begin patch *186*
+44 ; S X="`"_+Y,(DATA,EDATA)=$P(VAL,U,2),DIC="^VA(200,",DIC(0)="MZ" D ^DIC
+45 ; I Y=-1 S PXBUT=1 G PRVX
+46 SET DIC("S")="I $$ACTIVPRV^PXAPI(Y,$G(IDATE,DT))"
+47 SET X="`"_+Y
SET (DATA,EDATA)=$PIECE(VAL,U,2)
SET DIC="^VA(200,"
SET DIC(0)="MZ"
DO ^DIC
+48 IF Y=-1
Begin DoDot:1
+49 DO LOC^PXBCC(16,0)
DO HELP^PXBUTL0("PRVM")
+50 DO HELP1^PXBUTL1("CON")
READ X:DTIME
+51 DO LOC^PXBCC(3,1)
WRITE IOEDEOP
+52 DO LOC^PXBCC(15,0)
+53 SET DATA="^P"
SET PXBUT=1
SET FIRST=1
+54 if FROM="CPT"
DO HEADER^PXBMCPT2
End DoDot:1
GOTO PRVX
+55 ; end patch *186*
+56 ;--If Y is good and already in file...
+57 ;I '$G(DOUBLEQQ),$D(Y),$D(PXBKY($P(Y,"^",2))) D
+58 IF '$GET(DOUBLEQQ)
IF ($PIECE($GET(Y),U)>0)
IF $DATA(PRVN1($PIECE(Y,U)))
Begin DoDot:1
+59 SET LINE=$PIECE(PRVN1($PIECE(Y,U)),U,5)
+60 SET PRISEC=$PIECE($GET(PXBSAM(LINE)),"^",2)
if PRISEC["PRI"
SET FPRI=0
End DoDot:1
+61 SET PRV=Y(0)
+62 ;
PFIN ;--Finish the Provider
+1 IF $LENGTH(Y,"^")'>1
IF $GET(SELINE)
SET X="`"_$PIECE(^AUPNVPRV($ORDER(PXBSKY(SELINE,0)),0),"^",1)
SET DIC="^VA(200,"
SET DIC(0)="MZ"
DO ^DIC
+2 IF $LENGTH(Y,"^")'>1
IF '$GET(SELINE)
SET X=Y
SET DIC="^VA(200,"
SET DIC(0)="MZ"
DO ^DIC
+3 IF +Y<0
DO HELP^PXBUTL0("PRVM")
WRITE IOCUU
GOTO P
+4 SET PRV=Y(0)
+5 SET PXBNPRV($PIECE(PRV,U,1))=""
+6 SET PXBNPRVL(1)=$PIECE(PRV,U,1)
SET ^DISV(DUZ,"PXBPRV-4")=$PIECE(PRV,U,1)
+7 IF $DATA(PRVN1($PIECE(Y,U)))
IF $GET(SELINE)
SET $PIECE(REQI,U,7)=$ORDER(PXBSKY(SELINE,0))
SET $PIECE(REQI,U,2)=$PIECE($GET(PXBSAM(SELINE)),U,2)
+8 IF $DATA(PRVN1($PIECE(Y,U)))
IF '$GET(SELINE)
SET PRVN1=PRVN1($PIECE(Y,U))
Begin DoDot:1
+9 SET $PIECE(REQI,U,7)=$ORDER(PXBSKY($PIECE(PRVN1,U,5),0))
+10 SET PAT=$PIECE(Y(0),U,1)
SET ITEM=$PIECE(PRVN1,U,5)
SET $PIECE(REQI,U,2)=$EXTRACT($PIECE(PRVN1,U,2),1)
SET $PIECE(REQE,U,2)=$PIECE(PRVN1,U,2)
End DoDot:1
+11 SET $PIECE(REQI,U,1)=+Y
+12 IF $PIECE(REQI,U,2)']""
SET $PIECE(REQI,U,2)="S"
SET $PIECE(REQE,U,2)="SECONDARY"
+13 SET $PIECE(REQE,U,1)=$PIECE(PRV,U,1)
+14 IF '$DATA(REQI)
SET REQI=""
+15 ;---IF INACTIVE ISSUE A WARNING
+16 IF DATA]""
DO ACTIVE^PXBPPRV1
KILL DIR
PRVX ;--EXIT AND CLEAN UP
+1 KILL PRVN1,VIEN,D0
+2 IF $GET(WHAT)="INTV"
IF DATA="^"
SET PXBEXIT="^^"
+3 IF '$DATA(REQI)
SET REQI=""
+4 IF '$DATA(REQE)
SET REQE=""
+5 IF $PIECE(REQE,U,1)=""
SET $PIECE(REQE,U,1)="...No Provider Selected..."
+6 ; begin patch *186*
+7 ; I FROM="PRV",$L(EDATA)<40 D
+8 IF "CPT:PL:PRV"[FROM
IF $LENGTH(EDATA)<40
Begin DoDot:1
+9 FOR I=1:1:$LENGTH(ECHO)
WRITE IOCUB,IOELEOL
+10 FOR I=1:1:$LENGTH(ECHO)
WRITE IOCUF
+11 IF $PIECE(REQE,U,1)'["...No"
WRITE $PIECE(REQE,U,1)
End DoDot:1
+12 QUIT
