PXBGPOV2 ;ISL/JVS - DOUBLE ?? GATHERING OF DIAGNOSES ;27 Mar 2013 6:12 PM
;;1.0;PCE PATIENT CARE ENCOUNTER;**1,5,11,136,149,124,203,199**;Aug 12, 1996;Build 51
;
W !,"THIS IS NOT AN ENTRY POINT" Q
DOUBLE(FROM) ;--Entry point
; WHAT = The same WHAT as sent in from the API
; FROM = Exactly which prompt is asking for the list
; SCREEN = Same as the DIC("S") screen used by FileMan
; START = The starting point as to what to look up
;
N BACK,CODE,FIELD,FILE,FIRST,HEADING,NAME,NUM,PXACS,PXACSREC,PXDXDATE
N SCREEN,START,SUB,SUB2,TEMP,TITLE,VSTIEN
S VSTIEN=$S($D(PXBVST)=1:PXBVST,$D(VISIT)=1:VISIT,1:"")
S PXDXDATE=$$CSDATE^PXDXUTL(VSTIEN)
S PXACSREC=$$ACTDT^PXDXUTL(PXDXDATE),PXACS=$P(PXACSREC,U,3)
I PXACS["-" S PXACS=$P(PXACS,"-",1,2)
S BACK="",NUM=0,SCREEN=""
D LOC
; ICD9/ICD10 must be filtered out depending on PXDXDATE, so SCREEN must be defined
S SCREEN="I $P($$ICDDATA^ICDXCODE(""DIAG"",Y,PXDXDATE,$$IE^ICDEX(Y)),""^"",10)"
;
S START=$S($P(PXACSREC,"^",1)="ICD":"001.0 ",1:"A") ; start with A codes if ICD10
START ;--RECYCLE POINT
S TITLE="ALL DIAGNOSES ("_PXACS_" CODES)"
D SETUP
D LIST^DIC(FILE,"",FIELD,BACK,10,.START,"","BA",SCREEN,"","^TMP(""PXBTANA"",$J)","^TMP(""PXBTANA"",$J)")
D LOC,HEAD
D SETSECND ; SET UP DESCRIPTIONS TO GET AROUND FACT THAT THIS IS NOW A MULTIPLE FIELD IN FILE 80
D SUB
;
PROMPT ;---WRITE PROMPT HERE
D WIN17^PXBCC(PXBCNT),LOC^PXBCC(15,1)
W !!,"Enter '^' to quit, '-' for previous page."
S DIR("A")="Select a single 'ITEM NUMBER' or 'RETURN' to continue: "
S DIR("?")="Enter ITEM 'No' to select , '^' to quit, '-' for previous page."
S DIR(0)="N,A,O^0:10:0^I X'?.1""-"".1""^"".2N!(+X>10) K X"
D ^DIR
I X="-" S BACK="B" D BACK G START
I X="" S BACK="" D FORWARD G START
I $G(DIRUT) K DIRUT S VAL="^P" G EXIT
;
FINISH ;--FINISH SETTING A VARIABLE TO SELECTED ITEM
S VAL=$G(^TMP("PXBTANA",$J,"DILIST",2,X))_"^"_$G(^TMP("PXBTANA",$J,"DILIST","ID",X,FIRST))_"--"_$G(^TMP("PXBTANA",$J,"DILIST","ID",X,SECOND))
EXIT ;--EXIT
K DIR,^TMP("PXBTANA",$J),^TMP("PXBTOTAL",$J)
Q VAL
;
DOUBLE1(FROM) ;--Entry point
NEW ;
N CNT,CODE,CYCLE,FIELD,FILE,FIRST,HEADING,HLP,INDEX,NAME,OK,PXACS
N PXACSREC,PXDXDATE,SCREEN,START,SUB,SUB2,TITLE,TOTAL,VSTIEN
S VSTIEN=$S($D(PXBVST)=1:PXBVST,$D(VISIT)=1:VISIT,1:"")
S PXDXDATE=$$CSDATE^PXDXUTL(VSTIEN)
S PXACSREC=$$ACTDT^PXDXUTL(PXDXDATE),PXACS=$P(PXACSREC,U,3)
I PXACS["-" S PXACS=$P(PXACS,"-",1,2)
S BACK="",INDEX="BA"
S START=DATA,SUB=0,SUB2=0
S DIC("S")="I $P($$ICDDATA^ICDXCODE(""DIAG"",Y,PXDXDATE,$$IE^ICDEX(Y)),""^"",10)"
;
START1 ;--RECYCLE POINT
W !
S TITLE="- - S E L E C T E D D I A G N O S E S ("_PXACS_" CODES) - -"
S FILE=80,(FIELD,FIRST)=.01,SECOND="DxDesc",EDATA=DATA
I DATA?1N S START=DATA*100 S START=$O(^ICD9("BA",START_" ",-1)) S INDEX="BA"
I DATA?2N S START=DATA*10 S START=$O(^ICD9("BA",START_" ",-1)) S INDEX="BA"
I DATA?3.NP S (START)=DATA-(.99) S START=$O(^ICD9("BA",START_" ",-1)) S INDEX="BA"
I DATA?1A.ANP S START=$O(^ICD9("BA",START_" ",-1)) S INDEX="BA"
I DATA?2AP S HLP=1
I DATA?3.AP S START=$O(^ICD9("D",DATA),-1),INDEX="D"
I DATA?1A!(DATA?1.2N) D WAIT^DICD
;
D LIST^DIC(FILE,"",FIELD,BACK,"",.START,DATA,INDEX,DIC("S"),"","^TMP(""PXBTOTAL"",$J)","^TMP(""PXBTOTAL"",$J)")
D SETSECND
;
FILTER ;--FILTER OUT DUPLICATES
N I,DXINF,DXINFARR S I=0 F S I=$O(^TMP("PXBTOTAL",$J,"DILIST","ID",I)) Q:I="" D
.S DXINFARR=$$ICDDESC^ICDXCODE("DIAG",^TMP("PXBTOTAL",$J,"DILIST","ID",I,.01),PXDXDATE,.DXINFARR)
.S DXINF=$G(DXINFARR(1))
.I DXINF'="" S ^TMP("PXBOTAL",$J,$G(^TMP("PXBTOTAL",$J,"DILIST","ID",I,.01)),$E(DXINF,1,59)_" ",$G(^TMP("PXBTOTAL",$J,"DILIST",2,I))_" ")=""
K ^TMP("PXBTOTAL",$J)
N I,J,K,C S (I,J,K,C)="" F S I=$O(^TMP("PXBOTAL",$J,I)) Q:I="" D
.S C=C+1
.S J=$O(^TMP("PXBOTAL",$J,I,0))
.S K=$O(^TMP("PXBOTAL",$J,I,J,0))
.S ^TMP("PXBTOTAL",$J,"DILIST","ID",C,.01)=I
.S ^TMP("PXBTOTAL",$J,"DILIST","ID",C,"DxDesc")=J
.S ^TMP("PXBTOTAL",$J,"DILIST",2,C)=K
S ^TMP("PXBTOTAL",$J,"DILIST",0)=C
K ^TMP("PXBOTAL",$J)
;
S TOTAL=$P($G(^TMP("PXBTOTAL",$J,"DILIST",0)),"^",1)
;
;--DISPLAY IF NO MATCH FOUND
I TOTAL<1 D
.W IOEDEOP
.I '$G(HLP) W ! D HELP^PXBUTL0("CPTM")
.I $G(HLP) S RESULTS="USE AT LEAST THE 3 CHARACTERS" W !,IOCUU,?(IOM-$L(RESULTS))\2,RESULTS
.S ERROR=1,CYCL=1
I TOTAL<1 Q TOTAL
;
;----DISPLAY LIST TO THE SCREEN
S HEADING="W !,""ITEM"",?6,""CODE"",?16,""DESCRIPTION "",IOINHI,TOTAL,"" MATCHES"",IOINLOW"
LIST ;-DISPLAY LIST TO THE SCREEN
I TOTAL=1 S X=1 G VAL
D LOC,HEAD ; W !
;X HEADING
S SUB=SUB-1
S NUM=0 F S SUB=$O(^TMP("PXBTOTAL",$J,"DILIST","ID",SUB)) S NUM=NUM+1 Q:NUM=11 Q:SUB'>0 S SUB2=SUB2+1 D
.S CODE=$G(^TMP("PXBTOTAL",$J,"DILIST","ID",SUB,.01))
.S NAME=$E($G(^TMP("PXBTOTAL",$J,"DILIST","ID",SUB,"DxDesc")),1,62)
.W !,SUB,?6,CODE,?16,NAME
;
;----If There is only one selection go to proper prompting
I TOTAL=1 G PRMPT2
;
PRMPT ;---WRITE PROMPT HERE
D WIN17^PXBCC(PXBCNT)
D LOC^PXBCC(15,1)
W !
I SUB>0 W !,"Enter '^' to quit"
E I TOTAL>10 W !," END OF LIST"
I SUB>0 S DIR("A")="Select a single 'ITEM NUMBER' or 'RETURN' to continue: "
E S DIR("A")="Select a single 'ITEM NUMBER' or 'RETURN' to exit: "
S DIR("?")="Enter ITEM 'No' to select , '^' to quit"
S DIR(0)="N,A,O^0:"_SUB2_":0^I X'?.1""^"".N K X"
D ^DIR
I X="",SUB>0 G LIST
I X="",SUB'>0 S X="^"
VAL ;-----Set the VAL equal to the value
S VAL=$G(^TMP("PXBTOTAL",$J,"DILIST",2,X))_"^"_$G(^TMP("PXBTOTAL",$J,"DILIST","ID",X,.01))
EXITNEW ;--EXIT
K DIR,^TMP("PXBTANA",$J),^TMP("PXBTOTAL",$J)
K TANA,TOTAL
Q VAL
Q
;
;---SUBROUTINES
BACK ;
S START=$G(^TMP("PXBTANA",$J,"DILIST",1,1))
S START("IEN")=$G(^TMP("PXBTANA",$J,"DILIST",2,1))
Q
FORWARD ;
S START=$G(^TMP("PXBTANA",$J,"DILIST",1,10))
S START("IEN")=$G(^TMP("PXBTANA",$J,"DILIST",2,10))
Q
LOC ;--LOCATE CURSOR
D LOC^PXBCC(3,1) ;--LOCATE THE CURSOR
W IOEDEOP ;--CLEAR THE PAGE
Q
HEAD ;--HEAD
W !,IOCUU,IOBON,"HELP SCREEN",IOSGR0,?(IOM-$L(TITLE))\2,IOINHI,TITLE,IOINLOW,IOELEOL
Q
SUB ;--DISPLAY LIST TO THE SCREEN
I $P(^TMP("PXBTANA",$J,"DILIST",0),"^",1)=0 W !!," E N D O F L I S T" Q
X HEADING
S SUB=0,CNT=0 F S SUB=$O(^TMP("PXBTANA",$J,"DILIST","ID",SUB)) Q:SUB'>0 S CNT=CNT+1 D
.S CODE=$G(^TMP("PXBTANA",$J,"DILIST","ID",SUB,FIRST))
.S NAME=$E($G(^TMP("PXBTANA",$J,"DILIST","ID",SUB,SECOND)),1,62)
.W !,SUB,?6,CODE,?16,NAME
Q
SETUP ;-SETUP VARIABLES
S FILE=80,FIRST=.01,SECOND="DxDesc"
S FIELD=FIRST
S HEADING="W !,""ITEM"",?6,""CODE"",?16,""DESCRIPTION"""
Q
SETSECND ;
N NAMEARR
S SUB=0 F S SUB=$O(^TMP("PXBTANA",$J,"DILIST","ID",SUB)) Q:SUB'>0 D
. S CODE=$G(^TMP("PXBTANA",$J,"DILIST","ID",SUB,FIRST))
. S NAMEARR=$$ICDDESC^ICDXCODE("DIAG",CODE,PXDXDATE,.NAMEARR)
. S ^TMP("PXBTANA",$J,"DILIST","ID",SUB,SECOND)=$G(NAMEARR(1))
Q
;
PRMPT2 ;-----Yes and No prompt if only choice
D WIN17^PXBCC(PXBCNT)
D LOC^PXBCC(15,1)
S DIR("A")="Is this the correct entry "
S DIR("B")="YES"
S DIR(0)="Y"
D ^DIR
I Y=0 S X="^"
I Y=1 S X=1
G VAL
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXBGPOV2 7148 printed Oct 16, 2024@18:27:22 Page 2
PXBGPOV2 ;ISL/JVS - DOUBLE ?? GATHERING OF DIAGNOSES ;27 Mar 2013 6:12 PM
+1 ;;1.0;PCE PATIENT CARE ENCOUNTER;**1,5,11,136,149,124,203,199**;Aug 12, 1996;Build 51
+2 ;
+3 WRITE !,"THIS IS NOT AN ENTRY POINT"
QUIT
DOUBLE(FROM) ;--Entry point
+1 ; WHAT = The same WHAT as sent in from the API
+2 ; FROM = Exactly which prompt is asking for the list
+3 ; SCREEN = Same as the DIC("S") screen used by FileMan
+4 ; START = The starting point as to what to look up
+5 ;
+6 NEW BACK,CODE,FIELD,FILE,FIRST,HEADING,NAME,NUM,PXACS,PXACSREC,PXDXDATE
+7 NEW SCREEN,START,SUB,SUB2,TEMP,TITLE,VSTIEN
+8 SET VSTIEN=$SELECT($DATA(PXBVST)=1:PXBVST,$DATA(VISIT)=1:VISIT,1:"")
+9 SET PXDXDATE=$$CSDATE^PXDXUTL(VSTIEN)
+10 SET PXACSREC=$$ACTDT^PXDXUTL(PXDXDATE)
SET PXACS=$PIECE(PXACSREC,U,3)
+11 IF PXACS["-"
SET PXACS=$PIECE(PXACS,"-",1,2)
+12 SET BACK=""
SET NUM=0
SET SCREEN=""
+13 DO LOC
+14 ; ICD9/ICD10 must be filtered out depending on PXDXDATE, so SCREEN must be defined
+15 SET SCREEN="I $P($$ICDDATA^ICDXCODE(""DIAG"",Y,PXDXDATE,$$IE^ICDEX(Y)),""^"",10)"
+16 ;
+17 ; start with A codes if ICD10
SET START=$SELECT($PIECE(PXACSREC,"^",1)="ICD":"001.0 ",1:"A")
START ;--RECYCLE POINT
+1 SET TITLE="ALL DIAGNOSES ("_PXACS_" CODES)"
+2 DO SETUP
+3 DO LIST^DIC(FILE,"",FIELD,BACK,10,.START,"","BA",SCREEN,"","^TMP(""PXBTANA"",$J)","^TMP(""PXBTANA"",$J)")
+4 DO LOC
DO HEAD
+5 ; SET UP DESCRIPTIONS TO GET AROUND FACT THAT THIS IS NOW A MULTIPLE FIELD IN FILE 80
DO SETSECND
+6 DO SUB
+7 ;
PROMPT ;---WRITE PROMPT HERE
+1 DO WIN17^PXBCC(PXBCNT)
DO LOC^PXBCC(15,1)
+2 WRITE !!,"Enter '^' to quit, '-' for previous page."
+3 SET DIR("A")="Select a single 'ITEM NUMBER' or 'RETURN' to continue: "
+4 SET DIR("?")="Enter ITEM 'No' to select , '^' to quit, '-' for previous page."
+5 SET DIR(0)="N,A,O^0:10:0^I X'?.1""-"".1""^"".2N!(+X>10) K X"
+6 DO ^DIR
+7 IF X="-"
SET BACK="B"
DO BACK
GOTO START
+8 IF X=""
SET BACK=""
DO FORWARD
GOTO START
+9 IF $GET(DIRUT)
KILL DIRUT
SET VAL="^P"
GOTO EXIT
+10 ;
FINISH ;--FINISH SETTING A VARIABLE TO SELECTED ITEM
+1 SET VAL=$GET(^TMP("PXBTANA",$JOB,"DILIST",2,X))_"^"_$GET(^TMP("PXBTANA",$JOB,"DILIST","ID",X,FIRST))_"--"_$GET(^TMP("PXBTANA",$JOB,"DILIST","ID",X,SECOND))
EXIT ;--EXIT
+1 KILL DIR,^TMP("PXBTANA",$JOB),^TMP("PXBTOTAL",$JOB)
+2 QUIT VAL
+3 ;
DOUBLE1(FROM) ;--Entry point
NEW ;
+1 NEW CNT,CODE,CYCLE,FIELD,FILE,FIRST,HEADING,HLP,INDEX,NAME,OK,PXACS
+2 NEW PXACSREC,PXDXDATE,SCREEN,START,SUB,SUB2,TITLE,TOTAL,VSTIEN
+3 SET VSTIEN=$SELECT($DATA(PXBVST)=1:PXBVST,$DATA(VISIT)=1:VISIT,1:"")
+4 SET PXDXDATE=$$CSDATE^PXDXUTL(VSTIEN)
+5 SET PXACSREC=$$ACTDT^PXDXUTL(PXDXDATE)
SET PXACS=$PIECE(PXACSREC,U,3)
+6 IF PXACS["-"
SET PXACS=$PIECE(PXACS,"-",1,2)
+7 SET BACK=""
SET INDEX="BA"
+8 SET START=DATA
SET SUB=0
SET SUB2=0
+9 SET DIC("S")="I $P($$ICDDATA^ICDXCODE(""DIAG"",Y,PXDXDATE,$$IE^ICDEX(Y)),""^"",10)"
+10 ;
START1 ;--RECYCLE POINT
+1 WRITE !
+2 SET TITLE="- - S E L E C T E D D I A G N O S E S ("_PXACS_" CODES) - -"
+3 SET FILE=80
SET (FIELD,FIRST)=.01
SET SECOND="DxDesc"
SET EDATA=DATA
+4 IF DATA?1N
SET START=DATA*100
SET START=$ORDER(^ICD9("BA",START_" ",-1))
SET INDEX="BA"
+5 IF DATA?2N
SET START=DATA*10
SET START=$ORDER(^ICD9("BA",START_" ",-1))
SET INDEX="BA"
+6 IF DATA?3.NP
SET (START)=DATA-(.99)
SET START=$ORDER(^ICD9("BA",START_" ",-1))
SET INDEX="BA"
+7 IF DATA?1A.ANP
SET START=$ORDER(^ICD9("BA",START_" ",-1))
SET INDEX="BA"
+8 IF DATA?2AP
SET HLP=1
+9 IF DATA?3.AP
SET START=$ORDER(^ICD9("D",DATA),-1)
SET INDEX="D"
+10 IF DATA?1A!(DATA?1.2N)
DO WAIT^DICD
+11 ;
+12 DO LIST^DIC(FILE,"",FIELD,BACK,"",.START,DATA,INDEX,DIC("S"),"","^TMP(""PXBTOTAL"",$J)","^TMP(""PXBTOTAL"",$J)")
+13 DO SETSECND
+14 ;
FILTER ;--FILTER OUT DUPLICATES
+1 NEW I,DXINF,DXINFARR
SET I=0
FOR
SET I=$ORDER(^TMP("PXBTOTAL",$JOB,"DILIST","ID",I))
if I=""
QUIT
Begin DoDot:1
+2 SET DXINFARR=$$ICDDESC^ICDXCODE("DIAG",^TMP("PXBTOTAL",$JOB,"DILIST","ID",I,.01),PXDXDATE,.DXINFARR)
+3 SET DXINF=$GET(DXINFARR(1))
+4 IF DXINF'=""
SET ^TMP("PXBOTAL",$JOB,$GET(^TMP("PXBTOTAL",$JOB,"DILIST","ID",I,.01)),$EXTRACT(DXINF,1,59)_" ",$GET(^TMP("PXBTOTAL",$JOB,"DILIST",2,I))_" ")=""
End DoDot:1
+5 KILL ^TMP("PXBTOTAL",$JOB)
+6 NEW I,J,K,C
SET (I,J,K,C)=""
FOR
SET I=$ORDER(^TMP("PXBOTAL",$JOB,I))
if I=""
QUIT
Begin DoDot:1
+7 SET C=C+1
+8 SET J=$ORDER(^TMP("PXBOTAL",$JOB,I,0))
+9 SET K=$ORDER(^TMP("PXBOTAL",$JOB,I,J,0))
+10 SET ^TMP("PXBTOTAL",$JOB,"DILIST","ID",C,.01)=I
+11 SET ^TMP("PXBTOTAL",$JOB,"DILIST","ID",C,"DxDesc")=J
+12 SET ^TMP("PXBTOTAL",$JOB,"DILIST",2,C)=K
End DoDot:1
+13 SET ^TMP("PXBTOTAL",$JOB,"DILIST",0)=C
+14 KILL ^TMP("PXBOTAL",$JOB)
+15 ;
+16 SET TOTAL=$PIECE($GET(^TMP("PXBTOTAL",$JOB,"DILIST",0)),"^",1)
+17 ;
+18 ;--DISPLAY IF NO MATCH FOUND
+19 IF TOTAL<1
Begin DoDot:1
+20 WRITE IOEDEOP
+21 IF '$GET(HLP)
WRITE !
DO HELP^PXBUTL0("CPTM")
+22 IF $GET(HLP)
SET RESULTS="USE AT LEAST THE 3 CHARACTERS"
WRITE !,IOCUU,?(IOM-$LENGTH(RESULTS))\2,RESULTS
+23 SET ERROR=1
SET CYCL=1
End DoDot:1
+24 IF TOTAL<1
QUIT TOTAL
+25 ;
+26 ;----DISPLAY LIST TO THE SCREEN
+27 SET HEADING="W !,""ITEM"",?6,""CODE"",?16,""DESCRIPTION "",IOINHI,TOTAL,"" MATCHES"",IOINLOW"
LIST ;-DISPLAY LIST TO THE SCREEN
+1 IF TOTAL=1
SET X=1
GOTO VAL
+2 ; W !
DO LOC
DO HEAD
+3 ;X HEADING
+4 SET SUB=SUB-1
+5 SET NUM=0
FOR
SET SUB=$ORDER(^TMP("PXBTOTAL",$JOB,"DILIST","ID",SUB))
SET NUM=NUM+1
if NUM=11
QUIT
if SUB'>0
QUIT
SET SUB2=SUB2+1
Begin DoDot:1
+6 SET CODE=$GET(^TMP("PXBTOTAL",$JOB,"DILIST","ID",SUB,.01))
+7 SET NAME=$EXTRACT($GET(^TMP("PXBTOTAL",$JOB,"DILIST","ID",SUB,"DxDesc")),1,62)
+8 WRITE !,SUB,?6,CODE,?16,NAME
End DoDot:1
+9 ;
+10 ;----If There is only one selection go to proper prompting
+11 IF TOTAL=1
GOTO PRMPT2
+12 ;
PRMPT ;---WRITE PROMPT HERE
+1 DO WIN17^PXBCC(PXBCNT)
+2 DO LOC^PXBCC(15,1)
+3 WRITE !
+4 IF SUB>0
WRITE !,"Enter '^' to quit"
+5 IF '$TEST
IF TOTAL>10
WRITE !," END OF LIST"
+6 IF SUB>0
SET DIR("A")="Select a single 'ITEM NUMBER' or 'RETURN' to continue: "
+7 IF '$TEST
SET DIR("A")="Select a single 'ITEM NUMBER' or 'RETURN' to exit: "
+8 SET DIR("?")="Enter ITEM 'No' to select , '^' to quit"
+9 SET DIR(0)="N,A,O^0:"_SUB2_":0^I X'?.1""^"".N K X"
+10 DO ^DIR
+11 IF X=""
IF SUB>0
GOTO LIST
+12 IF X=""
IF SUB'>0
SET X="^"
VAL ;-----Set the VAL equal to the value
+1 SET VAL=$GET(^TMP("PXBTOTAL",$JOB,"DILIST",2,X))_"^"_$GET(^TMP("PXBTOTAL",$JOB,"DILIST","ID",X,.01))
EXITNEW ;--EXIT
+1 KILL DIR,^TMP("PXBTANA",$JOB),^TMP("PXBTOTAL",$JOB)
+2 KILL TANA,TOTAL
+3 QUIT VAL
+4 QUIT
+5 ;
+6 ;---SUBROUTINES
BACK ;
+1 SET START=$GET(^TMP("PXBTANA",$JOB,"DILIST",1,1))
+2 SET START("IEN")=$GET(^TMP("PXBTANA",$JOB,"DILIST",2,1))
+3 QUIT
FORWARD ;
+1 SET START=$GET(^TMP("PXBTANA",$JOB,"DILIST",1,10))
+2 SET START("IEN")=$GET(^TMP("PXBTANA",$JOB,"DILIST",2,10))
+3 QUIT
LOC ;--LOCATE CURSOR
+1 ;--LOCATE THE CURSOR
DO LOC^PXBCC(3,1)
+2 ;--CLEAR THE PAGE
WRITE IOEDEOP
+3 QUIT
HEAD ;--HEAD
+1 WRITE !,IOCUU,IOBON,"HELP SCREEN",IOSGR0,?(IOM-$LENGTH(TITLE))\2,IOINHI,TITLE,IOINLOW,IOELEOL
+2 QUIT
SUB ;--DISPLAY LIST TO THE SCREEN
+1 IF $PIECE(^TMP("PXBTANA",$JOB,"DILIST",0),"^",1)=0
WRITE !!," E N D O F L I S T"
QUIT
+2 XECUTE HEADING
+3 SET SUB=0
SET CNT=0
FOR
SET SUB=$ORDER(^TMP("PXBTANA",$JOB,"DILIST","ID",SUB))
if SUB'>0
QUIT
SET CNT=CNT+1
Begin DoDot:1
+4 SET CODE=$GET(^TMP("PXBTANA",$JOB,"DILIST","ID",SUB,FIRST))
+5 SET NAME=$EXTRACT($GET(^TMP("PXBTANA",$JOB,"DILIST","ID",SUB,SECOND)),1,62)
+6 WRITE !,SUB,?6,CODE,?16,NAME
End DoDot:1
+7 QUIT
SETUP ;-SETUP VARIABLES
+1 SET FILE=80
SET FIRST=.01
SET SECOND="DxDesc"
+2 SET FIELD=FIRST
+3 SET HEADING="W !,""ITEM"",?6,""CODE"",?16,""DESCRIPTION"""
+4 QUIT
SETSECND ;
+1 NEW NAMEARR
+2 SET SUB=0
FOR
SET SUB=$ORDER(^TMP("PXBTANA",$JOB,"DILIST","ID",SUB))
if SUB'>0
QUIT
Begin DoDot:1
+3 SET CODE=$GET(^TMP("PXBTANA",$JOB,"DILIST","ID",SUB,FIRST))
+4 SET NAMEARR=$$ICDDESC^ICDXCODE("DIAG",CODE,PXDXDATE,.NAMEARR)
+5 SET ^TMP("PXBTANA",$JOB,"DILIST","ID",SUB,SECOND)=$GET(NAMEARR(1))
End DoDot:1
+6 QUIT
+7 ;
PRMPT2 ;-----Yes and No prompt if only choice
+1 DO WIN17^PXBCC(PXBCNT)
+2 DO LOC^PXBCC(15,1)
+3 SET DIR("A")="Is this the correct entry "
+4 SET DIR("B")="YES"
+5 SET DIR(0)="Y"
+6 DO ^DIR
+7 IF Y=0
SET X="^"
+8 IF Y=1
SET X=1
+9 GOTO VAL
