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