PXBPPOV ;ISL/JVS - PROMPT POV ; 5/1/01 2:58pm
;;1.0;PCE PATIENT CARE ENCOUNTER;**11,28,92**;Aug 12, 1996
;
; VARIABLE LIST
; SELINE= Line number of selected item
;
POV ;--DIAGNOSIS
I $D(PXBNPOVL) D LOC^PXBCC(2,0) W IOUON,"Previous Entry: ",$G(PXBNPOVL(1)) F I=1:1:10 W " "
W IOUOFF
N TIMED,EDATA,DIC,LINE,XFLAG,SELINE,PXBEDIS,FPL
I '$D(^DISV(DUZ,"PXBPOV-3")) S ^DISV(DUZ,"PXBPOV-3")=" "
I '$D(IOSC) D TERM^PXBCC
S DOUBLEQQ=0
S TIMED="I '$T!(DATA=""^"")"
S DIC("S")="I $P($G(^ICD9(Y,0)),""^"",9)'=1!($P(^(0),""^"",11)'=""""&(IDATE<($P(^(0),""^"",11))))"
P ;--Second Entry point
W IOSC K FPL
;---DYNAMIC HEADER---
I '$D(CYCL) D
.I PXBCNT=0,DOUBLEQQ=0 D LOC^PXBCC(1,10) W "...There are "_$G(PXBCNT)_" ICD CODES associated with this encounter."
.I PXBCNT=1,DOUBLEQQ=0 D LOC^PXBCC(1,10) W "...There is "_$G(PXBCNT)_" ICD CODE associated with this encounter."
.I PXBCNT>1,DOUBLEQQ=0 D LOC^PXBCC(1,10) W "...There are "_$G(PXBCNT)_" ICD CODES associated with this encounter."
;
D LOC^PXBCC(15,0)
I PXBCNT>10&('$G(DOUBLEQQ)) W !,"Enter '+' for next page, '-' for previous page."
I '$D(^TMP("PXK",$J,"POV")) W !,"Enter Diagnosis : "_$G(PXBDPOV) W:$D(PXBDPOV) " //" W IOELEOL
I $D(^TMP("PXK",$J,"POV")) W !,"Enter ",IOINHI,"NEXT",IOINLOW," Diagnosis : "_$G(PXBDPOV) W:$D(PXBDPOV) " //" W IOELEOL
R DATA:DTIME S EDATA=DATA
P1 ;--Third entry point
X TIMED I S PXBUT=1,LEAVE=1,DATA="^" G POVX
I DATA?1.N1"E".NAP S DATA=" "_DATA
I DATA?24.N S (DATA,EDATA)=$E(DATA,1,24)
I $L(DATA)>200 S (DATA,EDATA)=$E(DATA,1,199)
D CASE^PXBUTL
;----SPACE BAR---
I DATA=" ",$D(^DISV(DUZ,"PXBPOV-3")) S DATA=^DISV(DUZ,"PXBPOV-3") W DATA
;-----------------
I DATA="^^" S PXBEXIT=0 G POVX
;---I Prompt can jump to others put symbols in here
I DATA["^P" G POVX
;------PXBDPOV=DEFAULT POV---
I DATA="",$D(PXBDPOV) S DATA=$P($G(PXBDPOV),"--",1)
I DATA="",'$D(PXBDPOV) S PXBUT=1,PXBSPL="",LEAVE=1 G POVX
;
I PXBCNT>10&((DATA="+")!(DATA="-")) D DPOV4^PXBDPOV(DATA) G P
;
M ;--------IF Multiple entries have been entered
D ADDM^PXBPPOV1
I $G(NF) G P1
;
;--------IF Multiple deleting of entries
D DELM^PXBPPOV1
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 REVPOV^PXBCC(DATA) S SELINE=DATA D
.F I=1:1:$L(DATA) W IOCUB,IOECH
.S PRISEC=$P($G(PXBSAM(DATA)),"^",4) S:PRISEC["PRI" FPRI=0
.S DATA=$P($G(PXBSAM(DATA)),"^",1)
I $D(XFLAG),XFLAG=1 S (Y,EDATA)=DATA G PFIN
LI1 ;
;--------If POV is already in the file
I '$G(DOUBLEQQ),$D(PXBKY(DATA)) D
.I PXBCNT>10 D DPOV4^PXBDPOV($O(PXBKY(DATA,0)))
.K Q D TIMES^PXBUTL(DATA)
.I Q=1 S LINE=$O(PXBKY(DATA,0)) S XFLAG=1 D REVPOV^PXBCC(LINE) S PRISEC=$P($G(PXBSAM(LINE)),"^",2) S:PRISEC["PRI" FPRI=0
.I Q>1 S NLINE=0 F S NLINE=$O(Q(NLINE)) Q:NLINE="" D REVPOV^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
I DATA'="??" D:DATA="?" EN1^PXBHLP0("PXB","POV",1,"",1) G:DATA="^P" P1 I DATA="?" G P
I DATA="??" S DOUBLEQQ=1 D EN1^PXBHLP0("PXB","POV","",1,2) S:$L(DATA,"^")>1 (Y,DATA,EDATA)=$P($P(DATA,"^",2),"--",1) G:Y>1 PFIN G:Y?1A1.NP PFIN I DATA<1 S DATA="^P" G P1
;
;--If a "?" is NOT entered during lookup
S (VAL,Y)=$$DOUBLE1^PXBGPOV2(WHAT) I Y<1 S DATA="^P" G P1
;<-*92*-< S (X,DATA,EDATA)=$P(VAL,"^",2),DIC=80,DIC(0)="MZ" D ^DIC
S (DATA,EDATA)=$P(VAL,"^",2),X="`"_+$P(Y,"^",1) K Y S DIC=80,DIC(0)="MZ" D ^DIC ;** PX*1.0*92 05/01/2001 make ^DIC selection "exact."
;
;--If Y is good and already in file...
I '$G(DOUBLEQQ),$D(Y),$D(PXBKY($P(Y,"^",2))) D
.S LINE=$O(PXBKY($P(Y,"^",2),0)) ;---D REVPOV^PXBCC(LINE)
.S PRISEC=$P($G(PXBSAM(LINE)),"^",4) S:PRISEC["PRI" FPRI=0
S POV=Y(0)
;
PFIN ;--Finish the DIAGNOSIS
I $L(Y,"^")'>1 S X=Y,DIC=80,DIC(0)="IZM" D ^DIC
I +Y<0 D HELP1^PXBUTL1("POV") G P
S POV=Y(0)
S PXBNPOV($P(POV,"^",1))=""
S PXBNPOVL(1)=$P(POV,"^",1) S ^DISV(DUZ,"PXBPOV-3")=DATA
I $D(PXBKY($P(Y(0),"^"))),$G(SELINE) S $P(REQI,"^",9)=$O(PXBSKY(SELINE,0))
I $D(PXBKY($P(Y(0),"^"))),'$G(SELINE) S $P(REQI,"^",9)=$O(PXBSKY($O(PXBKY($P(Y(0),"^"),0)),0))
I +Y>0 S PXBEDIS=$$EXTTEXT^PXUTL1(+Y,1,80,3)
S $P(REQI,"^",5)=+Y,$P(REQI,"^",6)="S"
S $P(REQE,"^",5)=$P(POV,"^",1)_" --"_$G(PXBEDIS),$P(REQE,"^",6)="SECONDARY"
POVX ;--EXIT AND CLEAN UP
I $G(WHAT)="INTV",DATA="^" S PXBEXIT="^^"
I '$D(REQE) S REQE=""
I $P(REQE,"^",5)="" S $P(REQE,"^",5)="...No Diagnosis Selected..."
Q
PXBPPOV ;ISL/JVS - PROMPT POV ; 5/1/01 2:58pm
+1 ;;1.0;PCE PATIENT CARE ENCOUNTER;**11,28,92**;Aug 12, 1996
+2 ;
+3 ; VARIABLE LIST
+4 ; SELINE= Line number of selected item
+5 ;
POV ;--DIAGNOSIS
+1 IF $DATA(PXBNPOVL)
DO LOC^PXBCC(2,0)
WRITE IOUON,"Previous Entry: ",$GET(PXBNPOVL(1))
FOR I=1:1:10
WRITE " "
+2 WRITE IOUOFF
+3 NEW TIMED,EDATA,DIC,LINE,XFLAG,SELINE,PXBEDIS,FPL
+4 IF '$DATA(^DISV(DUZ,"PXBPOV-3"))
SET ^DISV(DUZ,"PXBPOV-3")=" "
+5 IF '$DATA(IOSC)
DO TERM^PXBCC
+6 SET DOUBLEQQ=0
+7 SET TIMED="I '$T!(DATA=""^"")"
+8 SET DIC("S")="I $PXBPPOV_source.html#xP">PXBPXBPPOV_source.html#xP">PPXBPPOV_source.html#xP">POV_source.html#xPXBPPOV_source.html#xP">P">PXBPPOV_source.html#xP">P($G(^ICD9(Y,0)),""^"",9)'=1!($PXBPPOV_source.html#xP">PXBPXBPPOV_source.html#xP">PPXBPPOV_source.html#xP">POV_source.html#xPXBPPOV_source.html#xP">P">PXBPPOV_source.html#xP">P(^(0),""^"",11)'=""""&(IDATE<($PXBPPOV_source.html#xP">PXBPXBPPOV_source.html#xP">PPXBPPOV_source.html#xP">POV_source.html#xPXBPPOV_source.html#xP">P">PXBPPOV_source.html#xP">P(^(0),""^"",11))))"
P ;--Second Entry point
+1 WRITE IOSC
KILL FPL
+2 ;---DYNAMIC HEADER---
+3 IF '$DATA(CYCL)
Begin DoDot:1
+4 IF PXBCNT=0
IF DOUBLEQQ=0
DO LOC^PXBCC(1,10)
WRITE "...There are "_$GET(PXBCNT)_" ICD CODES associated with this encounter."
+5 IF PXBCNT=1
IF DOUBLEQQ=0
DO LOC^PXBCC(1,10)
WRITE "...There is "_$GET(PXBCNT)_" ICD CODE associated with this encounter."
+6 IF PXBCNT>1
IF DOUBLEQQ=0
DO LOC^PXBCC(1,10)
WRITE "...There are "_$GET(PXBCNT)_" ICD CODES associated with this encounter."
End DoDot:1
+7 ;
+8 DO LOC^PXBCC(15,0)
+9 IF PXBCNT>10&('$GET(DOUBLEQQ))
WRITE !,"Enter '+' for next page, '-' for previous page."
+10 IF '$DATA(^TMP("PXK",$JOB,"POV"))
WRITE !,"Enter Diagnosis : "_$GET(PXBDPOV)
IF $DATA(PXBDPOV)
WRITE " //"
WRITE IOELEOL
+11 IF $DATA(^TMP("PXK",$JOB,"POV"))
WRITE !,"Enter ",IOINHI,"NEXT",IOINLOW," Diagnosis : "_$GET(PXBDPOV)
IF $DATA(PXBDPOV)
WRITE " //"
WRITE IOELEOL
+12 READ DATA:DTIME
SET EDATA=DATA
P1 ;--Third entry point
+1 XECUTE TIMED
IF $TEST
SET PXBUT=1
SET LEAVE=1
SET DATA="^"
GOTO POVX
+2 IF DATA?1.N1"E".NAP
SET DATA=" "_DATA
+3 IF DATA?24.N
SET (DATA,EDATA)=$EXTRACT(DATA,1,24)
+4 IF $LENGTH(DATA)>200
SET (DATA,EDATA)=$EXTRACT(DATA,1,199)
+5 DO CASE^PXBUTL
+6 ;----SPACE BAR---
+7 IF DATA=" "
IF $DATA(^DISV(DUZ,"PXBPOV-3"))
SET DATA=^DISV(DUZ,"PXBPOV-3")
WRITE DATA
+8 ;-----------------
+9 IF DATA="^^"
SET PXBEXIT=0
GOTO POVX
+10 ;---I Prompt can jump to others put symbols in here
+11 IF DATA["^P"
GOTO POVX
+12 ;------PXBDPOV=DEFAULT POV---
+13 IF DATA=""
IF $DATA(PXBDPOV)
SET DATA=$PIECE($GET(PXBDPOV),"--",1)
+14 IF DATA=""
IF '$DATA(PXBDPOV)
SET PXBUT=1
SET PXBSPL=""
SET LEAVE=1
GOTO POVX
+15 ;
+16 IF PXBCNT>10&((DATA="+")!(DATA="-"))
DO DPOV4^PXBDPOV(DATA)
GOTO P
+17 ;
M ;--------IF Multiple entries have been entered
+1 DO ADDM^PXBPPOV1
+2 IF $GET(NF)
GOTO P1
+3 ;
+4 ;--------IF Multiple deleting of entries
+5 DO DELM^PXBPPOV1
+6 IF $GET(NF)
GOTO P1
+7 ;
LI ;--------If picked a line number
+1 IF (DATA>0)&(DATA<(PXBCNT+1))&($LENGTH(DATA)'>$LENGTH(PXBCNT))
SET XFLAG=1
DO REVPOV^PXBCC(DATA)
SET SELINE=DATA
Begin DoDot:1
+2 FOR I=1:1:$LENGTH(DATA)
WRITE IOCUB,IOECH
+3 SET PRISEC=$PIECE($GET(PXBSAM(DATA)),"^",4)
IF PRISEC["PRI"
SET FPRI=0
+4 SET DATA=$PIECE($GET(PXBSAM(DATA)),"^",1)
End DoDot:1
+5 IF $DATA(XFLAG)
IF XFLAG=1
SET (Y,EDATA)=DATA
GOTO PFIN
LI1 ;
+1 ;--------If POV is already in the file
+2 IF '$GET(DOUBLEQQ)
IF $DATA(PXBKY(DATA))
Begin DoDot:1
+3 IF PXBCNT>10
DO DPOV4^PXBDPOV($ORDER(PXBKY(DATA,0)))
+4 KILL Q
DO TIMES^PXBUTL(DATA)
+5 IF Q=1
SET LINE=$ORDER(PXBKY(DATA,0))
SET XFLAG=1
DO REVPOV^PXBCC(LINE)
SET PRISEC=$PIECE($GET(PXBSAM(LINE)),"^",2)
IF PRISEC["PRI"
SET FPRI=0
+6 IF Q>1
SET NLINE=0
FOR
SET NLINE=$ORDER(Q(NLINE))
IF NLINE=""
QUIT
DO REVPOV^PXBCC(NLINE)
End DoDot:1
+7 IF $DATA(Q)
IF Q>1
DO WHICH^PXBPWCH
GOTO LI
+8 IF $DATA(XFLAG)
IF XFLAG=1
SET Y=DATA
GOTO PFIN
+9 ;
+10 ;--------Need to do a DIC lookup on data
+11 IF DATA'="??"
IF DATA="?"
DO EN1^PXBHLP0("PXB","POV",1,"",1)
IF DATA="^P"
GOTO P1
IF DATA="?"
GOTO P
+12 IF DATA="??"
SET DOUBLEQQ=1
DO EN1^PXBHLP0("PXB","POV","",1,2)
IF $LENGTH(DATA,"^")>1
SET (Y,DATA,EDATA)=$PIECE($PIECE(DATA,"^",2),"--",1)
IF Y>1
GOTO PFIN
IF Y?1A1.NP
GOTO PFIN
IF DATA<1
SET DATA="^P"
GOTO P1
+13 ;
+14 ;--If a "?" is NOT entered during lookup
+15 SET (VAL,Y)=$$DOUBLE1^PXBGPOV2(WHAT)
IF Y<1
SET DATA="^P"
GOTO P1
+16 ;<-*92*-< S (X,DATA,EDATA)=$P(VAL,"^",2),DIC=80,DIC(0)="MZ" D ^DIC
+17 ;** PX*1.0*92 05/01/2001 make ^DIC selection "exact."
SET (DATA,EDATA)=$PIECE(VAL,"^",2)
SET X="`"_+$PIECE(Y,"^",1)
KILL Y
SET DIC=80
SET DIC(0)="MZ"
DO ^DIC
+18 ;
+19 ;--If Y is good and already in file...
+20 IF '$GET(DOUBLEQQ)
IF $DATA(Y)
IF $DATA(PXBKY($PIECE(Y,"^",2)))
Begin DoDot:1
+21 ;---D REVPOV^PXBCC(LINE)
SET LINE=$ORDER(PXBKY($PIECE(Y,"^",2),0))
+22 SET PRISEC=$PIECE($GET(PXBSAM(LINE)),"^",4)
IF PRISEC["PRI"
SET FPRI=0
End DoDot:1
+23 SET POV=Y(0)
+24 ;
PFIN ;--Finish the DIAGNOSIS
+1 IF $LENGTH(Y,"^")'>1
SET X=Y
SET DIC=80
SET DIC(0)="IZM"
DO ^DIC
+2 IF +Y<0
DO HELP1^PXBUTL1("POV")
GOTO P
+3 SET POV=Y(0)
+4 SET PXBNPOV($PIECE(POV,"^",1))=""
+5 SET PXBNPOVL(1)=$PIECE(POV,"^",1)
SET ^DISV(DUZ,"PXBPOV-3")=DATA
+6 IF $DATA(PXBKY($PIECE(Y(0),"^")))
IF $GET(SELINE)
SET $PIECE(REQI,"^",9)=$ORDER(PXBSKY(SELINE,0))
+7 IF $DATA(PXBKY($PIECE(Y(0),"^")))
IF '$GET(SELINE)
SET $PIECE(REQI,"^",9)=$ORDER(PXBSKY($ORDER(PXBKY($PIECE(Y(0),"^"),0)),0))
+8 IF +Y>0
SET PXBEDIS=$$EXTTEXT^PXUTL1(+Y,1,80,3)
+9 SET $PIECE(REQI,"^",5)=+Y
SET $PIECE(REQI,"^",6)="S"
+10 SET $PIECE(REQE,"^",5)=$PIECE(POV,"^",1)_" --"_$GET(PXBEDIS)
SET $PIECE(REQE,"^",6)="SECONDARY"
POVX ;--EXIT AND CLEAN UP
+1 IF $GET(WHAT)="INTV"
IF DATA="^"
SET PXBEXIT="^^"
+2 IF '$DATA(REQE)
SET REQE=""
+3 IF $PIECE(REQE,"^",5)=""
SET $PIECE(REQE,"^",5)="...No Diagnosis Selected..."
+4 QUIT
