PXBPPOV1 ;ISL/JVS,ESW - PROMPT POV ;4/6/05 2:41pm
;;1.0;PCE PATIENT CARE ENCOUNTER;**11,112,121,124,199**;Aug 12, 1996;Build 51
;
;
;
;
;
ADDM ;--------If Multiple POV entries have been entered.
;
;
;
N BDATA,OK,PXBLEN,PXDXDATE
S PXDXDATE=$$CSDATE^PXDXUTL(PXBVST)
D WIN17^PXBCC(PXBCNT)
S NF=0,PXBLEN=0
I DATA[",",$E(DATA,1)'["@" S NF=1 D
.S PXBLEN=$L(DATA,",") F PXI=1:1:PXBLEN S PXBPIECE=$P(DATA,",",PXI) D
..S Y=$$ICDDATA^ICDXCODE("DIAG",PXBPIECE,PXDXDATE,"E")
..I $P(Y,U)=-1!($P(Y,U,10)'=1) S BAD($G(PXBPIECE))="" Q
..S $P(REQI,"^",5)=+Y
..S PXBNPOV(PXBPIECE)=""
..;
..;--Prompt for Primary or Secondary DIAGNOSIS
..; ICD-10 Remediation note: the next two lines display code--code (ex. 369.65--369.65)
..; we think this is wrong but do not have specs to fix it.
..W !,"For the DIAGNOSIS: ",PXBPIECE,"--"
..W $P(Y,U,2),!
..D WIN17^PXBCC(PXBCNT)
..D PRI^PXBPPOV1
..I $D(DIRUT) D RSET^PXBDREQ("POV") Q
..D ORD^PXBPPOV1
..N PXCEVIEN,PXCEAFTR,PXD
..S PXCEVIEN=PXBVST,PXD=$P(REQI,U,5)
..D WIN17^PXBCC(PXBCNT),GET800^PXCEC800 ;CI's
..S PXBREQ(PXD,"I")=$G(PXCEAFTR(800))
..;
..D EN0^PXBSTOR(PXBVST,PATIENT,REQI)
..D EN1^PXKMAIN
..D RSET^PXBDREQ("POV")
I $G(NF)&($D(BAD)) D Q
.S (BDATA,EDATA)="" F S BDATA=$O(BAD(BDATA)) Q:BDATA="" S EDATA=EDATA_BDATA_" "
.W ! D HELP^PXBUTL0("CPTM") W !
.S DIR(0)="E" D ^DIR K DIR,DIRUT
.S:Y=1 DATA="^P" S:Y=0!(Y="") DATA="^" K Y
I $G(NF)&('$D(BAD)) S DATA="^P" Q
;
Q
;
DELM ;--------If Multiple deleting
N BAD,BDATA,DELM,PXBJ,PXBLEN
S NF=0,PXBLEN=0 S $P(DELM,"^",3)=1
I $E(DATA,1)="@" S DATA=$P(DATA,"@",2),NF=1 D
.S PXBLEN=$L(DATA,",") F PXI=1:1:PXBLEN S PXBPIECE=$P(DATA,",",PXI) D
..I PXBPIECE'["-"&(PXBPIECE'>0!(PXBPIECE'<(PXBCNT+1))) S BAD(+$G(PXBPIECE))="" Q
..I PXBPIECE'["-" D
...I $D(GONE(PXBPIECE)) Q
...Q:PXBPIECE'?.N
...S $P(REQI,"^",9)=$O(PXBSKY(PXBPIECE,0)) ;-IEN
...S X=$P(PXBSAM(PXBPIECE),U,1),Y=$$ICDDATA^ICDXCODE("DIAG",X,PXDXDATE,"E")
...I $P(Y,U)'=-1&($P(Y,U,10)=1) D
....S $P(REQI,"^",5)=+Y K Y
....S GONE(PXBPIECE)=""
....D EN0^PXBSTOR(PXBVST,PATIENT,REQI)
....D EN1^PXKMAIN
..I PXBPIECE["-" D
...F PXBJ=$P(PXBPIECE,"-",1):1:$P(PXBPIECE,"-",2) D
....I $D(GONE(PXBJ)) Q
....I PXBJ'>0!(PXBJ'<(PXBCNT+1)) S BAD(PXBJ)="" Q
....S $P(REQI,"^",9)=$O(PXBSKY(PXBJ,0)) ;-IEN
....S X=$P(PXBSAM(PXBJ),U,1),Y=$$ICDDATA^ICDXCODE("DIAG",X,PXDXDATE,"E")
....I $P(Y,U)'=-1&($P(Y,U,10)=1) D
.....S $P(REQI,"^",5)=+Y K Y
.....S GONE(PXBJ)=""
.....D EN0^PXBSTOR(PXBVST,PATIENT,REQI)
.....D EN1^PXKMAIN
K GONE
I $G(NF)&($D(BAD)) D Q
.S (BDATA,EDATA)="" F S BDATA=$O(BAD(BDATA)) Q:BDATA="" S EDATA=EDATA_BDATA_" "
.W ! D HELP^PXBUTL0("CPTMD") W !
.S DIR(0)="E" D ^DIR K DIR
.S:Y=1 DATA="^P" S:Y=0!(Y="") DATA="^" K Y
I $G(NF)&('$D(BAD)) S DATA="^P" Q
Q
PRI ;--Prompt for primary secondary DIAGNOSIS
N DIR,Y,X,SEQ
S SEQ=0 I $D(PXBKY(DATA)) S SEQ=+$O(PXBKY(DATA,"")) ;PX112
I $G(FPRI),$P($G(PXBKY(DATA,SEQ)),U,4)'="PRIMARY" Q ;PX112
W IOCUD,IOELALL,IOCUU
S DIR("A",1)="ONE primary diagnosis must be established for each encounter!"
S DIR("A")="Is this the PRIMARY DIAGNOSIS for this ENCOUNTER? "
S DIR("B")="YES"
S DIR("?")="One PRIMARY DIAGNOSIS must be established for each patient encounter. 'Yes' will mean PRIMARY and 'No' will mean SECONDARY."
S DIR(0)="Y,A,O"
D ^DIR I $G(DIRUT) G PPXIT
PPFIN ;--Finish off variables
I Y=1 S PRI="P^PRIMARY"
I Y=0 S PRI="S^SECONDARY"
S $P(REQI,"^",6)=$P(PRI,"^",1)
S $P(REQE,"^",6)=$P(PRI,"^",2)
PPXIT ;--EXIT
Q
ORD ;--Prompt for ordering resulting DIAGNOSIS
N DIR,Y,X,SEQ
S SEQ=0 I $D(PXBKY(DATA)) S SEQ=+$O(PXBKY(DATA,""))
W IOCUD,IOELALL,IOCUU
S DIR("A")="Is this Diagnosis Ordering or Resulting:"
S DIR("B")=$P($G(PXBKY(DATA,SEQ)),U,7)
S DIR("?")="Resulting and/or Ordering indicators are only entered if at least one of each diagnosis type exists."
S DIR(0)="SO^O:ORDERING;R:RESULTING;OR:BOTH O&R"
D ^DIR I $G(DIRUT) G PPXIT
ORFIN ;--Finish off variables
S $P(REQI,"^",7)=Y
S $P(REQE,"^",7)=$S(Y="O":"ORDERING",Y="R":"RESULTING",1:"BOTH O&R")
Q
PRBLM ;--Prompt for Problem list
N DIR,Y,X,VALL
W IOCUD,IOELALL,IOCUU
D WIN17^PXBCC(PXBCNT)
S DIR("?")="^S VALL=1,VALL=$$DOUBLE1^PXBGPL2(WHAT)"
S DIR("A")="Do you want this DIAGNOSIS added to the PROBLEM LIST? "
S DIR("B")="NO"
S DIR(0)="Y,A,O"
D ^DIR
I X="+"!(X="-") S DIR("?")="D DPOV4^PXBDPL(X)"
I $G(DIRUT) G PPXIT
PRPFIN ;--Finish off variables
K PXBKYPL,PXBSKYPL,PXBSAMPL,PXBCNTPL
K ^TMP("PXBKYPL",$J),^TMP("PXBSAMPL",$J)
S PXBPRBLM=+Y
PRPXIT ;--EXIT
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXBPPOV1 4641 printed Oct 16, 2024@18:27:52 Page 2
PXBPPOV1 ;ISL/JVS,ESW - PROMPT POV ;4/6/05 2:41pm
+1 ;;1.0;PCE PATIENT CARE ENCOUNTER;**11,112,121,124,199**;Aug 12, 1996;Build 51
+2 ;
+3 ;
+4 ;
+5 ;
+6 ;
ADDM ;--------If Multiple POV entries have been entered.
+1 ;
+2 ;
+3 ;
+4 NEW BDATA,OK,PXBLEN,PXDXDATE
+5 SET PXDXDATE=$$CSDATE^PXDXUTL(PXBVST)
+6 DO WIN17^PXBCC(PXBCNT)
+7 SET NF=0
SET PXBLEN=0
+8 IF DATA[","
IF $EXTRACT(DATA,1)'["@"
SET NF=1
Begin DoDot:1
+9 SET PXBLEN=$LENGTH(DATA,",")
FOR PXI=1:1:PXBLEN
SET PXBPIECE=$PIECE(DATA,",",PXI)
Begin DoDot:2
+10 SET Y=$$ICDDATA^ICDXCODE("DIAG",PXBPIECE,PXDXDATE,"E")
+11 IF $PIECE(Y,U)=-1!($PIECE(Y,U,10)'=1)
SET BAD($GET(PXBPIECE))=""
QUIT
+12 SET $PIECE(REQI,"^",5)=+Y
+13 SET PXBNPOV(PXBPIECE)=""
+14 ;
+15 ;--Prompt for Primary or Secondary DIAGNOSIS
+16 ; ICD-10 Remediation note: the next two lines display code--code (ex. 369.65--369.65)
+17 ; we think this is wrong but do not have specs to fix it.
+18 WRITE !,"For the DIAGNOSIS: ",PXBPIECE,"--"
+19 WRITE $PIECE(Y,U,2),!
+20 DO WIN17^PXBCC(PXBCNT)
+21 DO PRI^PXBPPOV1
+22 IF $DATA(DIRUT)
DO RSET^PXBDREQ("POV")
QUIT
+23 DO ORD^PXBPPOV1
+24 NEW PXCEVIEN,PXCEAFTR,PXD
+25 SET PXCEVIEN=PXBVST
SET PXD=$PIECE(REQI,U,5)
+26 ;CI's
DO WIN17^PXBCC(PXBCNT)
DO GET800^PXCEC800
+27 SET PXBREQ(PXD,"I")=$GET(PXCEAFTR(800))
+28 ;
+29 DO EN0^PXBSTOR(PXBVST,PATIENT,REQI)
+30 DO EN1^PXKMAIN
+31 DO RSET^PXBDREQ("POV")
End DoDot:2
End DoDot:1
+32 IF $GET(NF)&($DATA(BAD))
Begin DoDot:1
+33 SET (BDATA,EDATA)=""
FOR
SET BDATA=$ORDER(BAD(BDATA))
if BDATA=""
QUIT
SET EDATA=EDATA_BDATA_" "
+34 WRITE !
DO HELP^PXBUTL0("CPTM")
WRITE !
+35 SET DIR(0)="E"
DO ^DIR
KILL DIR,DIRUT
+36 if Y=1
SET DATA="^P"
if Y=0!(Y="")
SET DATA="^"
KILL Y
End DoDot:1
QUIT
+37 IF $GET(NF)&('$DATA(BAD))
SET DATA="^P"
QUIT
+38 ;
+39 QUIT
+40 ;
DELM ;--------If Multiple deleting
+1 NEW BAD,BDATA,DELM,PXBJ,PXBLEN
+2 SET NF=0
SET PXBLEN=0
SET $PIECE(DELM,"^",3)=1
+3 IF $EXTRACT(DATA,1)="@"
SET DATA=$PIECE(DATA,"@",2)
SET NF=1
Begin DoDot:1
+4 SET PXBLEN=$LENGTH(DATA,",")
FOR PXI=1:1:PXBLEN
SET PXBPIECE=$PIECE(DATA,",",PXI)
Begin DoDot:2
+5 IF PXBPIECE'["-"&(PXBPIECE'>0!(PXBPIECE'<(PXBCNT+1)))
SET BAD(+$GET(PXBPIECE))=""
QUIT
+6 IF PXBPIECE'["-"
Begin DoDot:3
+7 IF $DATA(GONE(PXBPIECE))
QUIT
+8 if PXBPIECE'?.N
QUIT
+9 ;-IEN
SET $PIECE(REQI,"^",9)=$ORDER(PXBSKY(PXBPIECE,0))
+10 SET X=$PIECE(PXBSAM(PXBPIECE),U,1)
SET Y=$$ICDDATA^ICDXCODE("DIAG",X,PXDXDATE,"E")
+11 IF $PIECE(Y,U)'=-1&($PIECE(Y,U,10)=1)
Begin DoDot:4
+12 SET $PIECE(REQI,"^",5)=+Y
KILL Y
+13 SET GONE(PXBPIECE)=""
+14 DO EN0^PXBSTOR(PXBVST,PATIENT,REQI)
+15 DO EN1^PXKMAIN
End DoDot:4
End DoDot:3
+16 IF PXBPIECE["-"
Begin DoDot:3
+17 FOR PXBJ=$PIECE(PXBPIECE,"-",1):1:$PIECE(PXBPIECE,"-",2)
Begin DoDot:4
+18 IF $DATA(GONE(PXBJ))
QUIT
+19 IF PXBJ'>0!(PXBJ'<(PXBCNT+1))
SET BAD(PXBJ)=""
QUIT
+20 ;-IEN
SET $PIECE(REQI,"^",9)=$ORDER(PXBSKY(PXBJ,0))
+21 SET X=$PIECE(PXBSAM(PXBJ),U,1)
SET Y=$$ICDDATA^ICDXCODE("DIAG",X,PXDXDATE,"E")
+22 IF $PIECE(Y,U)'=-1&($PIECE(Y,U,10)=1)
Begin DoDot:5
+23 SET $PIECE(REQI,"^",5)=+Y
KILL Y
+24 SET GONE(PXBJ)=""
+25 DO EN0^PXBSTOR(PXBVST,PATIENT,REQI)
+26 DO EN1^PXKMAIN
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+27 KILL GONE
+28 IF $GET(NF)&($DATA(BAD))
Begin DoDot:1
+29 SET (BDATA,EDATA)=""
FOR
SET BDATA=$ORDER(BAD(BDATA))
if BDATA=""
QUIT
SET EDATA=EDATA_BDATA_" "
+30 WRITE !
DO HELP^PXBUTL0("CPTMD")
WRITE !
+31 SET DIR(0)="E"
DO ^DIR
KILL DIR
+32 if Y=1
SET DATA="^P"
if Y=0!(Y="")
SET DATA="^"
KILL Y
End DoDot:1
QUIT
+33 IF $GET(NF)&('$DATA(BAD))
SET DATA="^P"
QUIT
+34 QUIT
PRI ;--Prompt for primary secondary DIAGNOSIS
+1 NEW DIR,Y,X,SEQ
+2 ;PX112
SET SEQ=0
IF $DATA(PXBKY(DATA))
SET SEQ=+$ORDER(PXBKY(DATA,""))
+3 ;PX112
IF $GET(FPRI)
IF $PIECE($GET(PXBKY(DATA,SEQ)),U,4)'="PRIMARY"
QUIT
+4 WRITE IOCUD,IOELALL,IOCUU
+5 SET DIR("A",1)="ONE primary diagnosis must be established for each encounter!"
+6 SET DIR("A")="Is this the PRIMARY DIAGNOSIS for this ENCOUNTER? "
+7 SET DIR("B")="YES"
+8 SET DIR("?")="One PRIMARY DIAGNOSIS must be established for each patient encounter. 'Yes' will mean PRIMARY and 'No' will mean SECONDARY."
+9 SET DIR(0)="Y,A,O"
+10 DO ^DIR
IF $GET(DIRUT)
GOTO PPXIT
PPFIN ;--Finish off variables
+1 IF Y=1
SET PRI="P^PRIMARY"
+2 IF Y=0
SET PRI="S^SECONDARY"
+3 SET $PIECE(REQI,"^",6)=$PIECE(PRI,"^",1)
+4 SET $PIECE(REQE,"^",6)=$PIECE(PRI,"^",2)
PPXIT ;--EXIT
+1 QUIT
ORD ;--Prompt for ordering resulting DIAGNOSIS
+1 NEW DIR,Y,X,SEQ
+2 SET SEQ=0
IF $DATA(PXBKY(DATA))
SET SEQ=+$ORDER(PXBKY(DATA,""))
+3 WRITE IOCUD,IOELALL,IOCUU
+4 SET DIR("A")="Is this Diagnosis Ordering or Resulting:"
+5 SET DIR("B")=$PIECE($GET(PXBKY(DATA,SEQ)),U,7)
+6 SET DIR("?")="Resulting and/or Ordering indicators are only entered if at least one of each diagnosis type exists."
+7 SET DIR(0)="SO^O:ORDERING;R:RESULTING;OR:BOTH O&R"
+8 DO ^DIR
IF $GET(DIRUT)
GOTO PPXIT
ORFIN ;--Finish off variables
+1 SET $PIECE(REQI,"^",7)=Y
+2 SET $PIECE(REQE,"^",7)=$SELECT(Y="O":"ORDERING",Y="R":"RESULTING",1:"BOTH O&R")
+3 QUIT
PRBLM ;--Prompt for Problem list
+1 NEW DIR,Y,X,VALL
+2 WRITE IOCUD,IOELALL,IOCUU
+3 DO WIN17^PXBCC(PXBCNT)
+4 SET DIR("?")="^S VALL=1,VALL=$$DOUBLE1^PXBGPL2(WHAT)"
+5 SET DIR("A")="Do you want this DIAGNOSIS added to the PROBLEM LIST? "
+6 SET DIR("B")="NO"
+7 SET DIR(0)="Y,A,O"
+8 DO ^DIR
+9 IF X="+"!(X="-")
SET DIR("?")="D DPOV4^PXBDPL(X)"
+10 IF $GET(DIRUT)
GOTO PPXIT
PRPFIN ;--Finish off variables
+1 KILL PXBKYPL,PXBSKYPL,PXBSAMPL,PXBCNTPL
+2 KILL ^TMP("PXBKYPL",$JOB),^TMP("PXBSAMPL",$JOB)
+3 SET PXBPRBLM=+Y
PRPXIT ;--EXIT
+1 QUIT
+2 ;
