PXBPPOV1 ;ISL/JVS,ESW - PROMPT POV ; 1/14/03 1:42pm
;;1.0;PCE PATIENT CARE ENCOUNTER;**11,112**;Aug 12, 1996
;
;
;
;
;
ADDM ;--------If Multiple POV entries have been entered.
;
;
;
N OK,PXBLEN,BDATA
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 X=PXBPIECE,DIC=80,DIC(0)="IMZ" D ^DIC
..I Y=-1 S BAD(+$G(PXBPIECE))="" Q
..S $P(REQI,"^",5)=+Y
..S PXBNPOV(PXBPIECE)=""
..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 DELM,PXBJ,BAD,PXBLEN,BDATA
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),"^",1),DIC=80,DIC(0)="IZM" D ^DIC
...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),"^",1),DIC=80,DIC(0)="IZM" D ^DIC
....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
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
;
PXBPPOV1 ;ISL/JVS,ESW - PROMPT POV ; 1/14/03 1:42pm
+1 ;;1.0;PCE PATIENT CARE ENCOUNTER;**11,112**;Aug 12, 1996
+2 ;
+3 ;
+4 ;
+5 ;
+6 ;
ADDM ;--------If Multiple POV entries have been entered.
+1 ;
+2 ;
+3 ;
+4 NEW OK,PXBLEN,BDATA
+5 DO WIN17^PXBCC(PXBCNT)
+6 SET NF=0
SET PXBLEN=0
+7 IF DATA[","
IF $EXTRACT(DATA,1)'["@"
SET NF=1
Begin DoDot:1
+8 SET PXBLEN=$LENGTH(DATA,",")
FOR PXI=1:1:PXBLEN
SET PXBPIECE=$PIECE(DATA,",",PXI)
Begin DoDot:2
+9 SET X=PXBPIECE
SET DIC=80
SET DIC(0)="IMZ"
DO ^DIC
+10 IF Y=-1
SET BAD(+$GET(PXBPIECE))=""
QUIT
+11 SET $PIECE(REQI,"^",5)=+Y
+12 SET PXBNPOV(PXBPIECE)=""
+13 DO EN0^PXBSTOR(PXBVST,PATIENT,REQI)
+14 DO EN1^PXKMAIN
+15 DO RSET^PXBDREQ("POV")
End DoDot:2
End DoDot:1
+16 IF $GET(NF)&($DATA(BAD))
Begin DoDot:1
+17 SET (BDATA,EDATA)=""
FOR
SET BDATA=$ORDER(BAD(BDATA))
IF BDATA=""
QUIT
SET EDATA=EDATA_BDATA_" "
+18 WRITE !
DO HELP^PXBUTL0("CPTM")
WRITE !
+19 SET DIR(0)="E"
DO ^DIR
KILL DIR,DIRUT
+20 IF Y=1
SET DATA="^P"
IF Y=0!(Y="")
SET DATA="^"
KILL Y
End DoDot:1
QUIT
+21 IF $GET(NF)&('$DATA(BAD))
SET DATA="^P"
QUIT
+22 ;
+23 QUIT
+24 ;
DELM ;--------If Multiple deleting
+1 NEW DELM,PXBJ,BAD,PXBLEN,BDATA
+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),"^",1)
SET DIC=80
SET DIC(0)="IZM"
DO ^DIC
+11 SET $PIECE(REQI,"^",5)=+Y
KILL Y
+12 SET GONE(PXBPIECE)=""
+13 DO EN0^PXBSTOR(PXBVST,PATIENT,REQI)
+14 DO EN1^PXKMAIN
End DoDot:3
+15 IF PXBPIECE["-"
Begin DoDot:3
+16 FOR PXBJ=$PIECE(PXBPIECE,"-",1):1:$PIECE(PXBPIECE,"-",2)
Begin DoDot:4
+17 IF $DATA(GONE(PXBJ))
QUIT
+18 IF PXBJ'>0!(PXBJ'<(PXBCNT+1))
SET BAD(PXBJ)=""
QUIT
+19 ;-IEN
SET $PIECE(REQI,"^",9)=$ORDER(PXBSKY(PXBJ,0))
+20 SET X=$PIECE(PXBSAM(PXBJ),"^",1)
SET DIC=80
SET DIC(0)="IZM"
DO ^DIC
+21 SET $PIECE(REQI,"^",5)=+Y
KILL Y
+22 SET GONE(PXBJ)=""
+23 DO EN0^PXBSTOR(PXBVST,PATIENT,REQI)
+24 DO EN1^PXKMAIN
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+25 KILL GONE
+26 IF $GET(NF)&($DATA(BAD))
Begin DoDot:1
+27 SET (BDATA,EDATA)=""
FOR
SET BDATA=$ORDER(BAD(BDATA))
IF BDATA=""
QUIT
SET EDATA=EDATA_BDATA_" "
+28 WRITE !
DO HELP^PXBUTL0("CPTMD")
WRITE !
+29 SET DIR(0)="E"
DO ^DIR
KILL DIR
+30 IF Y=1
SET DATA="^P"
IF Y=0!(Y="")
SET DATA="^"
KILL Y
End DoDot:1
QUIT
+31 IF $GET(NF)&('$DATA(BAD))
SET DATA="^P"
QUIT
+32 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
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 ;
