PXBPPOV ;ISL/JVS - PROMPT POV ;24 Sep 2013 11:19 AM
;;1.0;PCE PATIENT CARE ENCOUNTER;**11,28,92,121,149,124,170,182,199**;Aug 12, 1996;Build 51
;
; VARIABLE LIST
; SELINE= Line number of selected item
;
POV ;--DIAGNOSIS
N PXACS,PXACSREC,PXDXDATE,PXICDDATA,PXICDROW
S PXICDROW=15
S PXDXDATE=$$CSDATE^PXDXUTL(PXBVST)
S PXACSREC=$$ACTDT^PXDXUTL(PXDXDATE),PXACS=$P(PXACSREC,U,3)
I PXACS["-" S PXACS=$P(PXACS,"-",1,2)
I $D(PXBNPOVL) D LOC^PXBCC(2,0) W IOUON,"Previous Entry: ",$G(PXBNPOVL(1)) F I=1:1:10 W " "
W IOUOFF
N CNT,DIC,EDATA,FPL,LINE,PXBEDIS,SELINE,TIMED,XFLAG
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($$ICDDATA^ICDXCODE(""DIAG"",Y,PXDXDATE,""E""),U,10)"
P ;--Second Entry point
W IOSC K FPL,EDATA,DATA
;---DYNAMIC HEADER---
I '$D(CYCL) D
.S CNT=+$O(PXBSAM(""),-1)
.I CNT=0,DOUBLEQQ=0 D LOC^PXBCC(1,10) W "...There are 0 ",PXACS," CODES associated with this encounter."
.I CNT=1,DOUBLEQQ=0 D LOC^PXBCC(1,10) W "...There is 1 ",PXACS," CODE associated with this encounter."
.I CNT>1,DOUBLEQQ=0 D LOC^PXBCC(1,10) W "...There are ",CNT," ",PXACS," CODES associated with this encounter."
D LOC^PXBCC(PXICDROW,0)
I PXBCNT>10&('$G(DOUBLEQQ)) W !,"Enter '+' for next page, '-' for previous page."
I '$D(^TMP("PXK",$J,"POV")) W !,"Enter ",PXACS," Diagnosis : ",$G(PXBDPOV) W:$D(PXBDPOV) " //" W IOELEOL
I $D(^TMP("PXK",$J,"POV")) W !,"Enter ",IOINHI,"NEXT",IOINLOW," ",PXACS," 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---PX*1.0*182 - added variable EDATA
I DATA="",$D(PXBDPOV) S DATA=$P($G(PXBDPOV),"--",1),EDATA=DATA
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))&($D(PXBSAM(DATA))) D:PXBCNT>10 DPOV4^PXBDPOV(PXBSAM(DATA,"LINE")) S XFLAG=1 D REVPOV(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(PXBSAM($O(PXBKY(DATA,0)),"LINE"))
.K Q D TIMES^PXBUTL(DATA)
.I Q=1 S LINE=$O(PXBKY(DATA,0)) S XFLAG=1 D REVPOV(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(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.ANP PFIN I DATA<1 S DATA="^P" G P1
;
;--If a "?" is NOT entered during lookup
D CLEAR^VALM1,FULL^VALM1 ; call to clear screen -- added in *199
W "Searching for diagnosis codes...",! ; added in *199
K X,DIC
S X=EDATA
S PXACSREC=$$ACTDT^PXDXUTL(PXDXDATE),PXACS=$P(PXACSREC,U,3)
I DATA="???",$P(PXACSREC,U,1)'="ICD" D G P1
. D CLEAR^VALM1 S PXPAUSE=1 D QM3^PXDSLK S DATA="^P"
I $P(PXACSREC,U,1)'="ICD" D
. S PXDATE=PXDXDATE,PXDEF=$G(X),PXAGAIN=0 D ^PXDSLK I PXXX=-1 S Y=-1 Q
. S Y($P(PXACSREC,U,2))=$P($P(PXXX,U,1),";",2)
. S Y=$P(PXXX,";",1)_U_$P(PXXX,U,2)
I $P(PXACSREC,U,1)="ICD" D
. K DIC D CONFIG^LEXSET($P(PXACSREC,U,1),,PXDXDATE)
. S DIC("A")="Select "_PXACS_" Diagnosis: "
. S DIC="^LEX(757.01,",DIC(0)=$S('$L(X):"A",1:"")_"EQM"
. D ^DIC
I $G(X)="@" Q
I Y=-1 S DATA="^P" G P1
S WHAT=$G(Y($P(PXACSREC,U,2)))
S (DATA,EDATA)=WHAT K Y
S PXICDDATA=$$ICDDATA^ICDXCODE("DIAG",WHAT,PXDXDATE,"E")
S Y=$S($P(PXICDDATA,U,10)=0:-1,1:$P(PXICDDATA,U,1,2))
S Y(0)=$P(PXICDDATA,U,2,99)
;
;--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",DIC("S")="I $P($$ICDDATA^ICDXCODE(""DIAG"",Y,PXDXDATE,$$IE^ICDEX(Y)),U,10)" D ^DIC
I +Y<0 D HELP1^PXBUTL1("POV") S PXICDROW=19 G P
S POV=Y(0)
;get the correct diagnosis descriptor
N DXINF S DXINF=$$ICDDATA^ICDXCODE("DIAG",+Y,PXDXDATE,"I"),$P(POV,U,3)=$P(DXINF,U,4)
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=$P(DXINF,U,4)
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..."
W !! S VALMBCK="R" ; added in *199 to improve display
Q
REVPOV(LINE) ;--NEW Reverse video API for POV since Long Descriptions are
; multiple lines
Q:$G(NOREV)=1
N ENTRY,XLINE,COL
S ENTRY=$G(PXBSAM(LINE)),XLINE=PXBSAM(LINE,"LINE")#11
S XLINE=XLINE+(PXBSAM(LINE,"LINE")\11)
S:XLINE=11 XLINE=1 S XLINE=XLINE+4
S COL=4
D LOC^PXBCC(XLINE,COL)
W IORVON,$J($P($P(ENTRY,"^",1),".",1),4),".",$P($P(ENTRY,"^",1),".",2),IORVOFF
D LOC^PXBCC(18,1)
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXBPPOV 6232 printed Apr 09, 2024@21:30:43 Page 2
PXBPPOV ;ISL/JVS - PROMPT POV ;24 Sep 2013 11:19 AM
+1 ;;1.0;PCE PATIENT CARE ENCOUNTER;**11,28,92,121,149,124,170,182,199**;Aug 12, 1996;Build 51
+2 ;
+3 ; VARIABLE LIST
+4 ; SELINE= Line number of selected item
+5 ;
POV ;--DIAGNOSIS
+1 NEW PXACS,PXACSREC,PXDXDATE,PXICDDATA,PXICDROW
+2 SET PXICDROW=15
+3 SET PXDXDATE=$$CSDATE^PXDXUTL(PXBVST)
+4 SET PXACSREC=$$ACTDT^PXDXUTL(PXDXDATE)
SET PXACS=$PIECE(PXACSREC,U,3)
+5 IF PXACS["-"
SET PXACS=$PIECE(PXACS,"-",1,2)
+6 IF $DATA(PXBNPOVL)
DO LOC^PXBCC(2,0)
WRITE IOUON,"Previous Entry: ",$GET(PXBNPOVL(1))
FOR I=1:1:10
WRITE " "
+7 WRITE IOUOFF
+8 NEW CNT,DIC,EDATA,FPL,LINE,PXBEDIS,SELINE,TIMED,XFLAG
+9 IF '$DATA(^DISV(DUZ,"PXBPOV-3"))
SET ^DISV(DUZ,"PXBPOV-3")=" "
+10 IF '$DATA(IOSC)
DO TERM^PXBCC
+11 SET DOUBLEQQ=0
+12 SET TIMED="I '$T!(DATA=""^"")"
+13 SET DIC("S")="I $P($$ICDDATA^ICDXCODE(""DIAG"",Y,PXDXDATE,""E""),U,10)"
P ;--Second Entry point
+1 WRITE IOSC
KILL FPL,EDATA,DATA
+2 ;---DYNAMIC HEADER---
+3 IF '$DATA(CYCL)
Begin DoDot:1
+4 SET CNT=+$ORDER(PXBSAM(""),-1)
+5 IF CNT=0
IF DOUBLEQQ=0
DO LOC^PXBCC(1,10)
WRITE "...There are 0 ",PXACS," CODES associated with this encounter."
+6 IF CNT=1
IF DOUBLEQQ=0
DO LOC^PXBCC(1,10)
WRITE "...There is 1 ",PXACS," CODE associated with this encounter."
+7 IF CNT>1
IF DOUBLEQQ=0
DO LOC^PXBCC(1,10)
WRITE "...There are ",CNT," ",PXACS," CODES associated with this encounter."
End DoDot:1
+8 DO LOC^PXBCC(PXICDROW,0)
+9 IF PXBCNT>10&('$GET(DOUBLEQQ))
WRITE !,"Enter '+' for next page, '-' for previous page."
+10 IF '$DATA(^TMP("PXK",$JOB,"POV"))
WRITE !,"Enter ",PXACS," Diagnosis : ",$GET(PXBDPOV)
if $DATA(PXBDPOV)
WRITE " //"
WRITE IOELEOL
+11 IF $DATA(^TMP("PXK",$JOB,"POV"))
WRITE !,"Enter ",IOINHI,"NEXT",IOINLOW," ",PXACS," 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---PX*1.0*182 - added variable EDATA
+13 IF DATA=""
IF $DATA(PXBDPOV)
SET DATA=$PIECE($GET(PXBDPOV),"--",1)
SET EDATA=DATA
+14 IF DATA=""
IF '$DATA(PXBDPOV)
SET PXBUT=1
SET PXBSPL=""
SET LEAVE=1
GOTO POVX
+15 IF PXBCNT>10&((DATA="+")!(DATA="-"))
DO DPOV4^PXBDPOV(DATA)
GOTO P
+16 ;
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))&($DATA(PXBSAM(DATA)))
if PXBCNT>10
DO DPOV4^PXBDPOV(PXBSAM(DATA,"LINE"))
SET XFLAG=1
DO REVPOV(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(PXBSAM($ORDER(PXBKY(DATA,0)),"LINE"))
+4 KILL Q
DO TIMES^PXBUTL(DATA)
+5 IF Q=1
SET LINE=$ORDER(PXBKY(DATA,0))
SET XFLAG=1
DO REVPOV(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(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.ANP
GOTO PFIN
IF DATA<1
SET DATA="^P"
GOTO P1
+13 ;
+14 ;--If a "?" is NOT entered during lookup
+15 ; call to clear screen -- added in *199
DO CLEAR^VALM1
DO FULL^VALM1
+16 ; added in *199
WRITE "Searching for diagnosis codes...",!
+17 KILL X,DIC
+18 SET X=EDATA
+19 SET PXACSREC=$$ACTDT^PXDXUTL(PXDXDATE)
SET PXACS=$PIECE(PXACSREC,U,3)
+20 IF DATA="???"
IF $PIECE(PXACSREC,U,1)'="ICD"
Begin DoDot:1
+21 DO CLEAR^VALM1
SET PXPAUSE=1
DO QM3^PXDSLK
SET DATA="^P"
End DoDot:1
GOTO P1
+22 IF $PIECE(PXACSREC,U,1)'="ICD"
Begin DoDot:1
+23 SET PXDATE=PXDXDATE
SET PXDEF=$GET(X)
SET PXAGAIN=0
DO ^PXDSLK
IF PXXX=-1
SET Y=-1
QUIT
+24 SET Y($PIECE(PXACSREC,U,2))=$PIECE($PIECE(PXXX,U,1),";",2)
+25 SET Y=$PIECE(PXXX,";",1)_U_$PIECE(PXXX,U,2)
End DoDot:1
+26 IF $PIECE(PXACSREC,U,1)="ICD"
Begin DoDot:1
+27 KILL DIC
DO CONFIG^LEXSET($PIECE(PXACSREC,U,1),,PXDXDATE)
+28 SET DIC("A")="Select "_PXACS_" Diagnosis: "
+29 SET DIC="^LEX(757.01,"
SET DIC(0)=$SELECT('$LENGTH(X):"A",1:"")_"EQM"
+30 DO ^DIC
End DoDot:1
+31 IF $GET(X)="@"
QUIT
+32 IF Y=-1
SET DATA="^P"
GOTO P1
+33 SET WHAT=$GET(Y($PIECE(PXACSREC,U,2)))
+34 SET (DATA,EDATA)=WHAT
KILL Y
+35 SET PXICDDATA=$$ICDDATA^ICDXCODE("DIAG",WHAT,PXDXDATE,"E")
+36 SET Y=$SELECT($PIECE(PXICDDATA,U,10)=0:-1,1:$PIECE(PXICDDATA,U,1,2))
+37 SET Y(0)=$PIECE(PXICDDATA,U,2,99)
+38 ;
+39 ;--If Y is good and already in file...
+40 IF '$GET(DOUBLEQQ)
IF $DATA(Y)
IF $DATA(PXBKY($PIECE(Y,"^",2)))
Begin DoDot:1
+41 ;---D REVPOV^PXBCC(LINE)
SET LINE=$ORDER(PXBKY($PIECE(Y,"^",2),0))
+42 SET PRISEC=$PIECE($GET(PXBSAM(LINE)),"^",4)
if PRISEC["PRI"
SET FPRI=0
End DoDot:1
+43 SET POV=Y(0)
+44 ;
PFIN ;--Finish the DIAGNOSIS
+1 IF $LENGTH(Y,"^")'>1
SET X=Y
SET DIC=80
SET DIC(0)="IZM"
SET DIC("S")="I $P($$ICDDATA^ICDXCODE(""DIAG"",Y,PXDXDATE,$$IE^ICDEX(Y)),U,10)"
DO ^DIC
+2 IF +Y<0
DO HELP1^PXBUTL1("POV")
SET PXICDROW=19
GOTO P
+3 SET POV=Y(0)
+4 ;get the correct diagnosis descriptor
+5 NEW DXINF
SET DXINF=$$ICDDATA^ICDXCODE("DIAG",+Y,PXDXDATE,"I")
SET $PIECE(POV,U,3)=$PIECE(DXINF,U,4)
+6 SET PXBNPOV($PIECE(POV,"^",1))=""
+7 SET PXBNPOVL(1)=$PIECE(POV,"^",1)
SET ^DISV(DUZ,"PXBPOV-3")=DATA
+8 IF $DATA(PXBKY($PIECE(Y(0),"^")))
IF $GET(SELINE)
SET $PIECE(REQI,"^",9)=$ORDER(PXBSKY(SELINE,0))
+9 IF $DATA(PXBKY($PIECE(Y(0),"^")))
IF '$GET(SELINE)
SET $PIECE(REQI,"^",9)=$ORDER(PXBSKY($ORDER(PXBKY($PIECE(Y(0),"^"),0)),0))
+10 IF +Y>0
SET PXBEDIS=$PIECE(DXINF,U,4)
+11 SET $PIECE(REQI,"^",5)=+Y
SET $PIECE(REQI,"^",6)="S"
+12 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 ; added in *199 to improve display
WRITE !!
SET VALMBCK="R"
+5 QUIT
REVPOV(LINE) ;--NEW Reverse video API for POV since Long Descriptions are
+1 ; multiple lines
+2 if $GET(NOREV)=1
QUIT
+3 NEW ENTRY,XLINE,COL
+4 SET ENTRY=$GET(PXBSAM(LINE))
SET XLINE=PXBSAM(LINE,"LINE")#11
+5 SET XLINE=XLINE+(PXBSAM(LINE,"LINE")\11)
+6 if XLINE=11
SET XLINE=1
SET XLINE=XLINE+4
+7 SET COL=4
+8 DO LOC^PXBCC(XLINE,COL)
+9 WRITE IORVON,$JUSTIFY($PIECE($PIECE(ENTRY,"^",1),".",1),4),".",$PIECE($PIECE(ENTRY,"^",1),".",2),IORVOFF
+10 DO LOC^PXBCC(18,1)
+11 QUIT
+12 ;
