PXBPPRV ;ISL/JVS,ESW - PROMPT PROVIDER ; 10/31/02 12:12pm
;;1.0;PCE PATIENT CARE ENCOUNTER;**1,7,11,19,108**;Aug 12, 1996
;
; VARIABLE LIST
; SELINE= Line number of selected item
;
PRV ;--PROVIDER
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) ;108
I $D(FROM),FROM="CPT",$P(REQI,"^",1),$P(REQE,"^",1)'["..." S $P(PXBDPRV,"^",2)=$P(REQE,"^",1)
W $P($G(PXBDPRV),"^",2) W:$D(PXBDPRV) " // ",IOELEOL
;
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
;
I DATA="",$D(PXBDPRV) S DATA=$P($G(PXBDPRV),"^",2) 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
;
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)),"^",2) S:PRISEC["PRI" FPRI=0
.S DATA=$P($G(PXBSAM(DATA)),"^",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(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 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,"^",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
S FROM="PRV",(VAL,Y)=$$DOUBLE1^PXBGPRV2(FROM) I Y<1 S DATA="^P",DOUBLEQQ=1 G P1
;S (X,DATA,EDATA)=$P(VAL,"^",2),DIC="^VA(200,",DIC(0)="MZ" D ^DIC
S X="`"_+Y,(DATA,EDATA)=$P(VAL,"^",2),DIC="^VA(200,",DIC(0)="MZ" D ^DIC
I Y=-1 S PXBUT=1 G PRVX
;
;--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),"^",2)]""),$D(PXBKY($P(Y,"^",2))) D
.S LINE=$O(PXBKY($P(Y,"^",2),0))
.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,"^",1))=""
S PXBNPRVL(1)=$P(PRV,"^",1) S ^DISV(DUZ,"PXBPRV-4")=$P(PRV,"^",1)
I $D(PXBKY($P(Y(0),"^"))),$G(SELINE) S $P(REQI,"^",7)=$O(PXBSKY(SELINE,0)),$P(REQI,"^",2)=$P($G(PXBSAM(SELINE)),"^",2)
I $D(PXBKY($P(Y(0),"^"))),'$G(SELINE) S $P(REQI,"^",7)=$O(PXBSKY($O(PXBKY($P(Y(0),"^"),0)),0)) S PAT=$P(Y(0),"^",1),ITEM=$O(PXBKY(PAT,0)),$P(REQI,"^",2)=$E($P($G(PXBKY(PAT,ITEM)),"^",2),1),$P(REQE,"^",2)=$P($G(PXBKY(PAT,ITEM)),"^",2)
S $P(REQI,"^",1)=+Y
I $P(REQI,"^",2)']"" S $P(REQI,"^",2)="S",$P(REQE,"^",2)="SECONDARY"
S $P(REQE,"^",1)=$P(PRV,"^",1)
I '$D(REQI) S REQI=""
;---IF INACTIVE ISSUE A WARNING
I DATA]"" D ACTIVE^PXBPPRV1
PRVX ;--EXIT AND CLEAN UP
I $G(WHAT)="INTV",DATA="^" S PXBEXIT="^^"
I '$D(REQI) S REQI=""
I '$D(REQE) S REQE=""
I $P(REQE,"^",1)="" S $P(REQE,"^",1)="...No Provider Selected..."
I FROM="PRV",$L(EDATA)<40 D
.F I=1:1:$L(ECHO) W IOCUB,IOELEOL
.F I=1:1:$L(ECHO) W IOCUF
.I $P(REQE,"^",1)'["...No" W $P(REQE,"^",1)
Q
PXBPPRV ;ISL/JVS,ESW - PROMPT PROVIDER ; 10/31/02 12:12pm
+1 ;;1.0;PCE PATIENT CARE ENCOUNTER;**1,7,11,19,108**;Aug 12, 1996
+2 ;
+3 ; VARIABLE LIST
+4 ; SELINE= Line number of selected item
+5 ;
PRV ;--PROVIDER
+1 IF $DATA(PXBNPRVL)
WRITE IOSC
DO LOC^PXBCC(2,0)
WRITE IOUON,"Previous Entry: ",$GET(PXBNPRVL(1))
FOR I=1:1:10
WRITE " "
+2 IF $DATA(PXBNPRVL)
WRITE IORC
+3 WRITE IOUOFF
+4 NEW TIMED,EDATA,DIC,LINE,XFLAG,SELINE,UDATA,ECHO
+5 IF '$DATA(^DISV(DUZ,"PXBPRV-4"))
SET ^DISV(DUZ,"PXBPRV-4")=" "
+6 IF '$DATA(IOSC)
DO TERM^PXBCC
+7 SET DOUBLEQQ=0
+8 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 ;108
IF $DATA(PRVDR)
SET PXBDPRV="^"_$PIECE(PRVDR("PRIMARY"),U)
+21 IF $DATA(FROM)
IF FROM="CPT"
IF $PIECE(REQI,"^",1)
IF $PIECE(REQE,"^",1)'["..."
SET $PIECE(PXBDPRV,"^",2)=$PIECE(REQE,"^",1)
+22 WRITE $PIECE($GET(PXBDPRV),"^",2)
IF $DATA(PXBDPRV)
WRITE " // ",IOELEOL
+23 ;
+24 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 ;
+14 IF DATA=""
IF $DATA(PXBDPRV)
SET DATA=$PIECE($GET(PXBDPRV),"^",2)
IF DATA=""
SET PXBUT=1
GOTO PRVX
+15 IF DATA=""
IF '$DATA(PXBDPRV)
SET PXBUT=1
GOTO PRVX
+16 ;
+17 IF PXBCNT>10&((DATA="+")!(DATA="-"))
DO DPRV4^PXBDPRV(DATA)
WRITE IORC
DO WIN17^PXBCC(PXBCNT)
GOTO P
+18 ;
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)),"^",2)
IF PRISEC["PRI"
SET FPRI=0
+6 SET DATA=$PIECE($GET(PXBSAM(DATA)),"^",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(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
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,"^",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 SET FROM="PRV"
SET (VAL,Y)=$$DOUBLE1^PXBGPRV2(FROM)
IF Y<1
SET DATA="^P"
SET DOUBLEQQ=1
GOTO P1
+26 ;S (X,DATA,EDATA)=$P(VAL,"^",2),DIC="^VA(200,",DIC(0)="MZ" D ^DIC
+27 SET X="`"_+Y
SET (DATA,EDATA)=$PIECE(VAL,"^",2)
SET DIC="^VA(200,"
SET DIC(0)="MZ"
DO ^DIC
+28 IF Y=-1
SET PXBUT=1
GOTO PRVX
+29 ;
+30 ;--If Y is good and already in file...
+31 ;I '$G(DOUBLEQQ),$D(Y),$D(PXBKY($P(Y,"^",2))) D
+32 IF '$GET(DOUBLEQQ)
IF ($PIECE($GET(Y),"^",2)]"")
IF $DATA(PXBKY($PIECE(Y,"^",2)))
Begin DoDot:1
+33 SET LINE=$ORDER(PXBKY($PIECE(Y,"^",2),0))
+34 SET PRISEC=$PIECE($GET(PXBSAM(LINE)),"^",2)
IF PRISEC["PRI"
SET FPRI=0
End DoDot:1
+35 SET PRV=Y(0)
+36 ;
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,"^",1))=""
+6 SET PXBNPRVL(1)=$PIECE(PRV,"^",1)
SET ^DISV(DUZ,"PXBPRV-4")=$PIECE(PRV,"^",1)
+7 IF $DATA(PXBKY($PIECE(Y(0),"^")))
IF $GET(SELINE)
SET $PIECE(REQI,"^",7)=$ORDER(PXBSKY(SELINE,0))
SET $PIECE(REQI,"^",2)=$PIECE($GET(PXBSAM(SELINE)),"^",2)
+8 IF $DATA(PXBKY($PIECE(Y(0),"^")))
IF '$GET(SELINE)
SET $PIECE(REQI,"^",7)=$ORDER(PXBSKY($ORDER(PXBKY($PIECE(Y(0),"^"),0)),0))
SET PAT=$PIECE(Y(0),"^",1)
SET ITEM=$ORDER(PXBKY(PAT,0))
SET $PIECE(REQI,"^",2)=$EXTRACT($PIECE($GET(PXBKY(PAT,ITEM)),"^",2),1)
SET $PIECE(REQE,"^",2)=$PIECE($GET(PXBKY(PAT,ITEM)),"^",2)
+9 SET $PIECE(REQI,"^",1)=+Y
+10 IF $PIECE(REQI,"^",2)']""
SET $PIECE(REQI,"^",2)="S"
SET $PIECE(REQE,"^",2)="SECONDARY"
+11 SET $PIECE(REQE,"^",1)=$PIECE(PRV,"^",1)
+12 IF '$DATA(REQI)
SET REQI=""
+13 ;---IF INACTIVE ISSUE A WARNING
+14 IF DATA]""
DO ACTIVE^PXBPPRV1
PRVX ;--EXIT AND CLEAN UP
+1 IF $GET(WHAT)="INTV"
IF DATA="^"
SET PXBEXIT="^^"
+2 IF '$DATA(REQI)
SET REQI=""
+3 IF '$DATA(REQE)
SET REQE=""
+4 IF $PIECE(REQE,"^",1)=""
SET $PIECE(REQE,"^",1)="...No Provider Selected..."
+5 IF FROM="PRV"
IF $LENGTH(EDATA)<40
Begin DoDot:1
+6 FOR I=1:1:$LENGTH(ECHO)
WRITE IOCUB,IOELEOL
+7 FOR I=1:1:$LENGTH(ECHO)
WRITE IOCUF
+8 IF $PIECE(REQE,"^",1)'["...No"
WRITE $PIECE(REQE,"^",1)
End DoDot:1
+9 QUIT
