- 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 Feb 18, 2025@23:53:36 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)