PXBPCPT2 ;WASH/BDB - PROMPT PROCEDURE DIAGNOSES ;10 Jun 2013 1:58 PM
;;1.0;PCE PATIENT CARE ENCOUNTER;**124,170,199**;Aug 12, 1996;Build 51
;
Q ;not an entry
;
CDX(PXN) ;--Diagnosis for Procedure
N CDX,CPTDX,DIC,POS,PXACS,PXC,PXCEAFTR,PXCEVIEN,PXD,PXDISV,PXDXDATE,PXICDDATA,TIMED,VAL,X
CPT1 K PXBUT,EDATA,LEXVDT
S PXDXDATE=$$CSDATE^PXDXUTL(PXBVST)
S PXACSREC=$$ACTDT^PXDXUTL(PXDXDATE),PXACS=$P(PXACSREC,U,3)
I PXACS["-" S PXACS=$P(PXACS,"-",1,2)
S POS=PXN+11,CPTDX=$P($P(REQE,U,POS)," "),PXDISV="PXBCPTDX-"_POS
S TIMED="I '$T!(DATA[""^"")",PXD=$P(REQI,U,POS),PXC=$P(REQI,U,3)
S DIC("S")="I $P($$ICDDATA^ICDXCODE(""DIAG"",Y,PXDXDATE,""E""),U,10)"
PCPT1 ;SECOND ENTRY POINT
W !," What is ",PXACS," DIAGNOSIS "_PXN_" for this procedure: "_$S($L(CPTDX):CPTDX_"//",1:""),IOELEOL
R DATA:DTIME S:DATA="" DATA=CPTDX S EDATA=DATA G:DATA="" CDXX1
P1CPT1 ;--
X TIMED I S PXBUT=1,LEAVE=1 G CDXX1
I DATA="^D" G CDXX1
I DATA="^"!(DATA="^^") S PXBEXIT=0 G CDXX1
I DATA="@",'$G(PXD) S DATA="?"
I DATA="@" K PXBREQ(PXD) S $P(REQI,U,POS)="@" G CDXX1
;I DATA="",PXN=1 W !,"PRIMARY DIAGNOSIS IS REQUIRED!" G CPT1
I DATA="?" D EN1^PXBHLP0("PXB","POV",1,"",1) G CPT1
;I DATA="??" S DOUBLEQQ=1 D EN1^PXBHLP0("PXB","POV",1,"",2) S:$L(DATA,"^")>1 (Y,DATA,EDATA)=$P($P(DATA,"^",2),"--",1) G:Y>1 PFINCPT1 G:Y?1A1.NP PFINCPT1
I DATA="??" D EN1^PXBHLP0("PXB","POV",1,"",2) G CPT1
I $L(DATA)>200 S (DATA,EDATA)=$E(DATA,1,199)
;---SPACE BAR---
I DATA=" ",$D(^DISV(DUZ,PXDISV)) S (DATA,EDATA)=^DISV(DUZ,PXDISV) W DATA
I DATA=" " S (DATA,EDATA)="" G CDXX1
;-----
;--Do a DIC lookup on data if a "?" is NOT entered
D CLEAR^VALM1,FULL^VALM1 ; added in *199 to allow full scrolling of long lists
W "Searching for diagnosis codes...",! ; added in *199
K X,DIC
S X=EDATA
I $P(PXACSREC,U,1)'="ICD" D
. S PXDATE=PXDXDATE,PXDEF=$G(X),PXAGAIN=0 D ^PXDSLK I PXXX=-1 S Y=-1 Q
. S Y($P(PXACSREC,U,2))=$P($P(PXXX,U,1),";",2)
. S Y=$P(PXXX,";",1)_U_$P(PXXX,U,2)
I $P(PXACSREC,U,1)="ICD" D
. D CONFIG^LEXSET($P(PXACSREC,U,1),,PXDXDATE)
. S DIC("A")="Select "_PXACS_" Diagnosis: "
. S DIC="^LEX(757.01,",DIC(0)=$S('$L(X):"A",1:"")_"EQM"
. D ^DIC
I $G(X)="@" Q
I Y=-1 S DATA="^P" G P1CPT1
S WHAT=$G(Y($P(PXACSREC,U,2)))
S (DATA,EDATA)=WHAT K Y
S PXICDDATA=$$ICDDATA^ICDXCODE("DIAG",WHAT,PXDXDATE,"E")
S Y=$S($P(PXICDDATA,U,10)=0:-1,1:$P(PXICDDATA,U,1,2))
S Y(0)=$P(PXICDDATA,U,2,99)
;
PFINCPT1 ;--Finish DIAGNOSIS
I $L(Y,U)'>1 S X=Y,DIC=80,DIC(0)="IZM" D ^DIC
I +Y<0 D HELP1^PXBUTL1("POV") G CPT1
I $$DUP(+Y) W !,$P(Y,U,2)," IS ALREADY A DIAGNOSIS!" G PCPT1
S CDX=Y(0),^DISV(DUZ,PXDISV)=DATA,$P(REQI,U,POS)=+Y
S $P(REQE,U,POS)=$P(CDX,U,1)_" --"_$P(CDX,U,3)
I $D(PXBREQ(+Y,"I")) G CDXX1
I 'PXBDXPRI D
.D PRI^PXBPPOV1 ;PRI/SEC
.I '$D(DIRUT),$P(REQI,U,6)="P" S PXBDXPRI=+Y
S PXCEVIEN=PXBVST,PXDX=Y
D WIN17^PXBCC(PXBCNT),GET800^PXCEC800 ;CI's
I $G(PXCEQUIT) S $P(REQE,U,POS)=""
I '$G(PXCEQUIT) S PXBREQ(+PXDX,"I")=PXCEAFTR(800)
I '$G(PXCEQUIT) D EN0^PXBSTOR(PXBVST,PATIENT,REQI,.PXMREQ),EN1^PXKMAIN
CDXX1 ;--EXIT AND CLEAN UP
I '$D(REQE) S REQE=""
I $P(REQE,U,POS)="" S $P(REQI,U,POS)=""
D CLEAR^VALM1 S VALMBCK="R"
Q
;
DUP(CD) ;DUPLICATE?
N ANS,CTR
S ANS=0
F CTR=12:1:19 I CTR'=POS,$P(REQI,U,CTR)=CD S ANS=1 Q
Q ANS
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXBPCPT2 3323 printed Apr 09, 2024@21:30:31 Page 2
PXBPCPT2 ;WASH/BDB - PROMPT PROCEDURE DIAGNOSES ;10 Jun 2013 1:58 PM
+1 ;;1.0;PCE PATIENT CARE ENCOUNTER;**124,170,199**;Aug 12, 1996;Build 51
+2 ;
+3 ;not an entry
QUIT
+4 ;
CDX(PXN) ;--Diagnosis for Procedure
+1 NEW CDX,CPTDX,DIC,POS,PXACS,PXC,PXCEAFTR,PXCEVIEN,PXD,PXDISV,PXDXDATE,PXICDDATA,TIMED,VAL,X
CPT1 KILL PXBUT,EDATA,LEXVDT
+1 SET PXDXDATE=$$CSDATE^PXDXUTL(PXBVST)
+2 SET PXACSREC=$$ACTDT^PXDXUTL(PXDXDATE)
SET PXACS=$PIECE(PXACSREC,U,3)
+3 IF PXACS["-"
SET PXACS=$PIECE(PXACS,"-",1,2)
+4 SET POS=PXN+11
SET CPTDX=$PIECE($PIECE(REQE,U,POS)," ")
SET PXDISV="PXBCPTDX-"_POS
+5 SET TIMED="I '$T!(DATA[""^"")"
SET PXD=$PIECE(REQI,U,POS)
SET PXC=$PIECE(REQI,U,3)
+6 SET DIC("S")="I $P($$ICDDATA^ICDXCODE(""DIAG"",Y,PXDXDATE,""E""),U,10)"
PCPT1 ;SECOND ENTRY POINT
+1 WRITE !," What is ",PXACS," DIAGNOSIS "_PXN_" for this procedure: "_$SELECT($LENGTH(CPTDX):CPTDX_"//",1:""),IOELEOL
+2 READ DATA:DTIME
if DATA=""
SET DATA=CPTDX
SET EDATA=DATA
if DATA=""
GOTO CDXX1
P1CPT1 ;--
+1 XECUTE TIMED
IF $TEST
SET PXBUT=1
SET LEAVE=1
GOTO CDXX1
+2 IF DATA="^D"
GOTO CDXX1
+3 IF DATA="^"!(DATA="^^")
SET PXBEXIT=0
GOTO CDXX1
+4 IF DATA="@"
IF '$GET(PXD)
SET DATA="?"
+5 IF DATA="@"
KILL PXBREQ(PXD)
SET $PIECE(REQI,U,POS)="@"
GOTO CDXX1
+6 ;I DATA="",PXN=1 W !,"PRIMARY DIAGNOSIS IS REQUIRED!" G CPT1
+7 IF DATA="?"
DO EN1^PXBHLP0("PXB","POV",1,"",1)
GOTO CPT1
+8 ;I DATA="??" S DOUBLEQQ=1 D EN1^PXBHLP0("PXB","POV",1,"",2) S:$L(DATA,"^")>1 (Y,DATA,EDATA)=$P($P(DATA,"^",2),"--",1) G:Y>1 PFINCPT1 G:Y?1A1.NP PFINCPT1
+9 IF DATA="??"
DO EN1^PXBHLP0("PXB","POV",1,"",2)
GOTO CPT1
+10 IF $LENGTH(DATA)>200
SET (DATA,EDATA)=$EXTRACT(DATA,1,199)
+11 ;---SPACE BAR---
+12 IF DATA=" "
IF $DATA(^DISV(DUZ,PXDISV))
SET (DATA,EDATA)=^DISV(DUZ,PXDISV)
WRITE DATA
+13 IF DATA=" "
SET (DATA,EDATA)=""
GOTO CDXX1
+14 ;-----
+15 ;--Do a DIC lookup on data if a "?" is NOT entered
+16 ; added in *199 to allow full scrolling of long lists
DO CLEAR^VALM1
DO FULL^VALM1
+17 ; added in *199
WRITE "Searching for diagnosis codes...",!
+18 KILL X,DIC
+19 SET X=EDATA
+20 IF $PIECE(PXACSREC,U,1)'="ICD"
Begin DoDot:1
+21 SET PXDATE=PXDXDATE
SET PXDEF=$GET(X)
SET PXAGAIN=0
DO ^PXDSLK
IF PXXX=-1
SET Y=-1
QUIT
+22 SET Y($PIECE(PXACSREC,U,2))=$PIECE($PIECE(PXXX,U,1),";",2)
+23 SET Y=$PIECE(PXXX,";",1)_U_$PIECE(PXXX,U,2)
End DoDot:1
+24 IF $PIECE(PXACSREC,U,1)="ICD"
Begin DoDot:1
+25 DO CONFIG^LEXSET($PIECE(PXACSREC,U,1),,PXDXDATE)
+26 SET DIC("A")="Select "_PXACS_" Diagnosis: "
+27 SET DIC="^LEX(757.01,"
SET DIC(0)=$SELECT('$LENGTH(X):"A",1:"")_"EQM"
+28 DO ^DIC
End DoDot:1
+29 IF $GET(X)="@"
QUIT
+30 IF Y=-1
SET DATA="^P"
GOTO P1CPT1
+31 SET WHAT=$GET(Y($PIECE(PXACSREC,U,2)))
+32 SET (DATA,EDATA)=WHAT
KILL Y
+33 SET PXICDDATA=$$ICDDATA^ICDXCODE("DIAG",WHAT,PXDXDATE,"E")
+34 SET Y=$SELECT($PIECE(PXICDDATA,U,10)=0:-1,1:$PIECE(PXICDDATA,U,1,2))
+35 SET Y(0)=$PIECE(PXICDDATA,U,2,99)
+36 ;
PFINCPT1 ;--Finish DIAGNOSIS
+1 IF $LENGTH(Y,U)'>1
SET X=Y
SET DIC=80
SET DIC(0)="IZM"
DO ^DIC
+2 IF +Y<0
DO HELP1^PXBUTL1("POV")
GOTO CPT1
+3 IF $$DUP(+Y)
WRITE !,$PIECE(Y,U,2)," IS ALREADY A DIAGNOSIS!"
GOTO PCPT1
+4 SET CDX=Y(0)
SET ^DISV(DUZ,PXDISV)=DATA
SET $PIECE(REQI,U,POS)=+Y
+5 SET $PIECE(REQE,U,POS)=$PIECE(CDX,U,1)_" --"_$PIECE(CDX,U,3)
+6 IF $DATA(PXBREQ(+Y,"I"))
GOTO CDXX1
+7 IF 'PXBDXPRI
Begin DoDot:1
+8 ;PRI/SEC
DO PRI^PXBPPOV1
+9 IF '$DATA(DIRUT)
IF $PIECE(REQI,U,6)="P"
SET PXBDXPRI=+Y
End DoDot:1
+10 SET PXCEVIEN=PXBVST
SET PXDX=Y
+11 ;CI's
DO WIN17^PXBCC(PXBCNT)
DO GET800^PXCEC800
+12 IF $GET(PXCEQUIT)
SET $PIECE(REQE,U,POS)=""
+13 IF '$GET(PXCEQUIT)
SET PXBREQ(+PXDX,"I")=PXCEAFTR(800)
+14 IF '$GET(PXCEQUIT)
DO EN0^PXBSTOR(PXBVST,PATIENT,REQI,.PXMREQ)
DO EN1^PXKMAIN
CDXX1 ;--EXIT AND CLEAN UP
+1 IF '$DATA(REQE)
SET REQE=""
+2 IF $PIECE(REQE,U,POS)=""
SET $PIECE(REQI,U,POS)=""
+3 DO CLEAR^VALM1
SET VALMBCK="R"
+4 QUIT
+5 ;
DUP(CD) ;DUPLICATE?
+1 NEW ANS,CTR
+2 SET ANS=0
+3 FOR CTR=12:1:19
IF CTR'=POS
IF $PIECE(REQI,U,CTR)=CD
SET ANS=1
QUIT
+4 QUIT ANS
+5 ;
