Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PXBPPRV1

PXBPPRV1.m

Go to the documentation of this file.
  1. 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
  1. ;
  1. ;
  1. ;
  1. ACTIVE ;---CHECK TO SEE IF ACTIVE PROVIDER
  1. ;
  1. N PROVIDER,VISIT,DIC,DR,DA,INACTIVE,OK,NOT,PROVEX,BDATA,ACTIVE
  1. S PROVIDER=$P(REQI,"^",1) ;-Provider IEN
  1. S PROVEX=$P(REQE,"^",1) ;-Provider External form
  1. S VISIT=$P(IDATE,".",1) ;-Visit date Internal form
  1. ;
  1. ; begin patch *186*
  1. ;S DIC=200,DR=53.4,DA=PROVIDER,DIQ="INACTIVE",DIQ(0)="IN" D EN^DIQ1
  1. ;I $D(INACTIVE),$G(INACTIVE(200,PROVIDER,53.4,"I"))<VISIT S NOT=1
  1. ;S DIC=200,DR=9.2,DA=PROVIDER,DIQ="ACTIVE",DIQ(0)="IN" D EN^DIQ1
  1. ;I $D(ACTIVE),$G(ACTIVE(200,PROVIDER,9.2,"I"))<VISIT S NOT=1
  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
  1. ;I $G(NOT) W !,IOEDEOP,IORVON,"--WARNING!-",PROVEX," was INACTIVE on the date of this encounter.",IORVOFF D PMPT
  1. ;
  1. S DIC=200,DR=9.2,DA=PROVIDER,DIQ="ACTIVE",DIQ(0)="IN" D EN^DIQ1
  1. I $D(ACTIVE),$G(ACTIVE(200,PROVIDER,9.2,"I"))'>VISIT S NOT=1 D
  1. . D RSET^PXBDREQ("PRV") S FPRI=1
  1. . W !,IOEDEOP,IORVON,"--ERROR!--",PROVEX," was TERMINATED before the date of this encounter.",IORVOFF D HELP1^PXBUTL1("CON") R OK:DTIME
  1. ; end patch *186*
  1. ;
  1. ;---------3/17/97--PART OF FUTURE PATCH 27
  1. I '$G(NOT) D
  1. .N CLASS
  1. .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
  1. ..D RSET^PXBDREQ("PRV") S FPRI=1
  1. ..W !,IOEDEOP,IORVON,"--ERROR!--",PROVEX," does not have an ACTIVE person class.",IORVOFF D HELP1^PXBUTL1("CON") R OK:DTIME
  1. .;---------END 3/17/97
  1. .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
  1. AXIT ;--EXIT AND KILL
  1. K DIQ
  1. Q
  1. PMPT ;--PROMT FOR COMFIRMATION OF USING INACTIVE PORVIDER
  1. S DIR("A")="Are you sure you want to select this provider? "
  1. S DIR("B")="NO"
  1. S DIR(0)="YA"
  1. D ^DIR
  1. I Y<1 D RSET^PXBDREQ("PRV")
  1. Q
  1. ;
  1. ADDM ;--------If Multiple entries have been entered
  1. Q
  1. ;---NOT POSSIBLE TO ADD MULTIPLE PROVIDERS
  1. ;
  1. DELM ;--------If Multiple deleting
  1. ;
  1. N DELM,CNT,CPTPRV,PXBJ,BAD,PXBLEN,BDATA
  1. S (NF,CNT)=0,PXBLEN=0 S $P(DELM,"^",1)=1
  1. I $E(DATA,1)="@" S DATA=$P(DATA,"@",2),NF=1 D
  1. .S PXBLEN=$L(DATA,",") F PXI=1:1:PXBLEN S PXBPIECE=$P(DATA,",",PXI) D
  1. ..I PXBPIECE'["-"&(PXBPIECE'>0!(PXBPIECE'<(PXBCNT+1))) S BAD(+$G(PXBPIECE))="" Q
  1. ..I PXBPIECE'["-" D
  1. ...I $D(GONE(PXBPIECE)) Q
  1. ...Q:PXBPIECE'?.N
  1. ...Q:+PXBPIECE'=PXBPIECE
  1. ...S $P(REQI,"^",7)=$O(PXBSKY(PXBPIECE,0)) ;-IEN
  1. ...S X=$P(PXBSAM(PXBPIECE),"^",1),DIC="^VA(200,",DIC(0)="ZM" D ^DIC
  1. ...S $P(REQI,"^",1)=+Y S CPTPRV=+Y K Y
  1. ...S $P(REQI,"^",2)=$P(PXBSAM(PXBPIECE),"^",2) K Y
  1. ...S GONE(PXBPIECE)=""
  1. ...D EN0^PXBSTOR(PXBVST,PATIENT,REQI,$G(PXMREQ))
  1. ...D EN1^PXKMAIN
  1. ...I $G(WHAT)["CPT" D DCPT^PXBSTOR1(CPTPRV,PXBVST)
  1. ..I PXBPIECE["-" D
  1. ...S PXBJ=0 F PXBJ=$P(PXBPIECE,"-",1):1:$P(PXBPIECE,"-",2) D
  1. ....I $D(GONE(PXBJ)) Q
  1. ....I PXBJ'>0!(PXBJ'<(PXBCNT+1)) S BAD(PXBJ)="" Q
  1. ....S $P(REQI,"^",7)=$O(PXBSKY(PXBJ,0)) ;-IEN
  1. ....S X=$P(PXBSAM(PXBJ),"^",1),DIC="^VA(200,",DIC(0)="ZM" D ^DIC
  1. ....S $P(REQI,"^",1)=+Y S CPTPRV=+Y K Y
  1. ....S $P(REQI,"^",2)=$P(PXBSAM(PXBJ),"^",1)
  1. ....S GONE(PXBJ)=""
  1. ....D EN0^PXBSTOR(PXBVST,PATIENT,REQI,$G(PXMREQ))
  1. ....D EN1^PXKMAIN
  1. ....I $G(WHAT)["CPT" D DCPT^PXBSTOR1(CPTPRV,PXBVST)
  1. K GONE
  1. I $G(NF)&($D(BAD)) D Q
  1. .S (BDATA,EDATA)="" F S BDATA=$O(BAD(BDATA)) Q:BDATA="" S EDATA=EDATA_BDATA_" "
  1. .D WIN17^PXBCC(PXBCNT)
  1. .W ! D HELP^PXBUTL0("PRVMD") W !
  1. .S DIR(0)="E" D ^DIR K DIR
  1. .S:Y=1 DATA="^P" S:Y=0!(Y="") DATA="^" K Y
  1. I $G(NF)&('$D(BAD)) S DATA="^P" Q
  1. K PRVDR,PXBDPRV
  1. Q
  1. ;
  1. PRI ;--Prompt for primary secondary provider
  1. ;
  1. N DIR,Y,X
  1. I $G(FPRI) Q
  1. W IOCUD,IOELALL,IOCUU
  1. S DIR("A")="Is this the PRIMARY provider for this ENCOUNTER? "
  1. S DIR("B")="YES"
  1. S DIR("?")="One PRIMARY Provider must be established for each patient encounter. 'Yes' will mean PRIMARY and 'No' will mean SECONDARY."
  1. S DIR(0)="Y,A,O"
  1. D ^DIR I $G(DIRUT) G PPXIT
  1. PPFIN ;--Finish off variables
  1. I Y=1 S PRI="P^PRIMARY"
  1. I Y=0 S PRI="S^SECONDARY"
  1. S $P(REQI,"^",2)=$P(PRI,"^",1)
  1. S $P(REQE,"^",2)=$P(PRI,"^",2)
  1. PPXIT ;--EXIT
  1. Q