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

PXBDPOV.m

Go to the documentation of this file.
  1. PXBDPOV ;ISL/JVS - DISPLAY POV (DIAGNOSIS) ;24 May 2013 7:02 AM
  1. ;;1.0;PCE PATIENT CARE ENCOUNTER;**124,168,199**;Aug 12, 1996;Build 51
  1. ;
  1. ;
  1. EN0 ;---Main entry point
  1. I '$D(IOCUU) D TERM^PXBCC
  1. ;
  1. S HEAD="- - E N C O U N T E R D I A G N O S I S (ICD CODES) - -"
  1. W !,IOCUU,?(IOM-$L(HEAD))\2,IOINHI,HEAD
  1. W IOINLOW,IOELEOL K HEAD
  1. ;
  1. I $D(CLINIC) D POV^PXBUTL2(CLINIC)
  1. ;I PXBCNT<11 D DPOV1
  1. ;I PXBCNT>10&($D(PXBNPOV)) D DPOV4("SAME")
  1. ;I PXBCNT>10&('$D(PXBNPOV)) D DPOV4("BEGIN")
  1. D DPOV4($S($D(PXBNPOV):"SAME",1:"BEGIN"))
  1. Q
  1. ;
  1. ;
  1. DPOV1 ;--Display the POV Data
  1. N ENTRY,K
  1. D UNDON^PXBCC
  1. W !,"No.",?5,"ICD",?14,"DESCRIPTION",?65,"PROBLEM LIST"
  1. W IOEDEOP
  1. D UNDOFF^PXBCC
  1. ;
  1. ;
  1. S (K,J)=0 F S J=$O(PXBSAM(J)) Q:J="" D
  1. .S ENTRY=$G(PXBSAM(J)) I $D(PXBNPOV($P(ENTRY,"^",1))) S $P(ENTRY,"^",1)=$P(ENTRY,"^",1)_"*"
  1. .I $P(ENTRY,U)=0 D CIA($P(ENTRY,U,2,16)) Q
  1. .S K=K+1
  1. .W !,K,?4,$J($P($P(ENTRY,"^",1),".",1),4),".",$P($P(ENTRY,"^",1),".",2),?14,$E($P(ENTRY,"^",3),1,30),?45
  1. .W:$P(ENTRY,"^",4)["PRI" $P(ENTRY,"^",4)
  1. .I $P(ENTRY,"^",4)["PRI" W ?71,$P(ENTRY,"^",5)
  1. .E W ?75,$P(ENTRY,"^",5)
  1. .D DIS
  1. ;---Write no entries if none exist
  1. I '$D(PXBSAM) D NONE^PXBUTL(3)
  1. ;-------------UNCOMMENT TO LIST CLINIC POV TO SCREEN-----
  1. ;D DEF^PXBDPOV("A")
  1. ;----------------------------------------------------
  1. D DEF^PXBDPOV("D") I '$D(FIRST) K PXBDPOV
  1. Q
  1. ;
  1. ;
  1. ;
  1. DPOV4(SIGN) ;--Display the PROVIDER Data
  1. ;
  1. ;SIGN=
  1. ; '+' add 10 to the starting point in ^TMP("PXBDPOV",$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. I SIGN="BEGIN" S ^TMP("PXBDPOV",$J,"START")=0,PXBSTART=0
  1. I SIGN="SAME" S PXBSTART=^TMP("PXBDPOV",$J,"START")
  1. I SIGN="+" S PXBSTART=($G(^TMP("PXBDPOV",$J,"START"))+(10)) S:PXBSTART'<PXBCNT PXBSTART=(PXBCNT-(10)) S ^TMP("PXBDPOV",$J,"START")=PXBSTART
  1. I SIGN="-" S PXBSTART=$G(^TMP("PXBDPOV",$J,"START"))-10,^TMP("PXBDPOV",$J,"START")=PXBSTART I PXBSTART<0 S PXBSTART=0 S ^TMP("PXBDPOV",$J,"START")=0
  1. I +SIGN>0&(SIGN#10) S PXBSTART=$P((SIGN/10),".")*10 S:PXBSTART<10 PXBSTART=0 Q:^TMP("PXBDPOV",$J,"START")=PXBSTART S ^TMP("PXBDPOV",$J,"START")=PXBSTART
  1. I +SIGN>0&'(SIGN#10) S PXBSTART=(($P((SIGN/10),".")*10)-10) S:PXBSTART<10 PXBSTART=0 Q:^TMP("PXBDPOV",$J,"START")=PXBSTART S ^TMP("PXBDPOV",$J,"START")=PXBSTART
  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 D I A G N O S I S (ICD CODES) - -"
  1. W !,IOCUU,?(IOM-$L(HEAD))\2,IOINHI,HEAD ;----F W $C(32) Q:$X=(IOM-(1))
  1. W IOINLOW,IOELEOL K HEAD
  1. ;
  1. N ENTRY,J,K
  1. D UNDON^PXBCC
  1. W !,"No.",?5,"ICD",?14,"DESCRIPTION",?64,"PROBLEM LIST"
  1. W IOEDEOP
  1. D UNDOFF^PXBCC
  1. D ARRAY
  1. ;
  1. S J=PXBSTART,K=J
  1. F S J=$O(@PXTMP@(J)) Q:J="" Q:K=(PXBSTART+11) D
  1. .S ENTRY=$G(@PXTMP@(J,0)),K=K+1
  1. .I $P(ENTRY,U)=0 D CIA($P(ENTRY,U,2,16)) Q
  1. .N PXNUMBR S PXNUMBR=$P(ENTRY,U)
  1. .S ENTRY=$P(ENTRY,U,2,15)
  1. .I $P(ENTRY,"^",1)'="",$D(PXBNCPT($P(ENTRY,"^",1))) S $P(ENTRY,"^",1)=$P(ENTRY,"^",1)_"*"
  1. .W !,PXNUMBR,?4,$J($P($P(ENTRY,"^",1),".",1),4),$S($P(ENTRY,"^",1)'="":".",1:""),$P($P(ENTRY,"^",1),".",2),?14,$E($P(ENTRY,"^",3),1,30),?45
  1. .W:$P(ENTRY,"^",4)["PRI" IOINHI,$P(ENTRY,"^",4),IOINLOW
  1. .W ?$P(ENTRY,"^",4)["PRI"*7+53,$P(ENTRY,"^",7)
  1. .I $P(ENTRY,"^",4)["PRI" W ?71,$P(ENTRY,"^",5)
  1. .D DIS
  1. I SIGN'="BEGIN" W !!
  1. ;------------UNCOMMENT TO LIST PROVIDERS TO SCREEN--------
  1. ;D DEF^PXBDPOV("A")
  1. ;---------------------------------------------------------
  1. D DEF^PXBDPOV("D") I '$D(FIRST) K PXBDPOV
  1. Q
  1. ;
  1. ;
  1. DEF(CODE) ;---PROCESS DEFAULT LIST OF DIAGNOSES
  1. ; I CODE="D" JUST SEND DEFAULT
  1. ; I CODE="A" JUST SEND THE ARRAY OF PROVIDERS
  1. D POV^PXBUTL2(CLINIC,3)
  1. N POV,X,CLNAME,STOP,LIST,NAME,NUMBER
  1. I '$D(IORC) D TERM^PXBCC
  1. I '$D(CODE) W !,"SEND PARAMETER = TO 'D'efault OR 'A'rray" Q
  1. I $G(CODE)="D",$D(PXBPMT("DEF")) S NAME=$O(PXBPMT("DEF",0)) S PXBDPOV=NAME
  1. I $G(CODE)="A" K PXBPMT("DEF") D
  1. .S (POV,STOP)="" F S POV=$O(PXBPMT("POV",POV)) Q:POV="" Q:STOP=0 D
  1. ..I '$D(PXBKY(POV)) S STOP=0
  1. .I STOP="" Q
  1. .S CLNAME=$P(^SC(CLINIC,0),"^",1)
  1. .S X="Other ICD CODES associated with "_CLNAME_" clinic."
  1. .W:PXBCNT<7 ! W !,?(IOM-$L(X))/2,IOINHI,X,IOINLOW K X
  1. .S (POV,LIST)="" F S POV=$O(PXBPMT("POV",POV)) Q:POV="" D
  1. ..I $D(PXBKY(+POV)) Q
  1. ..S LIST=LIST_POV_" " I $L(LIST," ")>2 W !,?(IOM-$L(LIST))/2,LIST S LIST=""
  1. I $G(LIST)]"" W !,?(IOM-$L(LIST))/2,LIST
  1. Q
  1. ;
  1. DIS ;----DISPLAY
  1. Q
  1. I $D(PXBPMT("POV",$P($P(ENTRY,"^",1),"*"))) W:PXBCNT>11 IORVON W ?37," --Clinic Associated--",IORVOFF
  1. Q
  1. ;
  1. CIA(X) ;Clinical Indicator Abbreviations
  1. N V,I,CI,CI2 S CI="SC^AO^IR^SWAC^MST^HNC^CV^SHAD",CI2=1 W !
  1. F I=1,7,2:1:4,8,5,6 S V=$P(X,U,I) I V]"" W ?(CI2*8),$P(CI,U,I),":",$S(V:"Y",1:"N") S CI2=CI2+1
  1. Q
  1. ;
  1. ARRAY ;Set POV entries into ^TMP("PXBDPOV",$J,"DSP" for display
  1. N ENTRY,PX124,PXTLNS
  1. S PXTMP="^TMP(""PXBDPOV"""_","_$J_","_"""DSP"")",(PXTLNS,PX124)=0
  1. K @PXTMP
  1. F S PX124=$O(PXBSAM(PX124)) Q:'PX124 D
  1. .S PXTLNS=PXTLNS+1,ENTRY=PXBSAM(PX124)
  1. .S PXBSAM(PX124,"LINE")=PXTLNS
  1. .N PXCODSET S PXCODSET=$P($$ICDDATA^ICDXCODE("DIAG",$P(ENTRY,U),$$CSDATE^PXDXUTL(PXBVST),"E"),U,20) I PXCODSET=30 D
  1. ..N PXENTRY S PXENTRY(1)=$P(ENTRY,U,6) D PR^PXSELDS(.PXENTRY,30)
  1. ..S $P(ENTRY,U,3)=$$SENTENCE^XLFSTR(PXENTRY(1))
  1. ..S @PXTMP@(PXTLNS,0)=PX124_U_ENTRY
  1. ..N PXENTNUM F PXENTNUM=2:1:PXENTRY D
  1. ...S ENTRY=U_U_$$SENTENCE^XLFSTR(PXENTRY(PXENTNUM)),PXTLNS=PXTLNS+1
  1. ...S @PXTMP@(PXTLNS,0)=U_ENTRY
  1. .I PXCODSET'=30 S @PXTMP@(PXTLNS,0)=PX124_U_ENTRY
  1. .S PXTLNS=PXTLNS+1
  1. .S @PXTMP@(PXTLNS,0)=0_U_PXBSAM(PX124,"I")
  1. S PXBCNT=PXTLNS
  1. Q
  1. ;