- 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
