- 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 Jan 18, 2025@03:28:12 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