Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PXBDCPT

PXBDCPT.m

Go to the documentation of this file.
  1. 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
  1. ;
  1. ;
  1. ; Reference to CPT^ICPTCOD in ICR #1995
  1. ; Reference to LD^ICDEX in ICR #5747
  1. ;
  1. ;
  1. EN0 ;---Main entry point
  1. ;
  1. ;
  1. S HEAD="- - E N C O U N T E R P R O C E D U R E S (CPT CODES) - -"
  1. W IOINHI,!,IOCUU,?(IOM-$L(HEAD))\2,HEAD,IOINLOW
  1. W IOELEOL K HEAD
  1. ;
  1. I $D(CLINIC) D PRV^PXBUTL2(CLINIC)
  1. ;
  1. ;I PXBCNT<11 D DISCPT1^PXBDCPT
  1. ;I PXBCNT<21&(PXBCNT>10) D DISCPT2^PXBDCPT
  1. ;I PXBCNT>20&(PXBCNT<31) D DISCPT3^PXBDCPT
  1. ;I PXBCNT>30&('$D(PXBNCPT))
  1. D DISCPT4^PXBDCPT("BEGIN")
  1. ;I PXBCNT>30&($D(PXBNCPT)) D DISCPT4^PXBDCPT("SAME")
  1. Q
  1. ;
  1. ;
  1. ;
  1. ARRAY ;Set all CPT codes and modifiers into ^TMP("PXBDCPT",$J,"DSP"
  1. ;for display
  1. ;
  1. N PXASTRSK,PXCPTCD,PXCPTDA,PXCPTI,PXSQ,ENTRY,PXMD,PXDESC,PX124,PXC,PXD,PXDXDATE
  1. S PXTMP="^TMP(""PXBDCPT"""_","_$J_","_"""DSP"")"
  1. K @PXTMP
  1. ;PXBSAM is built by CPT^PXBGCPT which is called in HEADER^PXBMCPT2
  1. ;just before EN0^PXBDCPT is called.
  1. S (PXTLNS,PXSQ)=0
  1. F S PXSQ=$O(PXBSAM(PXSQ)) Q:'PXSQ D
  1. .S PXTLNS=PXTLNS+1
  1. .S ENTRY=PXBSAM(PXSQ)
  1. .S PXBSAM(PXSQ,"LINE")=PXTLNS
  1. .;The * is appended for codes added during the checkout interview.
  1. .;The added codes are in PXBNCPT.
  1. .S PXASTRSK=0
  1. .I $D(PXBNCPT($P(ENTRY,U))) D
  1. ..;I PXBNCPT($P(ENTRY,U))]"",'$D(PXBSKY(PXSQ,PXBNCPT($P(ENTRY,U)))) Q
  1. ..Q:'$D(PXBNCPT($P(ENTRY,U),$O(PXBSKY(PXSQ,0))))
  1. ..;S $P(ENTRY,U)=$P(ENTRY,U)_"*"
  1. ..S PXASTRSK=1
  1. .S PXCPTI=$P(ENTRY,U,1)
  1. .S PXCPTDA=$$CPT^ICPTCOD(+PXCPTI)
  1. .;The second piece of PXCPTDA is the code, unless something is wrong, then
  1. .;it is the error description.
  1. .S PXCPTCD=$P(PXCPTDA,U,2)
  1. .;If PXASTRSK is true and there is no CPT code error, append *.
  1. .I (PXASTRSK=1),($P(PXCPTDA,U,1)'=-1) S PXCPTCD=PXCPTCD_"*"
  1. .;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)
  1. .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)
  1. .S PXMD=""
  1. .F S PXMD=$O(PXBSAM(PXSQ,"MOD",PXMD)) Q:'PXMD D
  1. ..S PXTLNS=PXTLNS+1
  1. ..S PXMOD=PXBSAM(PXSQ,"MOD",PXMD)
  1. ..S PXDESC=$P($$MODP^ICPTMOD($E(ENTRY,1,5),PXMOD,"E",IDATE),U,2) ;PX*108
  1. ..S @PXTMP@(PXTLNS,0)=0_U_PXMOD_U_$E(PXDESC,1,54)
  1. .S PXTLNS=PXTLNS+1
  1. .S @PXTMP@(PXTLNS,0)="-22^"_$P(ENTRY,U,22)
  1. .S PXDXDATE=$$CSDATE^PXDXUTL(PXBVST)
  1. .F PX124=5:1:12 D
  1. ..S PXC=$P(ENTRY,U,PX124) Q:PXC=""
  1. ..S PXD=$$ICDDATA^ICDXCODE("DIAG",PXC,PXDXDATE,"E") Q:PXD<1
  1. ..I $P(PXD,U,20)'=30 D
  1. ...S PXC=PXC_" "_$P(PXD,U,4)
  1. ...S PXTLNS=PXTLNS+1,@PXTMP@(PXTLNS,0)=-PX124_U_PXC
  1. ..I $P(PXD,U,20)=30 D
  1. ...N PXENTRY S PXENTRY(1)=$$SENTENCE^XLFSTR($$LD^ICDEX(80,$P(PXD,U,1),PXDXDATE))
  1. ...D PR^PXSELDS(.PXENTRY,50)
  1. ...N PXLENGTH,PXLONG,PXSPACES S PXSPACES=" ",PXLENGTH=$L(PXC)-5
  1. ...I PXLENGTH>0 S PXSPACES=$E(PXSPACES,1,5-PXLENGTH)
  1. ...S PXLONG=PXC_PXSPACES_PXENTRY(1)
  1. ...S PXTLNS=PXTLNS+1,@PXTMP@(PXTLNS,0)=-PX124_U_PXLONG
  1. ...N PXNUMBR F PXNUMBR=2:1:PXENTRY D
  1. ....S PXTLNS=PXTLNS+1,@PXTMP@(PXTLNS,0)=-PX124_U_PXENTRY(PXNUMBR)_U_"NEXTLONG"
  1. ..I $G(PXBREQ(+PXD,"I"))="" S PXBREQ(+PXD,"I")=$P($$XLATE^PXBGPOV(PXBVST,+PXD),U,4,20)
  1. ..S PXTLNS=PXTLNS+1,@PXTMP@(PXTLNS,0)="I^"_PXBREQ(+PXD,"I")
  1. Q
  1. DISCPT1 ;--Display the CPT Data
  1. ;
  1. N ENTRY,J
  1. D UNDON^PXBCC
  1. W !,"No.",?4,"CPT CODE",?14,"QUANTITY",?25,"DESCRIPTION",?55,"PROVIDER",?75,$C(32)
  1. W IOEDEOP
  1. D UNDOFF^PXBCC
  1. ;
  1. S J=0
  1. F S J=$O(PXBSAM(J)) Q:J="" D
  1. .S ENTRY=$G(PXBSAM(J))
  1. .I $D(PXBNCPT($P(ENTRY,U,1))) S $P(ENTRY,U,1)=$P(ENTRY,U,1)_"*"
  1. .W !,J,?4,$P(ENTRY,U,1),?15,$P(ENTRY,U,2)
  1. .W ?25,$P(ENTRY,U,4),?55,$E($P(ENTRY,U,3),1,24)
  1. .;---Display associated modifiers
  1. .S PXSIEN=""
  1. .F S PXSIEN=$O(PXBSAM(J,"MOD",PXSIEN)) Q:PXSIEN="" D
  1. ..N PXWRAP,PXMOD,PXDESC,PXLN
  1. ..S PXMOD=PXBSAM(J,"MOD",PXSIEN)
  1. ..S PXDESC=$P($$MOD^ICPTMOD(PXMOD,"E",IDATE),U,3)
  1. ..D WRAP^PXCEVFI4(PXDESC,58,.PXWRAP)
  1. ..F PXLN=1:1 Q:$G(PXWRAP(PXLN))="" D
  1. ...W:PXLN=1 !,?4,"CPT Modifier: "_PXMOD
  1. ...W:PXLN>1 !
  1. ...W ?22,PXWRAP(PXLN)
  1. ;---Write no entries if none exist
  1. I '$D(PXBSAM) D NONE^PXBUTL(2)
  1. Q
  1. ;
  1. DISCPT2 ;--display of cpt data two columns if more than 10 entries.
  1. ;
  1. N ENTRY,J,PXA
  1. D GSET^%ZISS
  1. D UNDON^PXBCC W IOG1
  1. W !,"NO",?4,"CPT",?10,"QUA",?14,"DESCRIPTION",?39,IOVL
  1. W ?40,"NO",?44,"CPT",?50,"QUA",?54,"NARRATIVE"
  1. W IOEDEOP
  1. D UNDOFF^PXBCC
  1. ;
  1. ;
  1. ;
  1. S J=0 F S J=$O(PXBSAM(J)) Q:J="" D
  1. .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)_"*"
  1. F J=1:1:10 D
  1. .W !,J,?4,$P(ENTRY(J),U,1),?11,$P(ENTRY(J),U,2),?14,$E($P(ENTRY(J),U,4),1,24)
  1. .D BAWRITE(ENTRY(J))
  1. .I $D(ENTRY(J+10)) D
  1. ..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)
  1. ..D BAWRITE(ENTRY(J))
  1. W IOG0
  1. Q
  1. ;
  1. DISCPT3 ;--display of cpt data three columns if more than 20 entries.
  1. N ENTRY,J,PXA
  1. D GSET^%ZISS
  1. D UNDON^PXBCC W IOG1
  1. W !,"NO",?4,"CPT",?10,"QUA",?14,"NARRATIVE",?25,IOVL
  1. W ?26,"NO",?30,"CPT",?36,"QUA",?40,"NARRATIVE",?51,IOVL
  1. W ?52,"NO",?56,"CPT",?62,"QUA",?66,"NARRATIVE"
  1. W IOEDEOP
  1. D UNDOFF^PXBCC
  1. ;
  1. S J=0 F S J=$O(PXBSAM(J)) Q:J="" D
  1. .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)_"*"
  1. F J=1:1:10 D
  1. .W !,J,?4,$P(ENTRY(J),U,1),?11,$P(ENTRY(J),U,2),?14,$E($P(ENTRY(J),U,4),1,10)
  1. .D BAWRITE(ENTRY(J))
  1. .I $D(ENTRY(J+10)) D
  1. ..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)
  1. ..D BAWRITE(ENTRY(J+10))
  1. .I $D(ENTRY(J+20)) D
  1. ..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)
  1. ..D BAWRITE(ENTRY(J+20))
  1. W IOG0
  1. Q
  1. ;
  1. DISCPT4(SIGN) ;--Display the CPT Data
  1. ;
  1. ;SIGN=
  1. ; '+' add 10 to the starting point in ^TMP("PXBDCPT",$J)
  1. ; '-' subtract 10 from the starting point but not less than 0
  1. ; 'BEGIN' start at the beginning
  1. ; 'SAME' start stays where it's at
  1. ; '3'--any number set start to that number
  1. ;
  1. N PXBSTART,PXTMP
  1. D ARRAY
  1. I SIGN="BEGIN" S ^TMP("PXBDCPT",$J,"START")=0,PXBSTART=0
  1. I SIGN="SAME" S PXBSTART=^TMP("PXBDCPT",$J,"START")
  1. I SIGN="+" D
  1. .S PXBSTART=($G(^TMP("PXBDCPT",$J,"START"))+10)
  1. .I PXBSTART'<PXTLNS S PXBSTART=PXBSTART-10
  1. .S ^TMP("PXBDCPT",$J,"START")=PXBSTART
  1. I SIGN="-" D
  1. .S PXBSTART=$G(^TMP("PXBDCPT",$J,"START"))-10
  1. .S ^TMP("PXBDCPT",$J,"START")=PXBSTART
  1. .I PXBSTART<0 S PXBSTART=0 S ^TMP("PXBDCPT",$J,"START")=0
  1. I +SIGN>0&(SIGN#10) D Q:^TMP("PXBDCPT",$J,"START")=PXBSTART S ^TMP("PXBDCPT",$J,"START")=PXBSTART
  1. .S PXBSTART=$P((SIGN/10),".")*10
  1. .S:PXBSTART<10 PXBSTART=0
  1. I +SIGN>0&'(SIGN#10) D Q:^TMP("PXBDCPT",$J,"START")=PXBSTART S ^TMP("PXBDCPT",$J,"START")=PXBSTART
  1. .S PXBSTART=(($P((SIGN/10),".")*10)-10)
  1. .S:PXBSTART<10 PXBSTART=0
  1. ;
  1. ;
  1. I SIGN'="BEGIN" D LOC^PXBCC(3,0) W IOEDEOP
  1. ;
  1. HEAD4 ;--HEADER ON LIST
  1. S HEAD="- - E N C O U N T E R P R O C E D U R E S (CPT CODES) - -"
  1. W IOINHI,!,IOCUU,?(IOM-$L(HEAD))\2,HEAD,IOINLOW
  1. W IOELEOL K HEAD
  1. ;
  1. ;
  1. N ENTRY,J
  1. D UNDON^PXBCC
  1. W !,"No.",?4,"CPT CODE",?14,"QUANTITY",?25,"DESCRIPTION",?55,"PROVIDER",?75,$C(32)
  1. W IOEDEOP
  1. D UNDOFF^PXBCC
  1. ;
  1. ;
  1. N PXSIEN,PXDESC,PXMOD,PXQ,PXLNS,PX,PL
  1. S J=PXBSTART,PXQ=""
  1. S PXLNS=0
  1. F S J=$O(@PXTMP@(J)) Q:J="" D Q:PXQ
  1. .S PXLNS=PXLNS+1
  1. .I '(PXLNS#11) D Q
  1. ..S ^TMP("PXBDCPT",$J,"START")=PXBSTART
  1. ..S PXQ=1
  1. .I +@PXTMP@(J,0)>0 D Q
  1. ..W !,$P(^(0),U),?4,$P(^(0),U,2),?15,$P(^(0),U,3)
  1. ..W ?25,$P(^(0),U,4),?55,$P(^(0),U,5)
  1. .I +@PXTMP@(J,0)<0 D Q
  1. ..S PX=-$P(^(0),U,1)
  1. ..I PX=22 W !?4,"Ordering Provider: ",$P(^(0),U,2) Q
  1. ..I PX<20,$P(^(0),U,3)'="NEXTLONG" W !?4,"Diagnosis "_(PX-4)_": ",$P(^(0),U,2) Q
  1. ..I PX<20,$P(^(0),U,3)="NEXTLONG" W !?28,$P(^(0),U,2)
  1. .I $P(@PXTMP@(J,0),U)="I" D CIA^PXBDPOV($P(^(0),U,2,16)) Q
  1. .I $P(@PXTMP@(J,0),U)=0 D
  1. ..W !?4,"CPT Modifier: "_$P(^(0),U,2)_" "_$P(^(0),U,3)
  1. I SIGN'="BEGIN" W !!
  1. Q
  1. ;
  1. BAWRITE(PXD) ;WRITE BA INFO
  1. N PX,PD,PP
  1. W !?4,"Ordering Provider: ",$P(PXD,U,22)
  1. F PX=1:1:8 D
  1. .S PD=$P(PXD,U,PX+5),PP=$$XLATE^PXBGPOV(PXBVST,PD)
  1. .Q:'PD!'PP
  1. .W:PD !?4,"Diagnosis: ",PD
  1. .D CIA^PXBDPOV($P(PP,U,4,16))
  1. Q
  1. ;