PXBPPRV1 ;ISL/JVS - PROMPT FOR PROVIDER ;3/19/97
;;1.0;PCE PATIENT CARE ENCOUNTER;**11,19,27,88**;Aug 12, 1996
;
;
;
ACTIVE ;---CHECK TO SEE IF ACTIVE PROVIDER
;
N PROVIDER,VISIT,DIC,DR,DA,INACTIVE,OK,NOT,PROVEX,BDATA,ACTIVE
S PROVIDER=$P(REQI,"^",1) ;-Provider IEN
S PROVEX=$P(REQE,"^",1) ;-Provider External form
S VISIT=$P(IDATE,".",1) ;-Visit date Internal form
S DIC=200,DR=53.4,DA=PROVIDER,DIQ="INACTIVE",DIQ(0)="IN" D EN^DIQ1
I $D(INACTIVE),$G(INACTIVE(200,PROVIDER,53.4,"I"))<VISIT S NOT=1
S DIC=200,DR=9.2,DA=PROVIDER,DIQ="ACTIVE",DIQ(0)="IN" D EN^DIQ1
I $D(ACTIVE),$G(ACTIVE(200,PROVIDER,9.2,"I"))<VISIT S NOT=1
;---I $G(NOT) W !,IOEDEOP,IORVON,"--WARNING!-",PROVEX," was INACTIVE on the date of this encounter.",IORVOFF D HELP1^PXBUTL1("CON") R OK:DTIME
I $G(NOT) W !,IOEDEOP,IORVON,"--WARNING!-",PROVEX," was INACTIVE on the date of this encounter.",IORVOFF D PMPT
;---------3/17/97--PART OF FUTURE PATCH 27
I '$G(NOT) D
.N CLASS
.S CLASS=+$$GET^XUA4A72(PROVIDER,VISIT) I CLASS<0 D
..D RSET^PXBDREQ("PRV") S FPRI=1
..W !,IOEDEOP,IORVON,"--ERROR!--",PROVEX," does not have an ACTIVE person class.",IORVOFF D HELP1^PXBUTL1("CON") R OK:DTIME
;---------END 3/17/97
AXIT ;--EXIT AND KILL
K DIQ
Q
PMPT ;--PROMT FOR COMFIRMATION OF USING INACTIVE PORVIDER
S DIR("A")="Are you sure you want to select this provider? "
S DIR("B")="NO"
S DIR(0)="YA"
D ^DIR
I Y<1 D RSET^PXBDREQ("PRV")
Q
;
ADDM ;--------If Multiple entries have been entered
Q
;---NOT POSSIBLE TO ADD MULTIPLE PROVIDERS
;
DELM ;--------If Multiple deleting
;
N DELM,CNT,CPTPRV,PXBJ,BAD,PXBLEN,BDATA
S (NF,CNT)=0,PXBLEN=0 S $P(DELM,"^",1)=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,"^",7)=$O(PXBSKY(PXBPIECE,0)) ;-IEN
...S X=$P(PXBSAM(PXBPIECE),"^",1),DIC="^VA(200,",DIC(0)="ZM" D ^DIC
...S $P(REQI,"^",1)=+Y S CPTPRV=+Y K Y
...S $P(REQI,"^",2)=$P(PXBSAM(PXBPIECE),"^",2) K Y
...S GONE(PXBPIECE)=""
...D EN0^PXBSTOR(PXBVST,PATIENT,REQI,$G(PXMREQ))
...D EN1^PXKMAIN
...I $G(WHAT)["CPT" D DCPT^PXBSTOR1(CPTPRV,PXBVST)
..I PXBPIECE["-" D
...S PXBJ=0 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,"^",7)=$O(PXBSKY(PXBJ,0)) ;-IEN
....S X=$P(PXBSAM(PXBJ),"^",1),DIC="^VA(200,",DIC(0)="ZM" D ^DIC
....S $P(REQI,"^",1)=+Y S CPTPRV=+Y K Y
....S $P(REQI,"^",2)=$P(PXBSAM(PXBJ),"^",1)
....S GONE(PXBJ)=""
....D EN0^PXBSTOR(PXBVST,PATIENT,REQI,$G(PXMREQ))
....D EN1^PXKMAIN
....I $G(WHAT)["CPT" D DCPT^PXBSTOR1(CPTPRV,PXBVST)
K GONE
I $G(NF)&($D(BAD)) D Q
.S (BDATA,EDATA)="" F S BDATA=$O(BAD(BDATA)) Q:BDATA="" S EDATA=EDATA_BDATA_" "
.D WIN17^PXBCC(PXBCNT)
.W ! D HELP^PXBUTL0("PRVMD") 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
K PRVDR,PXBDPRV
Q
;
PRI ;--Prompt for primary secondary provider
;
N DIR,Y,X
I $G(FPRI) Q
W IOCUD,IOELALL,IOCUU
S DIR("A")="Is this the PRIMARY provider for this ENCOUNTER? "
S DIR("B")="YES"
S DIR("?")="One PRIMARY Provider 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,"^",2)=$P(PRI,"^",1)
S $P(REQE,"^",2)=$P(PRI,"^",2)
PPXIT ;--EXIT
Q
PXBPPRV1 ;ISL/JVS - PROMPT FOR PROVIDER ;3/19/97
+1 ;;1.0;PCE PATIENT CARE ENCOUNTER;**11,19,27,88**;Aug 12, 1996
+2 ;
+3 ;
+4 ;
ACTIVE ;---CHECK TO SEE IF ACTIVE PROVIDER
+1 ;
+2 NEW PROVIDER,VISIT,DIC,DR,DA,INACTIVE,OK,NOT,PROVEX,BDATA,ACTIVE
+3 ;-Provider IEN
SET PROVIDER=$PIECE(REQI,"^",1)
+4 ;-Provider External form
SET PROVEX=$PIECE(REQE,"^",1)
+5 ;-Visit date Internal form
SET VISIT=$PIECE(IDATE,".",1)
+6 SET DIC=200
SET DR=53.4
SET DA=PROVIDER
SET DIQ="INACTIVE"
SET DIQ(0)="IN"
DO EN^DIQ1
+7 IF $DATA(INACTIVE)
IF $GET(INACTIVE(200,PROVIDER,53.4,"I"))<VISIT
SET NOT=1
+8 SET DIC=200
SET DR=9.2
SET DA=PROVIDER
SET DIQ="ACTIVE"
SET DIQ(0)="IN"
DO EN^DIQ1
+9 IF $DATA(ACTIVE)
IF $GET(ACTIVE(200,PROVIDER,9.2,"I"))<VISIT
SET NOT=1
+10 ;---I $G(NOT) W !,IOEDEOP,IORVON,"--WARNING!-",PROVEX," was INACTIVE on the date of this encounter.",IORVOFF D HELP1^PXBUTL1("CON") R OK:DTIME
+11 IF $GET(NOT)
WRITE !,IOEDEOP,IORVON,"--WARNING!-",PROVEX," was INACTIVE on the date of this encounter.",IORVOFF
DO PMPT
+12 ;---------3/17/97--PART OF FUTURE PATCH 27
+13 IF '$GET(NOT)
Begin DoDot:1
+14 NEW CLASS
+15 SET CLASS=+$$GET^XUA4A72(PROVIDER,VISIT)
IF CLASS<0
Begin DoDot:2
+16 DO RSET^PXBDREQ("PRV")
SET FPRI=1
+17 WRITE !,IOEDEOP,IORVON,"--ERROR!--",PROVEX," does not have an ACTIVE person class.",IORVOFF
DO HELP1^PXBUTL1("CON")
READ OK:DTIME
End DoDot:2
End DoDot:1
+18 ;---------END 3/17/97
AXIT ;--EXIT AND KILL
+1 KILL DIQ
+2 QUIT
PMPT ;--PROMT FOR COMFIRMATION OF USING INACTIVE PORVIDER
+1 SET DIR("A")="Are you sure you want to select this provider? "
+2 SET DIR("B")="NO"
+3 SET DIR(0)="YA"
+4 DO ^DIR
+5 IF Y<1
DO RSET^PXBDREQ("PRV")
+6 QUIT
+7 ;
ADDM ;--------If Multiple entries have been entered
+1 QUIT
+2 ;---NOT POSSIBLE TO ADD MULTIPLE PROVIDERS
+3 ;
DELM ;--------If Multiple deleting
+1 ;
+2 NEW DELM,CNT,CPTPRV,PXBJ,BAD,PXBLEN,BDATA
+3 SET (NF,CNT)=0
SET PXBLEN=0
SET $PIECE(DELM,"^",1)=1
+4 IF $EXTRACT(DATA,1)="@"
SET DATA=$PIECE(DATA,"@",2)
SET NF=1
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 ;-IEN
SET $PIECE(REQI,"^",7)=$ORDER(PXBSKY(PXBPIECE,0))
+11 SET X=$PIECE(PXBSAM(PXBPIECE),"^",1)
SET DIC="^VA(200,"
SET DIC(0)="ZM"
DO ^DIC
+12 SET $PIECE(REQI,"^",1)=+Y
SET CPTPRV=+Y
KILL Y
+13 SET $PIECE(REQI,"^",2)=$PIECE(PXBSAM(PXBPIECE),"^",2)
KILL Y
+14 SET GONE(PXBPIECE)=""
+15 DO EN0^PXBSTOR(PXBVST,PATIENT,REQI,$GET(PXMREQ))
+16 DO EN1^PXKMAIN
+17 IF $GET(WHAT)["CPT"
DO DCPT^PXBSTOR1(CPTPRV,PXBVST)
End DoDot:3
+18 IF PXBPIECE["-"
Begin DoDot:3
+19 SET PXBJ=0
FOR PXBJ=$PIECE(PXBPIECE,"-",1):1:$PIECE(PXBPIECE,"-",2)
Begin DoDot:4
+20 IF $DATA(GONE(PXBJ))
QUIT
+21 IF PXBJ'>0!(PXBJ'<(PXBCNT+1))
SET BAD(PXBJ)=""
QUIT
+22 ;-IEN
SET $PIECE(REQI,"^",7)=$ORDER(PXBSKY(PXBJ,0))
+23 SET X=$PIECE(PXBSAM(PXBJ),"^",1)
SET DIC="^VA(200,"
SET DIC(0)="ZM"
DO ^DIC
+24 SET $PIECE(REQI,"^",1)=+Y
SET CPTPRV=+Y
KILL Y
+25 SET $PIECE(REQI,"^",2)=$PIECE(PXBSAM(PXBJ),"^",1)
+26 SET GONE(PXBJ)=""
+27 DO EN0^PXBSTOR(PXBVST,PATIENT,REQI,$GET(PXMREQ))
+28 DO EN1^PXKMAIN
+29 IF $GET(WHAT)["CPT"
DO DCPT^PXBSTOR1(CPTPRV,PXBVST)
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+30 KILL GONE
+31 IF $GET(NF)&($DATA(BAD))
Begin DoDot:1
+32 SET (BDATA,EDATA)=""
FOR
SET BDATA=$ORDER(BAD(BDATA))
IF BDATA=""
QUIT
SET EDATA=EDATA_BDATA_" "
+33 DO WIN17^PXBCC(PXBCNT)
+34 WRITE !
DO HELP^PXBUTL0("PRVMD")
WRITE !
+35 SET DIR(0)="E"
DO ^DIR
KILL DIR
+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 KILL PRVDR,PXBDPRV
+39 QUIT
+40 ;
PRI ;--Prompt for primary secondary provider
+1 ;
+2 NEW DIR,Y,X
+3 IF $GET(FPRI)
QUIT
+4 WRITE IOCUD,IOELALL,IOCUU
+5 SET DIR("A")="Is this the PRIMARY provider for this ENCOUNTER? "
+6 SET DIR("B")="YES"
+7 SET DIR("?")="One PRIMARY Provider must be established for each patient encounter. 'Yes' will mean PRIMARY and 'No' will mean SECONDARY."
+8 SET DIR(0)="Y,A,O"
+9 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,"^",2)=$PIECE(PRI,"^",1)
+4 SET $PIECE(REQE,"^",2)=$PIECE(PRI,"^",2)
PPXIT ;--EXIT
+1 QUIT
