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