PXBPSTP1 ;ISL/JVS - STOP CODE,ACTIVE,MULTIPLE ADD/DELETE ;7/24/96 08:24
;;1.0;PCE PATIENT CARE ENCOUNTER;;Aug 12, 1996
;
;
;
ACTIVE(REQI,REQE) ;---Check to see if stop code is active on visit date
N STOPI,STOPE,VISIT,DR,DA,INACTIVE,OK
S NOT=0
S STOPI=$P(REQI,"^",10) ;--STOP CODE IEN IN STOP CODE FILE
S STOPE=$P(REQE,"^",10) ;--STOP CODE EXTERNAL VALUE
S VISIT=$P(IDATE,".",1) ;--VISIT DATE INTERNAL FORM
S DIC=40.7,DR=2,DA=STOPI,DIQ="INACTIVE",DIQ(0)="IN" D EN^DIQ1
I $D(INACTIVE),$G(INACTIVE(40.7,2,"I"))<VISIT S NOT=1
I $G(NOT) W !,IOEDEOP,IORVON,"--INACTIVE!-",STOPE," was INACTIVE on the date of this ENCOUNTER.",IORVOFF
Q NOT
ADDM ;--------If Multiple STOP CODE entries have been entered.
;
N OK,PXBLEN,BAD,BDATA
S NF=0,PXBLEN=0
I DATA'["," Q
I $P(DATA,",",1)'>0,$P(DATA,",",1)'<(PXBCNT+(1)) Q
I DATA[",",$E(DATA,1)'["@" S NF=1 D WAIT^DICD D
.S PXBLEN=$L(DATA,",") F PXI=1:1:PXBLEN S PXBPIECE=$P(DATA,",",PXI) D
..S X=PXBPIECE,DIC=40.7,DIC(0)="IMZ" D ^DIC
..I Y=-1 S BAD(+$G(PXBPIECE))="" Q
..S $P(REQI,"^",10)=+Y
..S PXBNSTP(PXBPIECE)=""
..S PXBNSTP($P(Y,"^",2))=""
..D STP^PXBSTOR1
..D RSET^PXBDREQ("STP")
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="^S" S:Y=0!(Y="") DATA="^" K Y
I $G(NF)&('$D(BAD)) S DATA="^S" Q
;
Q
;
DELM ;--------If Multiple deleting
I DATA'["@" Q
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 WAIT^DICD 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 $P(REQI,"^",10)="@"
...S $P(REQI,"^",11)=$O(PXBSKY(PXBPIECE,0))
...S GONE(PXBPIECE)=""
...D STP^PXBSTOR1
..I PXBPIECE["-" D
...I DATA'?.N1"-".N S BAD(PXBPIECE)="" Q
...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,"^",10)="@"
....S $P(REQI,"^",11)=$O(PXBSKY(PXBJ,0))
....S GONE(PXBJ)=""
....D STP^PXBSTOR1
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="^S" S:Y=0!(Y="") DATA="^" K Y
I $G(NF)&('$D(BAD)) S DATA="^S" Q
Q
;
PROMPT(PXBCNT) ;--DETERMINE WHERE PROMPT SHOULD START
;
N START,DIFF
S START=$G(^TMP("PXBDSTP",$J,"START"))
S DIFF=PXBCNT-START
I DIFF<10 S LINE=DIFF+5
I DIFF>9 S LINE=15
Q LINE
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXBPSTP1 2801 printed Nov 22, 2024@17:37:15 Page 2
PXBPSTP1 ;ISL/JVS - STOP CODE,ACTIVE,MULTIPLE ADD/DELETE ;7/24/96 08:24
+1 ;;1.0;PCE PATIENT CARE ENCOUNTER;;Aug 12, 1996
+2 ;
+3 ;
+4 ;
ACTIVE(REQI,REQE) ;---Check to see if stop code is active on visit date
+1 NEW STOPI,STOPE,VISIT,DR,DA,INACTIVE,OK
+2 SET NOT=0
+3 ;--STOP CODE IEN IN STOP CODE FILE
SET STOPI=$PIECE(REQI,"^",10)
+4 ;--STOP CODE EXTERNAL VALUE
SET STOPE=$PIECE(REQE,"^",10)
+5 ;--VISIT DATE INTERNAL FORM
SET VISIT=$PIECE(IDATE,".",1)
+6 SET DIC=40.7
SET DR=2
SET DA=STOPI
SET DIQ="INACTIVE"
SET DIQ(0)="IN"
DO EN^DIQ1
+7 IF $DATA(INACTIVE)
IF $GET(INACTIVE(40.7,2,"I"))<VISIT
SET NOT=1
+8 IF $GET(NOT)
WRITE !,IOEDEOP,IORVON,"--INACTIVE!-",STOPE," was INACTIVE on the date of this ENCOUNTER.",IORVOFF
+9 QUIT NOT
ADDM ;--------If Multiple STOP CODE entries have been entered.
+1 ;
+2 NEW OK,PXBLEN,BAD,BDATA
+3 SET NF=0
SET PXBLEN=0
+4 IF DATA'[","
QUIT
+5 IF $PIECE(DATA,",",1)'>0
IF $PIECE(DATA,",",1)'<(PXBCNT+(1))
QUIT
+6 IF DATA[","
IF $EXTRACT(DATA,1)'["@"
SET NF=1
DO WAIT^DICD
Begin DoDot:1
+7 SET PXBLEN=$LENGTH(DATA,",")
FOR PXI=1:1:PXBLEN
SET PXBPIECE=$PIECE(DATA,",",PXI)
Begin DoDot:2
+8 SET X=PXBPIECE
SET DIC=40.7
SET DIC(0)="IMZ"
DO ^DIC
+9 IF Y=-1
SET BAD(+$GET(PXBPIECE))=""
QUIT
+10 SET $PIECE(REQI,"^",10)=+Y
+11 SET PXBNSTP(PXBPIECE)=""
+12 SET PXBNSTP($PIECE(Y,"^",2))=""
+13 DO STP^PXBSTOR1
+14 DO RSET^PXBDREQ("STP")
End DoDot:2
End DoDot:1
+15 IF $GET(NF)&($DATA(BAD))
Begin DoDot:1
+16 SET (BDATA,EDATA)=""
FOR
SET BDATA=$ORDER(BAD(BDATA))
if BDATA=""
QUIT
SET EDATA=EDATA_BDATA_" "
+17 WRITE !
DO HELP^PXBUTL0("CPTM")
WRITE !
+18 SET DIR(0)="E"
DO ^DIR
KILL DIR,DIRUT
+19 if Y=1
SET DATA="^S"
if Y=0!(Y="")
SET DATA="^"
KILL Y
End DoDot:1
QUIT
+20 IF $GET(NF)&('$DATA(BAD))
SET DATA="^S"
QUIT
+21 ;
+22 QUIT
+23 ;
DELM ;--------If Multiple deleting
+1 IF DATA'["@"
QUIT
+2 NEW DELM,PXBJ,BAD,PXBLEN,BDATA
+3 SET NF=0
SET PXBLEN=0
SET $PIECE(DELM,"^",3)=1
+4 IF $EXTRACT(DATA,1)="@"
SET DATA=$PIECE(DATA,"@",2)
SET NF=1
DO WAIT^DICD
Begin DoDot:1
+5 SET PXBLEN=$LENGTH(DATA,",")
FOR PXI=1:1:PXBLEN
SET PXBPIECE=$PIECE(DATA,",",PXI)
Begin DoDot:2
+6 IF PXBPIECE'["-"&(PXBPIECE'>0!(PXBPIECE'<(PXBCNT+1)))
SET BAD(+$GET(PXBPIECE))=""
QUIT
+7 IF PXBPIECE'["-"
Begin DoDot:3
+8 IF $DATA(GONE(PXBPIECE))
QUIT
+9 if PXBPIECE'?.N
QUIT
+10 ;S $P(REQI,"^",9)=$O(PXBSKY(PXBPIECE,0)) ;-IEN
+11 SET $PIECE(REQI,"^",10)="@"
+12 SET $PIECE(REQI,"^",11)=$ORDER(PXBSKY(PXBPIECE,0))
+13 SET GONE(PXBPIECE)=""
+14 DO STP^PXBSTOR1
End DoDot:3
+15 IF PXBPIECE["-"
Begin DoDot:3
+16 IF DATA'?.N1"-".N
SET BAD(PXBPIECE)=""
QUIT
+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 SET $PIECE(REQI,"^",10)="@"
+21 SET $PIECE(REQI,"^",11)=$ORDER(PXBSKY(PXBJ,0))
+22 SET GONE(PXBJ)=""
+23 DO STP^PXBSTOR1
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+24 KILL GONE
+25 IF $GET(NF)&($DATA(BAD))
Begin DoDot:1
+26 SET (BDATA,EDATA)=""
FOR
SET BDATA=$ORDER(BAD(BDATA))
if BDATA=""
QUIT
SET EDATA=EDATA_BDATA_" "
+27 WRITE !
DO HELP^PXBUTL0("CPTMD")
WRITE !
+28 SET DIR(0)="E"
DO ^DIR
KILL DIR
+29 if Y=1
SET DATA="^S"
if Y=0!(Y="")
SET DATA="^"
KILL Y
End DoDot:1
QUIT
+30 IF $GET(NF)&('$DATA(BAD))
SET DATA="^S"
QUIT
+31 QUIT
+32 ;
PROMPT(PXBCNT) ;--DETERMINE WHERE PROMPT SHOULD START
+1 ;
+2 NEW START,DIFF
+3 SET START=$GET(^TMP("PXBDSTP",$JOB,"START"))
+4 SET DIFF=PXBCNT-START
+5 IF DIFF<10
SET LINE=DIFF+5
+6 IF DIFF>9
SET LINE=15
+7 QUIT LINE
+8 ;
