PXBSTOR1 ;ISL/JVS - REMOVE THE DELETED PROVIDER FROM CPT'S ;2/23/04 9:41am
;;1.0;PCE PATIENT CARE ENCOUNTER;**88,124**;Aug 12, 1996
;
;
;
;
DCPT(CPTPRV,PXBVST) ;---ENTRY POINT
;CPTPRV=IEN of Provider to be removed
;PXBVST=VISIT of the encounter
;
;
Q:'$D(CPTPRV) Q:'$D(PXBVST)
;
K ^TMP("PXK",$J)
N IEN
S IEN=0 F S IEN=$O(^AUPNVCPT("AD",PXBVST,IEN)) Q:IEN="" D
.I $D(^AUPNVCPT(IEN,12)),$P(^AUPNVCPT(IEN,12),"^",4)=CPTPRV D CHANGE
Q
CHANGE ;--Remove the Provider from the CPT code
;
I '$D(^TMP("PXBSTOR",$J,"SEQ")) S SEQ=1
I $D(^TMP("PXBSTOR",$J,"SEQ")) S SEQ=^TMP("PXBSTOR",$J,"SEQ")
;------CHANGE SOURCE TO MATCH THAT SENT IN -********-
S ^TMP("PXK",$J,"SOR")=$O(^PX(839.7,"B","SD/PCE-INTERFACE-PROMPTS",0))
;-------------
S ^TMP("PXK",$J,"VST",1,"IEN")=PXBVST
S ^TMP("PXK",$J,"VST",1,0,"AFTER")=$G(^AUPNVSIT(PXBVST,0))
S ^TMP("PXK",$J,"VST",1,0,"BEFORE")=$G(^AUPNVSIT(PXBVST,0))
;
S (CPTBEF,CPTAFT)=$G(^AUPNVCPT(IEN,0))
S (CPTBEF12,CPTAFT12)=$G(^AUPNVCPT(IEN,12))
S $P(CPTAFT12,"^",4)="@"
;
S SEQ=SEQ+(1)
;
S ^TMP("PXK",$J,"CPT",SEQ,0,"AFTER")=CPTAFT
S ^TMP("PXK",$J,"CPT",SEQ,0,"BEFORE")=CPTBEF
S ^TMP("PXK",$J,"CPT",SEQ,12,"AFTER")=CPTAFT12
S ^TMP("PXK",$J,"CPT",SEQ,12,"BEFORE")=CPTBEF12
S ^TMP("PXK",$J,"CPT",SEQ,"IEN")=IEN
;
;
;
D EN1^PXKMAIN
K ^TMP("PXK",$J)
;
;
Q
STP ;--AMIS STOP CODES
;--STOP CODE ARE ON PIECE 10 AND 11 IS THE VISIT
Q:'$D(REQI)
N SOURCE
S SOURCE=$O(^PX(839.7,"B","SD/PCE-INTERFACE-PROMPTS",0))
S STOPI=$P(REQI,"^",10)
S SECVSIT=$P(REQI,"^",11)
S VISIT=+$$STOPCODE^PXUTLSTP(SOURCE,STOPI,PXBVST,SECVSIT)
Q
;
SET() ;--SET IENS OF EACH FILE
S PRVIEN=$P(REQI,"^",7) I PRVIEN]"" D
.S PRVBEF=$G(^AUPNVPRV($P(REQI,"^",7),0))
.S PRVBEF12=$G(^AUPNVPRV($P(REQI,"^",7),12))
.S PRVBF812=$G(^AUPNVPRV($P(REQI,"^",7),812))
E S (PRVBEF,PRVBEF12,PRVBF812)=""
S CPTIEN=$P(REQI,"^",8)
I CPTIEN]"" D
.S CPTBEF=$G(^AUPNVCPT($P(REQI,"^",8),0))
.;Build array for cpt modifiers
.N SUBIEN
.S SUBIEN=0
.F S SUBIEN=$O(^AUPNVCPT($P(REQI,"^",8),1,SUBIEN)) Q:'SUBIEN D
..S CPTBEF1(SUBIEN)=$G(^AUPNVCPT($P(REQI,"^",8),1,SUBIEN,0))
.S CPTBEF12=$G(^AUPNVCPT($P(REQI,"^",8),12))
.S CPTBF812=$G(^AUPNVCPT($P(REQI,"^",8),812))
E S (CPTBEF,CPTBEF12,CPTBF812)=""
S POVIEN=$P(REQI,"^",9) I POVIEN]"" D
.S POVBEF=$G(^AUPNVPOV($P(REQI,"^",9),0))
.S POVBEF12=$G(^AUPNVPOV($P(REQI,"^",9),12))
.S POVBEF17=$G(^AUPNVPOV($P(REQI,"^",9),17))
.S POVBF812=$G(^AUPNVPOV($P(REQI,"^",9),812))
.S POVBF800=$G(^AUPNVPOV($P(REQI,"^",9),800)) ;PX124
E S (POVBEF,POVBEF12,POVBEF17,POVBF812,POVBF800)=""
;
MISC ;--SET MISCELLANEOUS NODES
;--*** CONDITION THE SOURCE
I '$G(SOURCE) S ^TMP("PXK",$J,"SOR")=$O(^PX(839.7,"B","SD/PCE-INTERFACE-PROMPTS",0))
;
S ^TMP("PXK",$J,"VST",1,"IEN")=PXBVST
S ^TMP("PXK",$J,"VST",1,0,"AFTER")=$G(^AUPNVSIT(PXBVST,0))
S ^TMP("PXK",$J,"VST",1,0,"BEFORE")=$G(^AUPNVSIT(PXBVST,0))
;
Q $G(^TMP("PXBSTOR",$J,"SEQ"),1)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXBSTOR1 3001 printed Apr 09, 2024@21:33:07 Page 2
PXBSTOR1 ;ISL/JVS - REMOVE THE DELETED PROVIDER FROM CPT'S ;2/23/04 9:41am
+1 ;;1.0;PCE PATIENT CARE ENCOUNTER;**88,124**;Aug 12, 1996
+2 ;
+3 ;
+4 ;
+5 ;
DCPT(CPTPRV,PXBVST) ;---ENTRY POINT
+1 ;CPTPRV=IEN of Provider to be removed
+2 ;PXBVST=VISIT of the encounter
+3 ;
+4 ;
+5 if '$DATA(CPTPRV)
QUIT
if '$DATA(PXBVST)
QUIT
+6 ;
+7 KILL ^TMP("PXK",$JOB)
+8 NEW IEN
+9 SET IEN=0
FOR
SET IEN=$ORDER(^AUPNVCPT("AD",PXBVST,IEN))
if IEN=""
QUIT
Begin DoDot:1
+10 IF $DATA(^AUPNVCPT(IEN,12))
IF $PIECE(^AUPNVCPT(IEN,12),"^",4)=CPTPRV
DO CHANGE
End DoDot:1
+11 QUIT
CHANGE ;--Remove the Provider from the CPT code
+1 ;
+2 IF '$DATA(^TMP("PXBSTOR",$JOB,"SEQ"))
SET SEQ=1
+3 IF $DATA(^TMP("PXBSTOR",$JOB,"SEQ"))
SET SEQ=^TMP("PXBSTOR",$JOB,"SEQ")
+4 ;------CHANGE SOURCE TO MATCH THAT SENT IN -********-
+5 SET ^TMP("PXK",$JOB,"SOR")=$ORDER(^PX(839.7,"B","SD/PCE-INTERFACE-PROMPTS",0))
+6 ;-------------
+7 SET ^TMP("PXK",$JOB,"VST",1,"IEN")=PXBVST
+8 SET ^TMP("PXK",$JOB,"VST",1,0,"AFTER")=$GET(^AUPNVSIT(PXBVST,0))
+9 SET ^TMP("PXK",$JOB,"VST",1,0,"BEFORE")=$GET(^AUPNVSIT(PXBVST,0))
+10 ;
+11 SET (CPTBEF,CPTAFT)=$GET(^AUPNVCPT(IEN,0))
+12 SET (CPTBEF12,CPTAFT12)=$GET(^AUPNVCPT(IEN,12))
+13 SET $PIECE(CPTAFT12,"^",4)="@"
+14 ;
+15 SET SEQ=SEQ+(1)
+16 ;
+17 SET ^TMP("PXK",$JOB,"CPT",SEQ,0,"AFTER")=CPTAFT
+18 SET ^TMP("PXK",$JOB,"CPT",SEQ,0,"BEFORE")=CPTBEF
+19 SET ^TMP("PXK",$JOB,"CPT",SEQ,12,"AFTER")=CPTAFT12
+20 SET ^TMP("PXK",$JOB,"CPT",SEQ,12,"BEFORE")=CPTBEF12
+21 SET ^TMP("PXK",$JOB,"CPT",SEQ,"IEN")=IEN
+22 ;
+23 ;
+24 ;
+25 DO EN1^PXKMAIN
+26 KILL ^TMP("PXK",$JOB)
+27 ;
+28 ;
+29 QUIT
STP ;--AMIS STOP CODES
+1 ;--STOP CODE ARE ON PIECE 10 AND 11 IS THE VISIT
+2 if '$DATA(REQI)
QUIT
+3 NEW SOURCE
+4 SET SOURCE=$ORDER(^PX(839.7,"B","SD/PCE-INTERFACE-PROMPTS",0))
+5 SET STOPI=$PIECE(REQI,"^",10)
+6 SET SECVSIT=$PIECE(REQI,"^",11)
+7 SET VISIT=+$$STOPCODE^PXUTLSTP(SOURCE,STOPI,PXBVST,SECVSIT)
+8 QUIT
+9 ;
SET() ;--SET IENS OF EACH FILE
+1 SET PRVIEN=$PIECE(REQI,"^",7)
IF PRVIEN]""
Begin DoDot:1
+2 SET PRVBEF=$GET(^AUPNVPRV($PIECE(REQI,"^",7),0))
+3 SET PRVBEF12=$GET(^AUPNVPRV($PIECE(REQI,"^",7),12))
+4 SET PRVBF812=$GET(^AUPNVPRV($PIECE(REQI,"^",7),812))
End DoDot:1
+5 IF '$TEST
SET (PRVBEF,PRVBEF12,PRVBF812)=""
+6 SET CPTIEN=$PIECE(REQI,"^",8)
+7 IF CPTIEN]""
Begin DoDot:1
+8 SET CPTBEF=$GET(^AUPNVCPT($PIECE(REQI,"^",8),0))
+9 ;Build array for cpt modifiers
+10 NEW SUBIEN
+11 SET SUBIEN=0
+12 FOR
SET SUBIEN=$ORDER(^AUPNVCPT($PIECE(REQI,"^",8),1,SUBIEN))
if 'SUBIEN
QUIT
Begin DoDot:2
+13 SET CPTBEF1(SUBIEN)=$GET(^AUPNVCPT($PIECE(REQI,"^",8),1,SUBIEN,0))
End DoDot:2
+14 SET CPTBEF12=$GET(^AUPNVCPT($PIECE(REQI,"^",8),12))
+15 SET CPTBF812=$GET(^AUPNVCPT($PIECE(REQI,"^",8),812))
End DoDot:1
+16 IF '$TEST
SET (CPTBEF,CPTBEF12,CPTBF812)=""
+17 SET POVIEN=$PIECE(REQI,"^",9)
IF POVIEN]""
Begin DoDot:1
+18 SET POVBEF=$GET(^AUPNVPOV($PIECE(REQI,"^",9),0))
+19 SET POVBEF12=$GET(^AUPNVPOV($PIECE(REQI,"^",9),12))
+20 SET POVBEF17=$GET(^AUPNVPOV($PIECE(REQI,"^",9),17))
+21 SET POVBF812=$GET(^AUPNVPOV($PIECE(REQI,"^",9),812))
+22 ;PX124
SET POVBF800=$GET(^AUPNVPOV($PIECE(REQI,"^",9),800))
End DoDot:1
+23 IF '$TEST
SET (POVBEF,POVBEF12,POVBEF17,POVBF812,POVBF800)=""
+24 ;
MISC ;--SET MISCELLANEOUS NODES
+1 ;--*** CONDITION THE SOURCE
+2 IF '$GET(SOURCE)
SET ^TMP("PXK",$JOB,"SOR")=$ORDER(^PX(839.7,"B","SD/PCE-INTERFACE-PROMPTS",0))
+3 ;
+4 SET ^TMP("PXK",$JOB,"VST",1,"IEN")=PXBVST
+5 SET ^TMP("PXK",$JOB,"VST",1,0,"AFTER")=$GET(^AUPNVSIT(PXBVST,0))
+6 SET ^TMP("PXK",$JOB,"VST",1,0,"BEFORE")=$GET(^AUPNVSIT(PXBVST,0))
+7 ;
+8 QUIT $GET(^TMP("PXBSTOR",$JOB,"SEQ"),1)
