PXBPPRV1 ;ISL/JVS - PROMPT FOR PROVIDER ; 5/31/07 5:10pm
;;1.0;PCE PATIENT CARE ENCOUNTER;**11,19,27,88,124,186,205**;Aug 12, 1996;Build 6
;
;
;
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
;
; begin patch *186*
;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
;
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 D
. D RSET^PXBDREQ("PRV") S FPRI=1
. W !,IOEDEOP,IORVON,"--ERROR!--",PROVEX," was TERMINATED before the date of this encounter.",IORVOFF D HELP1^PXBUTL1("CON") R OK:DTIME
; end patch *186*
;
;---------3/17/97--PART OF FUTURE PATCH 27
I '$G(NOT) D
.N CLASS
.S CLASS=$$GET^XUA4A72(PROVIDER,$P(VISIT,".")) I +CLASS<0 D ;PX*1.0*205 moved + from in front of $$ to in front of CLASS
..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
.I +CLASS'<0,$P(CLASS,U,7)="" D RSET^PXBDREQ("PRV") S FPRI=1 W !,IOEDEOP,IORVON,"--ERROR!--",PROVEX," does not have a VA CODE on PERSON CLASS.",IORVOFF D HELP1^PXBUTL1("CON") R OK:DTIME ;PX*1.0*205 added
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
...Q:+PXBPIECE'=PXBPIECE
...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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXBPPRV1 4388 printed Nov 22, 2024@17:37:13 Page 2
PXBPPRV1 ;ISL/JVS - PROMPT FOR PROVIDER ; 5/31/07 5:10pm
+1 ;;1.0;PCE PATIENT CARE ENCOUNTER;**11,19,27,88,124,186,205**;Aug 12, 1996;Build 6
+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 ;
+7 ; begin patch *186*
+8 ;S DIC=200,DR=53.4,DA=PROVIDER,DIQ="INACTIVE",DIQ(0)="IN" D EN^DIQ1
+9 ;I $D(INACTIVE),$G(INACTIVE(200,PROVIDER,53.4,"I"))<VISIT S NOT=1
+10 ;S DIC=200,DR=9.2,DA=PROVIDER,DIQ="ACTIVE",DIQ(0)="IN" D EN^DIQ1
+11 ;I $D(ACTIVE),$G(ACTIVE(200,PROVIDER,9.2,"I"))<VISIT S NOT=1
+12 ;---I $G(NOT) W !,IOEDEOP,IORVON,"--WARNING!-",PROVEX," was INACTIVE on the date of this encounter.",IORVOFF D HELP1^PXBUTL1("CON") R OK:DTIME
+13 ;I $G(NOT) W !,IOEDEOP,IORVON,"--WARNING!-",PROVEX," was INACTIVE on the date of this encounter.",IORVOFF D PMPT
+14 ;
+15 SET DIC=200
SET DR=9.2
SET DA=PROVIDER
SET DIQ="ACTIVE"
SET DIQ(0)="IN"
DO EN^DIQ1
+16 IF $DATA(ACTIVE)
IF $GET(ACTIVE(200,PROVIDER,9.2,"I"))'>VISIT
SET NOT=1
Begin DoDot:1
+17 DO RSET^PXBDREQ("PRV")
SET FPRI=1
+18 WRITE !,IOEDEOP,IORVON,"--ERROR!--",PROVEX," was TERMINATED before the date of this encounter.",IORVOFF
DO HELP1^PXBUTL1("CON")
READ OK:DTIME
End DoDot:1
+19 ; end patch *186*
+20 ;
+21 ;---------3/17/97--PART OF FUTURE PATCH 27
+22 IF '$GET(NOT)
Begin DoDot:1
+23 NEW CLASS
+24 ;PX*1.0*205 moved + from in front of $$ to in front of CLASS
SET CLASS=$$GET^XUA4A72(PROVIDER,$PIECE(VISIT,"."))
IF +CLASS<0
Begin DoDot:2
+25 DO RSET^PXBDREQ("PRV")
SET FPRI=1
+26 WRITE !,IOEDEOP,IORVON,"--ERROR!--",PROVEX," does not have an ACTIVE person class.",IORVOFF
DO HELP1^PXBUTL1("CON")
READ OK:DTIME
End DoDot:2
+27 ;---------END 3/17/97
+28 ;PX*1.0*205 added
IF +CLASS'<0
IF $PIECE(CLASS,U,7)=""
DO RSET^PXBDREQ("PRV")
SET FPRI=1
WRITE !,IOEDEOP,IORVON,"--ERROR!--",PROVEX," does not have a VA CODE on PERSON CLASS.",IORVOFF
DO HELP1^PXBUTL1("CON")
READ OK:DTIME
End DoDot:1
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 if +PXBPIECE'=PXBPIECE
QUIT
+11 ;-IEN
SET $PIECE(REQI,"^",7)=$ORDER(PXBSKY(PXBPIECE,0))
+12 SET X=$PIECE(PXBSAM(PXBPIECE),"^",1)
SET DIC="^VA(200,"
SET DIC(0)="ZM"
DO ^DIC
+13 SET $PIECE(REQI,"^",1)=+Y
SET CPTPRV=+Y
KILL Y
+14 SET $PIECE(REQI,"^",2)=$PIECE(PXBSAM(PXBPIECE),"^",2)
KILL Y
+15 SET GONE(PXBPIECE)=""
+16 DO EN0^PXBSTOR(PXBVST,PATIENT,REQI,$GET(PXMREQ))
+17 DO EN1^PXKMAIN
+18 IF $GET(WHAT)["CPT"
DO DCPT^PXBSTOR1(CPTPRV,PXBVST)
End DoDot:3
+19 IF PXBPIECE["-"
Begin DoDot:3
+20 SET PXBJ=0
FOR PXBJ=$PIECE(PXBPIECE,"-",1):1:$PIECE(PXBPIECE,"-",2)
Begin DoDot:4
+21 IF $DATA(GONE(PXBJ))
QUIT
+22 IF PXBJ'>0!(PXBJ'<(PXBCNT+1))
SET BAD(PXBJ)=""
QUIT
+23 ;-IEN
SET $PIECE(REQI,"^",7)=$ORDER(PXBSKY(PXBJ,0))
+24 SET X=$PIECE(PXBSAM(PXBJ),"^",1)
SET DIC="^VA(200,"
SET DIC(0)="ZM"
DO ^DIC
+25 SET $PIECE(REQI,"^",1)=+Y
SET CPTPRV=+Y
KILL Y
+26 SET $PIECE(REQI,"^",2)=$PIECE(PXBSAM(PXBJ),"^",1)
+27 SET GONE(PXBJ)=""
+28 DO EN0^PXBSTOR(PXBVST,PATIENT,REQI,$GET(PXMREQ))
+29 DO EN1^PXKMAIN
+30 IF $GET(WHAT)["CPT"
DO DCPT^PXBSTOR1(CPTPRV,PXBVST)
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+31 KILL GONE
+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 DO WIN17^PXBCC(PXBCNT)
+35 WRITE !
DO HELP^PXBUTL0("PRVMD")
WRITE !
+36 SET DIR(0)="E"
DO ^DIR
KILL DIR
+37 if Y=1
SET DATA="^P"
if Y=0!(Y="")
SET DATA="^"
KILL Y
End DoDot:1
QUIT
+38 IF $GET(NF)&('$DATA(BAD))
SET DATA="^P"
QUIT
+39 KILL PRVDR,PXBDPRV
+40 QUIT
+41 ;
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
