- 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 Feb 18, 2025@23:52:42 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 ;