PXBDCPT ;ISL/JVS,ESW - DISPLAY CPT ; Mar 24, 2022@23:05
;;1.0;PCE PATIENT CARE ENCOUNTER;**11,73,89,108,121,124,199,230**;Aug 12, 1996;Build 4
;
;
; Reference to CPT^ICPTCOD in ICR #1995
; Reference to LD^ICDEX in ICR #5747
;
;
EN0 ;---Main entry point
;
;
HEAD ;--HEADER ON LIST
S HEAD="- - E N C O U N T E R P R O C E D U R E S (CPT CODES) - -"
W IOINHI,!,IOCUU,?(IOM-$L(HEAD))\2,HEAD,IOINLOW
W IOELEOL K HEAD
;
I $D(CLINIC) D PRV^PXBUTL2(CLINIC)
;
;I PXBCNT<11 D DISCPT1^PXBDCPT
;I PXBCNT<21&(PXBCNT>10) D DISCPT2^PXBDCPT
;I PXBCNT>20&(PXBCNT<31) D DISCPT3^PXBDCPT
;I PXBCNT>30&('$D(PXBNCPT))
D DISCPT4^PXBDCPT("BEGIN")
;I PXBCNT>30&($D(PXBNCPT)) D DISCPT4^PXBDCPT("SAME")
Q
;
;
;
ARRAY ;Set all CPT codes and modifiers into ^TMP("PXBDCPT",$J,"DSP"
;for display
;
N PXASTRSK,PXCPTCD,PXCPTDA,PXCPTI,PXSQ,ENTRY,PXMD,PXDESC,PX124,PXC,PXD,PXDXDATE
S PXTMP="^TMP(""PXBDCPT"""_","_$J_","_"""DSP"")"
K @PXTMP
;PXBSAM is built by CPT^PXBGCPT which is called in HEADER^PXBMCPT2
;just before EN0^PXBDCPT is called.
S (PXTLNS,PXSQ)=0
F S PXSQ=$O(PXBSAM(PXSQ)) Q:'PXSQ D
.S PXTLNS=PXTLNS+1
.S ENTRY=PXBSAM(PXSQ)
.S PXBSAM(PXSQ,"LINE")=PXTLNS
.;The * is appended for codes added during the checkout interview.
.;The added codes are in PXBNCPT.
.S PXASTRSK=0
.I $D(PXBNCPT($P(ENTRY,U))) D
..;I PXBNCPT($P(ENTRY,U))]"",'$D(PXBSKY(PXSQ,PXBNCPT($P(ENTRY,U)))) Q
..Q:'$D(PXBNCPT($P(ENTRY,U),$O(PXBSKY(PXSQ,0))))
..;S $P(ENTRY,U)=$P(ENTRY,U)_"*"
..S PXASTRSK=1
.S PXCPTI=$P(ENTRY,U,1)
.S PXCPTDA=$$CPT^ICPTCOD(+PXCPTI)
.;The second piece of PXCPTDA is the code, unless something is wrong, then
.;it is the error description.
.S PXCPTCD=$P(PXCPTDA,U,2)
.;If PXASTRSK is true and there is no CPT code error, append *.
.I (PXASTRSK=1),($P(PXCPTDA,U,1)'=-1) S PXCPTCD=PXCPTCD_"*"
.;S @PXTMP@(PXTLNS,0)=PXSQ_U_$P(ENTRY,U)_U_$P(ENTRY,U,2)_U_$P(ENTRY,U,4)_U_$E($P(ENTRY,U,3),1,24)
.S @PXTMP@(PXTLNS,0)=PXSQ_U_PXCPTCD_U_$P(ENTRY,U,2)_U_$P(ENTRY,U,4)_U_$E($P(ENTRY,U,3),1,24)
.S PXMD=""
.F S PXMD=$O(PXBSAM(PXSQ,"MOD",PXMD)) Q:'PXMD D
..S PXTLNS=PXTLNS+1
..S PXMOD=PXBSAM(PXSQ,"MOD",PXMD)
..S PXDESC=$P($$MODP^ICPTMOD($E(ENTRY,1,5),PXMOD,"E",IDATE),U,2) ;PX*108
..S @PXTMP@(PXTLNS,0)=0_U_PXMOD_U_$E(PXDESC,1,54)
.S PXTLNS=PXTLNS+1
.S @PXTMP@(PXTLNS,0)="-22^"_$P(ENTRY,U,22)
.S PXDXDATE=$$CSDATE^PXDXUTL(PXBVST)
.F PX124=5:1:12 D
..S PXC=$P(ENTRY,U,PX124) Q:PXC=""
..S PXD=$$ICDDATA^ICDXCODE("DIAG",PXC,PXDXDATE,"E") Q:PXD<1
..I $P(PXD,U,20)'=30 D
...S PXC=PXC_" "_$P(PXD,U,4)
...S PXTLNS=PXTLNS+1,@PXTMP@(PXTLNS,0)=-PX124_U_PXC
..I $P(PXD,U,20)=30 D
...N PXENTRY S PXENTRY(1)=$$SENTENCE^XLFSTR($$LD^ICDEX(80,$P(PXD,U,1),PXDXDATE))
...D PR^PXSELDS(.PXENTRY,50)
...N PXLENGTH,PXLONG,PXSPACES S PXSPACES=" ",PXLENGTH=$L(PXC)-5
...I PXLENGTH>0 S PXSPACES=$E(PXSPACES,1,5-PXLENGTH)
...S PXLONG=PXC_PXSPACES_PXENTRY(1)
...S PXTLNS=PXTLNS+1,@PXTMP@(PXTLNS,0)=-PX124_U_PXLONG
...N PXNUMBR F PXNUMBR=2:1:PXENTRY D
....S PXTLNS=PXTLNS+1,@PXTMP@(PXTLNS,0)=-PX124_U_PXENTRY(PXNUMBR)_U_"NEXTLONG"
..I $G(PXBREQ(+PXD,"I"))="" S PXBREQ(+PXD,"I")=$P($$XLATE^PXBGPOV(PXBVST,+PXD),U,4,20)
..S PXTLNS=PXTLNS+1,@PXTMP@(PXTLNS,0)="I^"_PXBREQ(+PXD,"I")
Q
DISCPT1 ;--Display the CPT Data
;
N ENTRY,J
D UNDON^PXBCC
W !,"No.",?4,"CPT CODE",?14,"QUANTITY",?25,"DESCRIPTION",?55,"PROVIDER",?75,$C(32)
W IOEDEOP
D UNDOFF^PXBCC
;
S J=0
F S J=$O(PXBSAM(J)) Q:J="" D
.S ENTRY=$G(PXBSAM(J))
.I $D(PXBNCPT($P(ENTRY,U,1))) S $P(ENTRY,U,1)=$P(ENTRY,U,1)_"*"
.W !,J,?4,$P(ENTRY,U,1),?15,$P(ENTRY,U,2)
.W ?25,$P(ENTRY,U,4),?55,$E($P(ENTRY,U,3),1,24)
.;---Display associated modifiers
.S PXSIEN=""
.F S PXSIEN=$O(PXBSAM(J,"MOD",PXSIEN)) Q:PXSIEN="" D
..N PXWRAP,PXMOD,PXDESC,PXLN
..S PXMOD=PXBSAM(J,"MOD",PXSIEN)
..S PXDESC=$P($$MOD^ICPTMOD(PXMOD,"E",IDATE),U,3)
..D WRAP^PXCEVFI4(PXDESC,58,.PXWRAP)
..F PXLN=1:1 Q:$G(PXWRAP(PXLN))="" D
...W:PXLN=1 !,?4,"CPT Modifier: "_PXMOD
...W:PXLN>1 !
...W ?22,PXWRAP(PXLN)
;---Write no entries if none exist
I '$D(PXBSAM) D NONE^PXBUTL(2)
Q
;
DISCPT2 ;--display of cpt data two columns if more than 10 entries.
;
N ENTRY,J,PXA
D GSET^%ZISS
D UNDON^PXBCC W IOG1
W !,"NO",?4,"CPT",?10,"QUA",?14,"DESCRIPTION",?39,IOVL
W ?40,"NO",?44,"CPT",?50,"QUA",?54,"NARRATIVE"
W IOEDEOP
D UNDOFF^PXBCC
;
;
;
S J=0 F S J=$O(PXBSAM(J)) Q:J="" D
.S ENTRY(J)=$G(PXBSAM(J)) I $D(PXBNCPT($P(ENTRY(J),U,1))) S $P(ENTRY(J),U,1)=$P(ENTRY(J),U,1)_"*"
F J=1:1:10 D
.W !,J,?4,$P(ENTRY(J),U,1),?11,$P(ENTRY(J),U,2),?14,$E($P(ENTRY(J),U,4),1,24)
.D BAWRITE(ENTRY(J))
.I $D(ENTRY(J+10)) D
..W ?39,IOVL,(J+10),?44,$P(ENTRY(J+10),U,1),?51,$P(ENTRY(J+10),U,2),?54,$E($P(ENTRY(J+10),U,4),1,24)
..D BAWRITE(ENTRY(J))
W IOG0
Q
;
DISCPT3 ;--display of cpt data three columns if more than 20 entries.
N ENTRY,J,PXA
D GSET^%ZISS
D UNDON^PXBCC W IOG1
W !,"NO",?4,"CPT",?10,"QUA",?14,"NARRATIVE",?25,IOVL
W ?26,"NO",?30,"CPT",?36,"QUA",?40,"NARRATIVE",?51,IOVL
W ?52,"NO",?56,"CPT",?62,"QUA",?66,"NARRATIVE"
W IOEDEOP
D UNDOFF^PXBCC
;
S J=0 F S J=$O(PXBSAM(J)) Q:J="" D
.S ENTRY(J)=$G(PXBSAM(J)) I $D(PXBNCPT($P(ENTRY(J),U,1))) S $P(ENTRY(J),U,1)=$P(ENTRY(J),U,1)_"*"
F J=1:1:10 D
.W !,J,?4,$P(ENTRY(J),U,1),?11,$P(ENTRY(J),U,2),?14,$E($P(ENTRY(J),U,4),1,10)
.D BAWRITE(ENTRY(J))
.I $D(ENTRY(J+10)) D
..W ?25,IOVL,(J+10),?30,$P(ENTRY(J+10),U,1),?37,$P(ENTRY(J+10),U,2),?40,$E($P(ENTRY(J+10),U,4),1,10)
..D BAWRITE(ENTRY(J+10))
.I $D(ENTRY(J+20)) D
..W ?51,IOVL,(J+20),?56,$P(ENTRY(J+20),U,1),?63,$P(ENTRY(J+20),U,2),?66,$E($P(ENTRY(J+20),U,4),1,10)
..D BAWRITE(ENTRY(J+20))
W IOG0
Q
;
DISCPT4(SIGN) ;--Display the CPT Data
;
;SIGN=
; '+' add 10 to the starting point in ^TMP("PXBDCPT",$J)
; '-' subtract 10 from the starting point but not less than 0
; 'BEGIN' start at the beginning
; 'SAME' start stays where it's at
; '3'--any number set start to that number
;
N PXBSTART,PXTMP
D ARRAY
I SIGN="BEGIN" S ^TMP("PXBDCPT",$J,"START")=0,PXBSTART=0
I SIGN="SAME" S PXBSTART=^TMP("PXBDCPT",$J,"START")
I SIGN="+" D
.S PXBSTART=($G(^TMP("PXBDCPT",$J,"START"))+10)
.I PXBSTART'<PXTLNS S PXBSTART=PXBSTART-10
.S ^TMP("PXBDCPT",$J,"START")=PXBSTART
I SIGN="-" D
.S PXBSTART=$G(^TMP("PXBDCPT",$J,"START"))-10
.S ^TMP("PXBDCPT",$J,"START")=PXBSTART
.I PXBSTART<0 S PXBSTART=0 S ^TMP("PXBDCPT",$J,"START")=0
I +SIGN>0&(SIGN#10) D Q:^TMP("PXBDCPT",$J,"START")=PXBSTART S ^TMP("PXBDCPT",$J,"START")=PXBSTART
.S PXBSTART=$P((SIGN/10),".")*10
.S:PXBSTART<10 PXBSTART=0
I +SIGN>0&'(SIGN#10) D Q:^TMP("PXBDCPT",$J,"START")=PXBSTART S ^TMP("PXBDCPT",$J,"START")=PXBSTART
.S PXBSTART=(($P((SIGN/10),".")*10)-10)
.S:PXBSTART<10 PXBSTART=0
;
;
I SIGN'="BEGIN" D LOC^PXBCC(3,0) W IOEDEOP
;
HEAD4 ;--HEADER ON LIST
S HEAD="- - E N C O U N T E R P R O C E D U R E S (CPT CODES) - -"
W IOINHI,!,IOCUU,?(IOM-$L(HEAD))\2,HEAD,IOINLOW
W IOELEOL K HEAD
;
;
N ENTRY,J
D UNDON^PXBCC
W !,"No.",?4,"CPT CODE",?14,"QUANTITY",?25,"DESCRIPTION",?55,"PROVIDER",?75,$C(32)
W IOEDEOP
D UNDOFF^PXBCC
;
;
N PXSIEN,PXDESC,PXMOD,PXQ,PXLNS,PX,PL
S J=PXBSTART,PXQ=""
S PXLNS=0
F S J=$O(@PXTMP@(J)) Q:J="" D Q:PXQ
.S PXLNS=PXLNS+1
.I '(PXLNS#11) D Q
..S ^TMP("PXBDCPT",$J,"START")=PXBSTART
..S PXQ=1
.I +@PXTMP@(J,0)>0 D Q
..W !,$P(^(0),U),?4,$P(^(0),U,2),?15,$P(^(0),U,3)
..W ?25,$P(^(0),U,4),?55,$P(^(0),U,5)
.I +@PXTMP@(J,0)<0 D Q
..S PX=-$P(^(0),U,1)
..I PX=22 W !?4,"Ordering Provider: ",$P(^(0),U,2) Q
..I PX<20,$P(^(0),U,3)'="NEXTLONG" W !?4,"Diagnosis "_(PX-4)_": ",$P(^(0),U,2) Q
..I PX<20,$P(^(0),U,3)="NEXTLONG" W !?28,$P(^(0),U,2)
.I $P(@PXTMP@(J,0),U)="I" D CIA^PXBDPOV($P(^(0),U,2,16)) Q
.I $P(@PXTMP@(J,0),U)=0 D
..W !?4,"CPT Modifier: "_$P(^(0),U,2)_" "_$P(^(0),U,3)
I SIGN'="BEGIN" W !!
Q
;
BAWRITE(PXD) ;WRITE BA INFO
N PX,PD,PP
W !?4,"Ordering Provider: ",$P(PXD,U,22)
F PX=1:1:8 D
.S PD=$P(PXD,U,PX+5),PP=$$XLATE^PXBGPOV(PXBVST,PD)
.Q:'PD!'PP
.W:PD !?4,"Diagnosis: ",PD
.D CIA^PXBDPOV($P(PP,U,4,16))
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXBDCPT 8216 printed Dec 13, 2024@02:26:25 Page 2
PXBDCPT ;ISL/JVS,ESW - DISPLAY CPT ; Mar 24, 2022@23:05
+1 ;;1.0;PCE PATIENT CARE ENCOUNTER;**11,73,89,108,121,124,199,230**;Aug 12, 1996;Build 4
+2 ;
+3 ;
+4 ; Reference to CPT^ICPTCOD in ICR #1995
+5 ; Reference to LD^ICDEX in ICR #5747
+6 ;
+7 ;
EN0 ;---Main entry point
+1 ;
+2 ;
HEAD ;--HEADER ON LIST
+1 SET HEAD="- - E N C O U N T E R P R O C E D U R E S (CPT CODES) - -"
+2 WRITE IOINHI,!,IOCUU,?(IOM-$LENGTH(HEAD))\2,HEAD,IOINLOW
+3 WRITE IOELEOL
KILL HEAD
+4 ;
+5 IF $DATA(CLINIC)
DO PRV^PXBUTL2(CLINIC)
+6 ;
+7 ;I PXBCNT<11 D DISCPT1^PXBDCPT
+8 ;I PXBCNT<21&(PXBCNT>10) D DISCPT2^PXBDCPT
+9 ;I PXBCNT>20&(PXBCNT<31) D DISCPT3^PXBDCPT
+10 ;I PXBCNT>30&('$D(PXBNCPT))
+11 DO DISCPT4^PXBDCPT("BEGIN")
+12 ;I PXBCNT>30&($D(PXBNCPT)) D DISCPT4^PXBDCPT("SAME")
+13 QUIT
+14 ;
+15 ;
+16 ;
ARRAY ;Set all CPT codes and modifiers into ^TMP("PXBDCPT",$J,"DSP"
+1 ;for display
+2 ;
+3 NEW PXASTRSK,PXCPTCD,PXCPTDA,PXCPTI,PXSQ,ENTRY,PXMD,PXDESC,PX124,PXC,PXD,PXDXDATE
+4 SET PXTMP="^TMP(""PXBDCPT"""_","_$JOB_","_"""DSP"")"
+5 KILL @PXTMP
+6 ;PXBSAM is built by CPT^PXBGCPT which is called in HEADER^PXBMCPT2
+7 ;just before EN0^PXBDCPT is called.
+8 SET (PXTLNS,PXSQ)=0
+9 FOR
SET PXSQ=$ORDER(PXBSAM(PXSQ))
if 'PXSQ
QUIT
Begin DoDot:1
+10 SET PXTLNS=PXTLNS+1
+11 SET ENTRY=PXBSAM(PXSQ)
+12 SET PXBSAM(PXSQ,"LINE")=PXTLNS
+13 ;The * is appended for codes added during the checkout interview.
+14 ;The added codes are in PXBNCPT.
+15 SET PXASTRSK=0
+16 IF $DATA(PXBNCPT($PIECE(ENTRY,U)))
Begin DoDot:2
+17 ;I PXBNCPT($P(ENTRY,U))]"",'$D(PXBSKY(PXSQ,PXBNCPT($P(ENTRY,U)))) Q
+18 if '$DATA(PXBNCPT($PIECE(ENTRY,U),$ORDER(PXBSKY(PXSQ,0))))
QUIT
+19 ;S $P(ENTRY,U)=$P(ENTRY,U)_"*"
+20 SET PXASTRSK=1
End DoDot:2
+21 SET PXCPTI=$PIECE(ENTRY,U,1)
+22 SET PXCPTDA=$$CPT^ICPTCOD(+PXCPTI)
+23 ;The second piece of PXCPTDA is the code, unless something is wrong, then
+24 ;it is the error description.
+25 SET PXCPTCD=$PIECE(PXCPTDA,U,2)
+26 ;If PXASTRSK is true and there is no CPT code error, append *.
+27 IF (PXASTRSK=1)
IF ($PIECE(PXCPTDA,U,1)'=-1)
SET PXCPTCD=PXCPTCD_"*"
+28 ;S @PXTMP@(PXTLNS,0)=PXSQ_U_$P(ENTRY,U)_U_$P(ENTRY,U,2)_U_$P(ENTRY,U,4)_U_$E($P(ENTRY,U,3),1,24)
+29 SET @PXTMP@(PXTLNS,0)=PXSQ_U_PXCPTCD_U_$PIECE(ENTRY,U,2)_U_$PIECE(ENTRY,U,4)_U_$EXTRACT($PIECE(ENTRY,U,3),1,24)
+30 SET PXMD=""
+31 FOR
SET PXMD=$ORDER(PXBSAM(PXSQ,"MOD",PXMD))
if 'PXMD
QUIT
Begin DoDot:2
+32 SET PXTLNS=PXTLNS+1
+33 SET PXMOD=PXBSAM(PXSQ,"MOD",PXMD)
+34 ;PX*108
SET PXDESC=$PIECE($$MODP^ICPTMOD($EXTRACT(ENTRY,1,5),PXMOD,"E",IDATE),U,2)
+35 SET @PXTMP@(PXTLNS,0)=0_U_PXMOD_U_$EXTRACT(PXDESC,1,54)
End DoDot:2
+36 SET PXTLNS=PXTLNS+1
+37 SET @PXTMP@(PXTLNS,0)="-22^"_$PIECE(ENTRY,U,22)
+38 SET PXDXDATE=$$CSDATE^PXDXUTL(PXBVST)
+39 FOR PX124=5:1:12
Begin DoDot:2
+40 SET PXC=$PIECE(ENTRY,U,PX124)
if PXC=""
QUIT
+41 SET PXD=$$ICDDATA^ICDXCODE("DIAG",PXC,PXDXDATE,"E")
if PXD<1
QUIT
+42 IF $PIECE(PXD,U,20)'=30
Begin DoDot:3
+43 SET PXC=PXC_" "_$PIECE(PXD,U,4)
+44 SET PXTLNS=PXTLNS+1
SET @PXTMP@(PXTLNS,0)=-PX124_U_PXC
End DoDot:3
+45 IF $PIECE(PXD,U,20)=30
Begin DoDot:3
+46 NEW PXENTRY
SET PXENTRY(1)=$$SENTENCE^XLFSTR($$LD^ICDEX(80,$PIECE(PXD,U,1),PXDXDATE))
+47 DO PR^PXSELDS(.PXENTRY,50)
+48 NEW PXLENGTH,PXLONG,PXSPACES
SET PXSPACES=" "
SET PXLENGTH=$LENGTH(PXC)-5
+49 IF PXLENGTH>0
SET PXSPACES=$EXTRACT(PXSPACES,1,5-PXLENGTH)
+50 SET PXLONG=PXC_PXSPACES_PXENTRY(1)
+51 SET PXTLNS=PXTLNS+1
SET @PXTMP@(PXTLNS,0)=-PX124_U_PXLONG
+52 NEW PXNUMBR
FOR PXNUMBR=2:1:PXENTRY
Begin DoDot:4
+53 SET PXTLNS=PXTLNS+1
SET @PXTMP@(PXTLNS,0)=-PX124_U_PXENTRY(PXNUMBR)_U_"NEXTLONG"
End DoDot:4
End DoDot:3
+54 IF $GET(PXBREQ(+PXD,"I"))=""
SET PXBREQ(+PXD,"I")=$PIECE($$XLATE^PXBGPOV(PXBVST,+PXD),U,4,20)
+55 SET PXTLNS=PXTLNS+1
SET @PXTMP@(PXTLNS,0)="I^"_PXBREQ(+PXD,"I")
End DoDot:2
End DoDot:1
+56 QUIT
DISCPT1 ;--Display the CPT Data
+1 ;
+2 NEW ENTRY,J
+3 DO UNDON^PXBCC
+4 WRITE !,"No.",?4,"CPT CODE",?14,"QUANTITY",?25,"DESCRIPTION",?55,"PROVIDER",?75,$CHAR(32)
+5 WRITE IOEDEOP
+6 DO UNDOFF^PXBCC
+7 ;
+8 SET J=0
+9 FOR
SET J=$ORDER(PXBSAM(J))
if J=""
QUIT
Begin DoDot:1
+10 SET ENTRY=$GET(PXBSAM(J))
+11 IF $DATA(PXBNCPT($PIECE(ENTRY,U,1)))
SET $PIECE(ENTRY,U,1)=$PIECE(ENTRY,U,1)_"*"
+12 WRITE !,J,?4,$PIECE(ENTRY,U,1),?15,$PIECE(ENTRY,U,2)
+13 WRITE ?25,$PIECE(ENTRY,U,4),?55,$EXTRACT($PIECE(ENTRY,U,3),1,24)
+14 ;---Display associated modifiers
+15 SET PXSIEN=""
+16 FOR
SET PXSIEN=$ORDER(PXBSAM(J,"MOD",PXSIEN))
if PXSIEN=""
QUIT
Begin DoDot:2
+17 NEW PXWRAP,PXMOD,PXDESC,PXLN
+18 SET PXMOD=PXBSAM(J,"MOD",PXSIEN)
+19 SET PXDESC=$PIECE($$MOD^ICPTMOD(PXMOD,"E",IDATE),U,3)
+20 DO WRAP^PXCEVFI4(PXDESC,58,.PXWRAP)
+21 FOR PXLN=1:1
if $GET(PXWRAP(PXLN))=""
QUIT
Begin DoDot:3
+22 if PXLN=1
WRITE !,?4,"CPT Modifier: "_PXMOD
+23 if PXLN>1
WRITE !
+24 WRITE ?22,PXWRAP(PXLN)
End DoDot:3
End DoDot:2
End DoDot:1
+25 ;---Write no entries if none exist
+26 IF '$DATA(PXBSAM)
DO NONE^PXBUTL(2)
+27 QUIT
+28 ;
DISCPT2 ;--display of cpt data two columns if more than 10 entries.
+1 ;
+2 NEW ENTRY,J,PXA
+3 DO GSET^%ZISS
+4 DO UNDON^PXBCC
WRITE IOG1
+5 WRITE !,"NO",?4,"CPT",?10,"QUA",?14,"DESCRIPTION",?39,IOVL
+6 WRITE ?40,"NO",?44,"CPT",?50,"QUA",?54,"NARRATIVE"
+7 WRITE IOEDEOP
+8 DO UNDOFF^PXBCC
+9 ;
+10 ;
+11 ;
+12 SET J=0
FOR
SET J=$ORDER(PXBSAM(J))
if J=""
QUIT
Begin DoDot:1
+13 SET ENTRY(J)=$GET(PXBSAM(J))
IF $DATA(PXBNCPT($PIECE(ENTRY(J),U,1)))
SET $PIECE(ENTRY(J),U,1)=$PIECE(ENTRY(J),U,1)_"*"
End DoDot:1
+14 FOR J=1:1:10
Begin DoDot:1
+15 WRITE !,J,?4,$PIECE(ENTRY(J),U,1),?11,$PIECE(ENTRY(J),U,2),?14,$EXTRACT($PIECE(ENTRY(J),U,4),1,24)
+16 DO BAWRITE(ENTRY(J))
+17 IF $DATA(ENTRY(J+10))
Begin DoDot:2
+18 WRITE ?39,IOVL,(J+10),?44,$PIECE(ENTRY(J+10),U,1),?51,$PIECE(ENTRY(J+10),U,2),?54,$EXTRACT($PIECE(ENTRY(J+10),U,4),1,24)
+19 DO BAWRITE(ENTRY(J))
End DoDot:2
End DoDot:1
+20 WRITE IOG0
+21 QUIT
+22 ;
DISCPT3 ;--display of cpt data three columns if more than 20 entries.
+1 NEW ENTRY,J,PXA
+2 DO GSET^%ZISS
+3 DO UNDON^PXBCC
WRITE IOG1
+4 WRITE !,"NO",?4,"CPT",?10,"QUA",?14,"NARRATIVE",?25,IOVL
+5 WRITE ?26,"NO",?30,"CPT",?36,"QUA",?40,"NARRATIVE",?51,IOVL
+6 WRITE ?52,"NO",?56,"CPT",?62,"QUA",?66,"NARRATIVE"
+7 WRITE IOEDEOP
+8 DO UNDOFF^PXBCC
+9 ;
+10 SET J=0
FOR
SET J=$ORDER(PXBSAM(J))
if J=""
QUIT
Begin DoDot:1
+11 SET ENTRY(J)=$GET(PXBSAM(J))
IF $DATA(PXBNCPT($PIECE(ENTRY(J),U,1)))
SET $PIECE(ENTRY(J),U,1)=$PIECE(ENTRY(J),U,1)_"*"
End DoDot:1
+12 FOR J=1:1:10
Begin DoDot:1
+13 WRITE !,J,?4,$PIECE(ENTRY(J),U,1),?11,$PIECE(ENTRY(J),U,2),?14,$EXTRACT($PIECE(ENTRY(J),U,4),1,10)
+14 DO BAWRITE(ENTRY(J))
+15 IF $DATA(ENTRY(J+10))
Begin DoDot:2
+16 WRITE ?25,IOVL,(J+10),?30,$PIECE(ENTRY(J+10),U,1),?37,$PIECE(ENTRY(J+10),U,2),?40,$EXTRACT($PIECE(ENTRY(J+10),U,4),1,10)
+17 DO BAWRITE(ENTRY(J+10))
End DoDot:2
+18 IF $DATA(ENTRY(J+20))
Begin DoDot:2
+19 WRITE ?51,IOVL,(J+20),?56,$PIECE(ENTRY(J+20),U,1),?63,$PIECE(ENTRY(J+20),U,2),?66,$EXTRACT($PIECE(ENTRY(J+20),U,4),1,10)
+20 DO BAWRITE(ENTRY(J+20))
End DoDot:2
End DoDot:1
+21 WRITE IOG0
+22 QUIT
+23 ;
DISCPT4(SIGN) ;--Display the CPT Data
+1 ;
+2 ;SIGN=
+3 ; '+' add 10 to the starting point in ^TMP("PXBDCPT",$J)
+4 ; '-' subtract 10 from the starting point but not less than 0
+5 ; 'BEGIN' start at the beginning
+6 ; 'SAME' start stays where it's at
+7 ; '3'--any number set start to that number
+8 ;
+9 NEW PXBSTART,PXTMP
+10 DO ARRAY
+11 IF SIGN="BEGIN"
SET ^TMP("PXBDCPT",$JOB,"START")=0
SET PXBSTART=0
+12 IF SIGN="SAME"
SET PXBSTART=^TMP("PXBDCPT",$JOB,"START")
+13 IF SIGN="+"
Begin DoDot:1
+14 SET PXBSTART=($GET(^TMP("PXBDCPT",$JOB,"START"))+10)
+15 IF PXBSTART'<PXTLNS
SET PXBSTART=PXBSTART-10
+16 SET ^TMP("PXBDCPT",$JOB,"START")=PXBSTART
End DoDot:1
+17 IF SIGN="-"
Begin DoDot:1
+18 SET PXBSTART=$GET(^TMP("PXBDCPT",$JOB,"START"))-10
+19 SET ^TMP("PXBDCPT",$JOB,"START")=PXBSTART
+20 IF PXBSTART<0
SET PXBSTART=0
SET ^TMP("PXBDCPT",$JOB,"START")=0
End DoDot:1
+21 IF +SIGN>0&(SIGN#10)
Begin DoDot:1
+22 SET PXBSTART=$PIECE((SIGN/10),".")*10
+23 if PXBSTART<10
SET PXBSTART=0
End DoDot:1
if ^TMP("PXBDCPT",$JOB,"START")=PXBSTART
QUIT
SET ^TMP("PXBDCPT",$JOB,"START")=PXBSTART
+24 IF +SIGN>0&'(SIGN#10)
Begin DoDot:1
+25 SET PXBSTART=(($PIECE((SIGN/10),".")*10)-10)
+26 if PXBSTART<10
SET PXBSTART=0
End DoDot:1
if ^TMP("PXBDCPT",$JOB,"START")=PXBSTART
QUIT
SET ^TMP("PXBDCPT",$JOB,"START")=PXBSTART
+27 ;
+28 ;
+29 IF SIGN'="BEGIN"
DO LOC^PXBCC(3,0)
WRITE IOEDEOP
+30 ;
HEAD4 ;--HEADER ON LIST
+1 SET HEAD="- - E N C O U N T E R P R O C E D U R E S (CPT CODES) - -"
+2 WRITE IOINHI,!,IOCUU,?(IOM-$LENGTH(HEAD))\2,HEAD,IOINLOW
+3 WRITE IOELEOL
KILL HEAD
+4 ;
+5 ;
+6 NEW ENTRY,J
+7 DO UNDON^PXBCC
+8 WRITE !,"No.",?4,"CPT CODE",?14,"QUANTITY",?25,"DESCRIPTION",?55,"PROVIDER",?75,$CHAR(32)
+9 WRITE IOEDEOP
+10 DO UNDOFF^PXBCC
+11 ;
+12 ;
+13 NEW PXSIEN,PXDESC,PXMOD,PXQ,PXLNS,PX,PL
+14 SET J=PXBSTART
SET PXQ=""
+15 SET PXLNS=0
+16 FOR
SET J=$ORDER(@PXTMP@(J))
if J=""
QUIT
Begin DoDot:1
+17 SET PXLNS=PXLNS+1
+18 IF '(PXLNS#11)
Begin DoDot:2
+19 SET ^TMP("PXBDCPT",$JOB,"START")=PXBSTART
+20 SET PXQ=1
End DoDot:2
QUIT
+21 IF +@PXTMP@(J,0)>0
Begin DoDot:2
+22 WRITE !,$PIECE(^(0),U),?4,$PIECE(^(0),U,2),?15,$PIECE(^(0),U,3)
+23 WRITE ?25,$PIECE(^(0),U,4),?55,$PIECE(^(0),U,5)
End DoDot:2
QUIT
+24 IF +@PXTMP@(J,0)<0
Begin DoDot:2
+25 SET PX=-$PIECE(^(0),U,1)
+26 IF PX=22
WRITE !?4,"Ordering Provider: ",$PIECE(^(0),U,2)
QUIT
+27 IF PX<20
IF $PIECE(^(0),U,3)'="NEXTLONG"
WRITE !?4,"Diagnosis "_(PX-4)_": ",$PIECE(^(0),U,2)
QUIT
+28 IF PX<20
IF $PIECE(^(0),U,3)="NEXTLONG"
WRITE !?28,$PIECE(^(0),U,2)
End DoDot:2
QUIT
+29 IF $PIECE(@PXTMP@(J,0),U)="I"
DO CIA^PXBDPOV($PIECE(^(0),U,2,16))
QUIT
+30 IF $PIECE(@PXTMP@(J,0),U)=0
Begin DoDot:2
+31 WRITE !?4,"CPT Modifier: "_$PIECE(^(0),U,2)_" "_$PIECE(^(0),U,3)
End DoDot:2
End DoDot:1
if PXQ
QUIT
+32 IF SIGN'="BEGIN"
WRITE !!
+33 QUIT
+34 ;
BAWRITE(PXD) ;WRITE BA INFO
+1 NEW PX,PD,PP
+2 WRITE !?4,"Ordering Provider: ",$PIECE(PXD,U,22)
+3 FOR PX=1:1:8
Begin DoDot:1
+4 SET PD=$PIECE(PXD,U,PX+5)
SET PP=$$XLATE^PXBGPOV(PXBVST,PD)
+5 if 'PD!'PP
QUIT
+6 if PD
WRITE !?4,"Diagnosis: ",PD
+7 DO CIA^PXBDPOV($PIECE(PP,U,4,16))
End DoDot:1
+8 QUIT
+9 ;
