PXBGCPT2 ;ISL/JVS,ESW - DOUBLE ?? GATHERING OF CPT CODES ; 10/31/02 12:05pm
;;1.0;PCE PATIENT CARE ENCOUNTER;**11,19,108,149,194,212**;Aug 12, 1996;Build 7
;
;
;
W !,"NOT" Q
;
DOUBLE(FROM) ;--Entry
;
N FILE,FIELD,TITLE,HEADING,SUB,CODE,NAME,START,SCREEN,BACK,NUM
N SCREEN,TEMP,FIRST
S BACK="",NUM=0,SCREEN=""
D LOC
I $D(DIC("S")) S SCREEN=DIC("S")
;
START ;
;
S TITLE="- - A L L P R O C E D U R E (CPT CODES) - -"
;
D SETUP
D LIST^DIC(FILE,"",FIELD,BACK,10,.START,"","",SCREEN,"","^TMP(""PXBTANA"",$J)","^TMP(""PXBTANA"",$J)")
;
D LOC,HEAD,SUB
;
PROMPT ;--PROMPT
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="^C" G EXIT
FINISH ;--FINISH
;
;S VAL=$G(^TMP("PXBTANA",$J,"DILIST",2,X))_U_$G(^TMP("PXBTANA",$J,"DILIST","ID",X,FIRST))_"--"_$G(^TMP("PXBTANA",$J,"DILIST","ID",X,SECOND))
S VAL=$G(^TMP("PXBTANA",$J,"DILIST",2,X))_U_$G(^TMP("PXBTANA",$J,"DILIST","ID",X,FIRST))_"--"_$P($$CPT^ICPTCOD($G(^TMP("PXBTANA",$J,"DILIST","ID",X,FIRST)),$G(IDATE)),U,3) ;PX212 - LLS replace line above
EXIT ;--EXIT
K DIR,^TMP("PXBTANA",$J),^TMP("PXBTOTAL",$J)
Q VAL
;
DOUBLE1(FROM) ;--Entry
;
NEW ;
N FILE,FIELD,TITLE,HEADING,SUB,CODE,NAME,START,SCREEN,CNT,OK,INDEX,CYCLE
N TOTAL,FIRST,SUB2
;---SETUP
S BACK="",INDEX=""
S START=DATA,SUB=0,SUB2=0
;
START1 ;--RECYCLE
S TITLE="- - S E L E C T E D P R O C E D U R E S (CPT CODES) - -"
S FILE=81
;S FIELD=".01;2"
S FIELD=".01" ;PX212 - LLS - removed [;2]
N TMP,LL,TT
S LL=$L(DATA),TT="0000"
I DATA?1.4N!(DATA?1A.3N) D
.S START=$O(^ICPT("B",DATA_$E(TT,1,5-LL)),-1)
I DATA?5N!(DATA?1A4N)!(DATA?4N1A) D
.S START=$O(^ICPT("B",START),-1)
XXX W IOCUOFF,IOCUF,IOCUF
N TMP
S SUBT=START,TOTAL=0 F S SUBT=$O(^ICPT("B",SUBT)) Q:SUBT'[DATA D
.I '$$CPTSCREN^PXBUTL($O(^ICPT("B",SUBT,0)),IDATE) Q
.S TOTAL=TOTAL+1 S PXBMOD=TOTAL#100 D WAIT^PXBUTL
.S ^TMP("PXBTOTAL",$J,"DILIST","ID",TOTAL,.01)=SUBT
.S ^TMP("PXBTOTAL",$J,"DILIST","ID",TOTAL,2)=$P($$CPT^ICPTCOD($O(^ICPT("B",SUBT,0)),IDATE),U,3)
.S TMP(SUBT)=""
I DATA?1.4N!(DATA?.3N1A) D
.S START=$O(^ICPT("B",$E(TT,1,5-LL)_DATA),-1)
.S SUBT=START F S SUBT=$O(^ICPT("B",SUBT)) Q:SUBT'[DATA D
..Q:$D(TMP(SUBT))
..I '$$CPTSCREN^PXBUTL($O(^ICPT("B",SUBT,0)),IDATE) Q
..S TOTAL=TOTAL+1 S PXBMOD=TOTAL#100 D WAIT^PXBUTL
..S ^TMP("PXBTOTAL",$J,"DILIST","ID",TOTAL,.01)=SUBT
..S ^TMP("PXBTOTAL",$J,"DILIST","ID",TOTAL,2)=$P($$CPT^ICPTCOD($O(^ICPT("B",SUBT,0)),IDATE),U,3)
W IOCUON
;
;
;
I DATA?2.A W IOCUOFF,IOCUF,IOCUF D
.N IEN,CODE,ARRAY,XX
.D FIND^DIC(81,"","","M",DATA,"","","","","ARRAY")
.I $D(ARRAY("DILIST"))<10 S Y=-1 Q
.S I=0 F S I=$O(ARRAY("DILIST",2,I)) Q:'I D
..S MIEN=ARRAY("DILIST",2,I),XX=$$CPT^ICPTCOD(MIEN,IDATE)
..Q:'$P(XX,U,7)
..S TOTAL=TOTAL+1 S PXBMOD=TOTAL#100 D WAIT^PXBUTL
..S ^TMP("PXBTOTAL",$J,"DILIST","ID",TOTAL,.01)=$P(XX,U,2)
..S ^TMP("PXBTOTAL",$J,"DILIST","ID",TOTAL,2)=DATA_", "_$P(XX,U,3)
W IOCUON
K SUBT
;
;
;
;--NO MATCH
I TOTAL=0 D
.I DATA?1A W ! D HELP^PXBUTL0("CPT4")
.I DATA'?1A W ! D HELP^PXBUTL0("CPTM")
.S ERROR=1,CYCL=1
I TOTAL=0 Q TOTAL
;
;--LIST
S HEADING="W !,""ITEM"",?6,""CODE"",?15,""DESCRIPTION "",IOINHI,TOTAL,"" MATCHES"",IOINLOW"
LIST ;-DISPLAY LIST TO THE SCREEN
I TOTAL=1 S X=1 G VAL
D LOC 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,2)),1,64)
.W !,SUB,?6,CODE,?15,NAME
;
;--one
I TOTAL=1 G PRMPT2
;
PRMPT ;--PROMPT
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 ;--VAL equal value
S VAL=$G(^TMP("PXBTOTAL",$J,"DILIST",2,X))_U_$G(^TMP("PXBTOTAL",$J,"DILIST","ID",X,.01))_"--"_$G(^TMP("PXBTOTAL",$J,"DILIST","ID",X,2))
EXITNEW ;--EXIT
K DIR,DIRUT,^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 ;--LIST
I $P(^TMP("PXBTANA",$J,"DILIST",0),U)=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=$G(^TMP("PXBTANA",$J,"DILIST","ID",SUB,SECOND))
.S NAME=$P($$CPT^ICPTCOD(CODE,$G(IDATE)),U,3) ;PX212 - LLS replaced line above
.W !,SUB,?6,CODE,?15,NAME
Q
SETUP ;--SET
S FILE=81,FIRST=.01,SECOND=2
S FIELD=FIRST ;_";"_SECOND ;PX212 - LLS - removed [_";"_SECOND]
S HEADING="W !,""ITEM"",?6,""CODE"",?15,""DESCRIPTION"""
Q
PRMPT2 ;--Yes and No prompt
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[HPXBGCPT2 5958 printed Nov 22, 2024@17:36:33 Page 2
PXBGCPT2 ;ISL/JVS,ESW - DOUBLE ?? GATHERING OF CPT CODES ; 10/31/02 12:05pm
+1 ;;1.0;PCE PATIENT CARE ENCOUNTER;**11,19,108,149,194,212**;Aug 12, 1996;Build 7
+2 ;
+3 ;
+4 ;
+5 WRITE !,"NOT"
QUIT
+6 ;
DOUBLE(FROM) ;--Entry
+1 ;
+2 NEW FILE,FIELD,TITLE,HEADING,SUB,CODE,NAME,START,SCREEN,BACK,NUM
+3 NEW SCREEN,TEMP,FIRST
+4 SET BACK=""
SET NUM=0
SET SCREEN=""
+5 DO LOC
+6 IF $DATA(DIC("S"))
SET SCREEN=DIC("S")
+7 ;
START ;
+1 ;
+2 SET TITLE="- - A L L P R O C E D U R E (CPT CODES) - -"
+3 ;
+4 DO SETUP
+5 DO LIST^DIC(FILE,"",FIELD,BACK,10,.START,"","",SCREEN,"","^TMP(""PXBTANA"",$J)","^TMP(""PXBTANA"",$J)")
+6 ;
+7 DO LOC
DO HEAD
DO SUB
+8 ;
PROMPT ;--PROMPT
+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="^C"
GOTO EXIT
FINISH ;--FINISH
+1 ;
+2 ;S VAL=$G(^TMP("PXBTANA",$J,"DILIST",2,X))_U_$G(^TMP("PXBTANA",$J,"DILIST","ID",X,FIRST))_"--"_$G(^TMP("PXBTANA",$J,"DILIST","ID",X,SECOND))
+3 ;PX212 - LLS replace line above
SET VAL=$GET(^TMP("PXBTANA",$JOB,"DILIST",2,X))_U_$GET(^TMP("PXBTANA",$JOB,"DILIST","ID",X,FIRST))_"--"_$PIECE($$CPT^ICPTCOD($GET(^TMP("PXBTANA",$JOB,"DILIST","ID",X,FIRST)),$GET(IDATE)),U,3)
EXIT ;--EXIT
+1 KILL DIR,^TMP("PXBTANA",$JOB),^TMP("PXBTOTAL",$JOB)
+2 QUIT VAL
+3 ;
DOUBLE1(FROM) ;--Entry
+1 ;
NEW ;
+1 NEW FILE,FIELD,TITLE,HEADING,SUB,CODE,NAME,START,SCREEN,CNT,OK,INDEX,CYCLE
+2 NEW TOTAL,FIRST,SUB2
+3 ;---SETUP
+4 SET BACK=""
SET INDEX=""
+5 SET START=DATA
SET SUB=0
SET SUB2=0
+6 ;
START1 ;--RECYCLE
+1 SET TITLE="- - S E L E C T E D P R O C E D U R E S (CPT CODES) - -"
+2 SET FILE=81
+3 ;S FIELD=".01;2"
+4 ;PX212 - LLS - removed [;2]
SET FIELD=".01"
+5 NEW TMP,LL,TT
+6 SET LL=$LENGTH(DATA)
SET TT="0000"
+7 IF DATA?1.4N!(DATA?1A.3N)
Begin DoDot:1
+8 SET START=$ORDER(^ICPT("B",DATA_$EXTRACT(TT,1,5-LL)),-1)
End DoDot:1
+9 IF DATA?5N!(DATA?1A4N)!(DATA?4N1A)
Begin DoDot:1
+10 SET START=$ORDER(^ICPT("B",START),-1)
End DoDot:1
XXX WRITE IOCUOFF,IOCUF,IOCUF
+1 NEW TMP
+2 SET SUBT=START
SET TOTAL=0
FOR
SET SUBT=$ORDER(^ICPT("B",SUBT))
if SUBT'[DATA
QUIT
Begin DoDot:1
+3 IF '$$CPTSCREN^PXBUTL($ORDER(^ICPT("B",SUBT,0)),IDATE)
QUIT
+4 SET TOTAL=TOTAL+1
SET PXBMOD=TOTAL#100
DO WAIT^PXBUTL
+5 SET ^TMP("PXBTOTAL",$JOB,"DILIST","ID",TOTAL,.01)=SUBT
+6 SET ^TMP("PXBTOTAL",$JOB,"DILIST","ID",TOTAL,2)=$PIECE($$CPT^ICPTCOD($ORDER(^ICPT("B",SUBT,0)),IDATE),U,3)
+7 SET TMP(SUBT)=""
End DoDot:1
+8 IF DATA?1.4N!(DATA?.3N1A)
Begin DoDot:1
+9 SET START=$ORDER(^ICPT("B",$EXTRACT(TT,1,5-LL)_DATA),-1)
+10 SET SUBT=START
FOR
SET SUBT=$ORDER(^ICPT("B",SUBT))
if SUBT'[DATA
QUIT
Begin DoDot:2
+11 if $DATA(TMP(SUBT))
QUIT
+12 IF '$$CPTSCREN^PXBUTL($ORDER(^ICPT("B",SUBT,0)),IDATE)
QUIT
+13 SET TOTAL=TOTAL+1
SET PXBMOD=TOTAL#100
DO WAIT^PXBUTL
+14 SET ^TMP("PXBTOTAL",$JOB,"DILIST","ID",TOTAL,.01)=SUBT
+15 SET ^TMP("PXBTOTAL",$JOB,"DILIST","ID",TOTAL,2)=$PIECE($$CPT^ICPTCOD($ORDER(^ICPT("B",SUBT,0)),IDATE),U,3)
End DoDot:2
End DoDot:1
+16 WRITE IOCUON
+17 ;
+18 ;
+19 ;
+20 IF DATA?2.A
WRITE IOCUOFF,IOCUF,IOCUF
Begin DoDot:1
+21 NEW IEN,CODE,ARRAY,XX
+22 DO FIND^DIC(81,"","","M",DATA,"","","","","ARRAY")
+23 IF $DATA(ARRAY("DILIST"))<10
SET Y=-1
QUIT
+24 SET I=0
FOR
SET I=$ORDER(ARRAY("DILIST",2,I))
if 'I
QUIT
Begin DoDot:2
+25 SET MIEN=ARRAY("DILIST",2,I)
SET XX=$$CPT^ICPTCOD(MIEN,IDATE)
+26 if '$PIECE(XX,U,7)
QUIT
+27 SET TOTAL=TOTAL+1
SET PXBMOD=TOTAL#100
DO WAIT^PXBUTL
+28 SET ^TMP("PXBTOTAL",$JOB,"DILIST","ID",TOTAL,.01)=$PIECE(XX,U,2)
+29 SET ^TMP("PXBTOTAL",$JOB,"DILIST","ID",TOTAL,2)=DATA_", "_$PIECE(XX,U,3)
End DoDot:2
End DoDot:1
+30 WRITE IOCUON
+31 KILL SUBT
+32 ;
+33 ;
+34 ;
+35 ;--NO MATCH
+36 IF TOTAL=0
Begin DoDot:1
+37 IF DATA?1A
WRITE !
DO HELP^PXBUTL0("CPT4")
+38 IF DATA'?1A
WRITE !
DO HELP^PXBUTL0("CPTM")
+39 SET ERROR=1
SET CYCL=1
End DoDot:1
+40 IF TOTAL=0
QUIT TOTAL
+41 ;
+42 ;--LIST
+43 SET HEADING="W !,""ITEM"",?6,""CODE"",?15,""DESCRIPTION "",IOINHI,TOTAL,"" MATCHES"",IOINLOW"
LIST ;-DISPLAY LIST TO THE SCREEN
+1 IF TOTAL=1
SET X=1
GOTO VAL
+2 DO LOC
WRITE !
+3 XECUTE 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,2)),1,64)
+8 WRITE !,SUB,?6,CODE,?15,NAME
End DoDot:1
+9 ;
+10 ;--one
+11 IF TOTAL=1
GOTO PRMPT2
+12 ;
PRMPT ;--PROMPT
+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 ;--VAL equal value
+1 SET VAL=$GET(^TMP("PXBTOTAL",$JOB,"DILIST",2,X))_U_$GET(^TMP("PXBTOTAL",$JOB,"DILIST","ID",X,.01))_"--"_$GET(^TMP("PXBTOTAL",$JOB,"DILIST","ID",X,2))
EXITNEW ;--EXIT
+1 KILL DIR,DIRUT,^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 ;--LIST
+1 IF $PIECE(^TMP("PXBTANA",$JOB,"DILIST",0),U)=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 ;S NAME=$G(^TMP("PXBTANA",$J,"DILIST","ID",SUB,SECOND))
+6 ;PX212 - LLS replaced line above
SET NAME=$PIECE($$CPT^ICPTCOD(CODE,$GET(IDATE)),U,3)
+7 WRITE !,SUB,?6,CODE,?15,NAME
End DoDot:1
+8 QUIT
SETUP ;--SET
+1 SET FILE=81
SET FIRST=.01
SET SECOND=2
+2 ;_";"_SECOND ;PX212 - LLS - removed [_";"_SECOND]
SET FIELD=FIRST
+3 SET HEADING="W !,""ITEM"",?6,""CODE"",?15,""DESCRIPTION"""
+4 QUIT
PRMPT2 ;--Yes and No prompt
+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
+10 ;
