PXBGCPT ;ISL/JVS,PKR - GATHER CPT ; Mar 24, 2022@23:05
;;1.0;PCE PATIENT CARE ENCOUNTER;**73,149,124,211,229,230**;Aug 12, 1996;Build 4
;
; Reference to $$CPT^ICPTCOD in ICR #1995
;
CPT(VISIT) ;--Gather the entries in the V CPT file
;
K PXBKY,PXBSAM,PXBSKY,PXBPRV
I '$D(^AUPNVCPT("AD",VISIT)) S PXBCNT=0 Q
;
N CPT,CPTA,DA,DR,EDATA,EVENTDT,IEN,IENS,FIELDS,GROUP,MODIFIER
N PROVIDER,PX124,PXBC,PXSFIL,PXMOD,PXSIEN,QUANTITY,VAUGHN
A ;--Set array with CPT codes and associated modifiers
S FIELDS=".01;.04;.05;.09;.15;.16;1*;1201;1202;1204"
S IEN=0
F S IEN=$O(^AUPNVCPT("AD",VISIT,IEN)) Q:IEN'>0 D
.K VAUGHN,EDATA
.S IENS=IEN_","
.D GETS^DIQ(9000010.18,IENS,FIELDS,"EI","VAUGHN")
.S CPT=$G(VAUGHN(9000010.18,IENS,".01","I")) ;PX*1.0*230 - Change to Internal to correct duplicate encounter issue
.S QUANTITY=$G(VAUGHN(9000010.18,IENS,".16","E"))
.S EVENTDT=$G(VAUGHN(9000010.18,IENS,"1201","I"))
.I EVENTDT="" S EVENTDT=$P(^AUPNVSIT(VISIT,0),U,1)
.S PROVIDER=$G(VAUGHN(9000010.18,IENS,"1204","E"))
.S NARR=$E($G(VAUGHN(9000010.18,IENS,".04","E")),1,29)
.I NARR="" S NARR=$P($$CPT^ICPTCOD(CPT,EVENTDT),U,3)
.S EDATA=$E($G(VAUGHN(9000010.18,IENS,1202,"E")),1,29)
.D CASE^PXBUTL
.S GROUP=CPT_"^"_QUANTITY_"^"_PROVIDER_"^"_NARR
.F PX124=.05,.09,.1,.11,.12,.13,.14,.15 D
..S DA=$G(VAUGHN(9000010.18,IENS,PX124,"E")),DR=DA,GROUP=GROUP_U_DA
..I DA S DR=$$XLATE^PXBGPOV(VISIT,DA),DA=$P(DR,U,2)
..I DR S PXBREQ(DA,"I")=$P(DR,U,4,20)
.K DR,DA
.S $P(GROUP,U,22)=EDATA,CPTA(CPT,IEN)=GROUP
.S PXSFIL=9000010.181,PXSIEN=""
.F S PXSIEN=$O(VAUGHN(PXSFIL,PXSIEN)) Q:PXSIEN="" D
..S PXMOD=VAUGHN(PXSFIL,PXSIEN,.01,"E")
..S CPTA(CPT,IEN,"MOD",+PXSIEN)=PXMOD
;
B ;--Add line numbers
;
I $D(CPTA) D
.S PXBC=0,CPT=""
.F S CPT=$O(CPTA(CPT)) Q:CPT="" D
..S IEN=0
..F S IEN=$O(CPTA(CPT,IEN)) Q:IEN="" S PXBC=PXBC+1 D
...S PXBKY(CPT,PXBC)=$G(CPTA(CPT,IEN))
...S PXBSAM(PXBC)=$G(CPTA(CPT,IEN))
...S PXBSKY(PXBC,IEN)=""
...S PXSIEN=0
...F S PXSIEN=$O(CPTA(CPT,IEN,"MOD",PXSIEN)) Q:PXSIEN="" D
....S PXBKY(CPT,PXBC,"MOD",PXSIEN)=CPTA(CPT,IEN,"MOD",PXSIEN)
....S PXBSAM(PXBC,"MOD",PXSIEN)=CPTA(CPT,IEN,"MOD",PXSIEN)
...I $P($G(CPTA(CPT,IEN)),"^",3)]"" D
....S PXBPRV($P($G(CPTA(CPT,IEN)),"^",3),$P($G(CPTA(CPT,IEN)),"^",1),IEN,PXBC)=QUANTITY
S PXBCNT=+$G(PXBC)
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXBGCPT 2353 printed Apr 09, 2024@21:32:43 Page 2
PXBGCPT ;ISL/JVS,PKR - GATHER CPT ; Mar 24, 2022@23:05
+1 ;;1.0;PCE PATIENT CARE ENCOUNTER;**73,149,124,211,229,230**;Aug 12, 1996;Build 4
+2 ;
+3 ; Reference to $$CPT^ICPTCOD in ICR #1995
+4 ;
CPT(VISIT) ;--Gather the entries in the V CPT file
+1 ;
+2 KILL PXBKY,PXBSAM,PXBSKY,PXBPRV
+3 IF '$DATA(^AUPNVCPT("AD",VISIT))
SET PXBCNT=0
QUIT
+4 ;
+5 NEW CPT,CPTA,DA,DR,EDATA,EVENTDT,IEN,IENS,FIELDS,GROUP,MODIFIER
+6 NEW PROVIDER,PX124,PXBC,PXSFIL,PXMOD,PXSIEN,QUANTITY,VAUGHN
A ;--Set array with CPT codes and associated modifiers
+1 SET FIELDS=".01;.04;.05;.09;.15;.16;1*;1201;1202;1204"
+2 SET IEN=0
+3 FOR
SET IEN=$ORDER(^AUPNVCPT("AD",VISIT,IEN))
if IEN'>0
QUIT
Begin DoDot:1
+4 KILL VAUGHN,EDATA
+5 SET IENS=IEN_","
+6 DO GETS^DIQ(9000010.18,IENS,FIELDS,"EI","VAUGHN")
+7 ;PX*1.0*230 - Change to Internal to correct duplicate encounter issue
SET CPT=$GET(VAUGHN(9000010.18,IENS,".01","I"))
+8 SET QUANTITY=$GET(VAUGHN(9000010.18,IENS,".16","E"))
+9 SET EVENTDT=$GET(VAUGHN(9000010.18,IENS,"1201","I"))
+10 IF EVENTDT=""
SET EVENTDT=$PIECE(^AUPNVSIT(VISIT,0),U,1)
+11 SET PROVIDER=$GET(VAUGHN(9000010.18,IENS,"1204","E"))
+12 SET NARR=$EXTRACT($GET(VAUGHN(9000010.18,IENS,".04","E")),1,29)
+13 IF NARR=""
SET NARR=$PIECE($$CPT^ICPTCOD(CPT,EVENTDT),U,3)
+14 SET EDATA=$EXTRACT($GET(VAUGHN(9000010.18,IENS,1202,"E")),1,29)
+15 DO CASE^PXBUTL
+16 SET GROUP=CPT_"^"_QUANTITY_"^"_PROVIDER_"^"_NARR
+17 FOR PX124=.05,.09,.1,.11,.12,.13,.14,.15
Begin DoDot:2
+18 SET DA=$GET(VAUGHN(9000010.18,IENS,PX124,"E"))
SET DR=DA
SET GROUP=GROUP_U_DA
+19 IF DA
SET DR=$$XLATE^PXBGPOV(VISIT,DA)
SET DA=$PIECE(DR,U,2)
+20 IF DR
SET PXBREQ(DA,"I")=$PIECE(DR,U,4,20)
End DoDot:2
+21 KILL DR,DA
+22 SET $PIECE(GROUP,U,22)=EDATA
SET CPTA(CPT,IEN)=GROUP
+23 SET PXSFIL=9000010.181
SET PXSIEN=""
+24 FOR
SET PXSIEN=$ORDER(VAUGHN(PXSFIL,PXSIEN))
if PXSIEN=""
QUIT
Begin DoDot:2
+25 SET PXMOD=VAUGHN(PXSFIL,PXSIEN,.01,"E")
+26 SET CPTA(CPT,IEN,"MOD",+PXSIEN)=PXMOD
End DoDot:2
End DoDot:1
+27 ;
B ;--Add line numbers
+1 ;
+2 IF $DATA(CPTA)
Begin DoDot:1
+3 SET PXBC=0
SET CPT=""
+4 FOR
SET CPT=$ORDER(CPTA(CPT))
if CPT=""
QUIT
Begin DoDot:2
+5 SET IEN=0
+6 FOR
SET IEN=$ORDER(CPTA(CPT,IEN))
if IEN=""
QUIT
SET PXBC=PXBC+1
Begin DoDot:3
+7 SET PXBKY(CPT,PXBC)=$GET(CPTA(CPT,IEN))
+8 SET PXBSAM(PXBC)=$GET(CPTA(CPT,IEN))
+9 SET PXBSKY(PXBC,IEN)=""
+10 SET PXSIEN=0
+11 FOR
SET PXSIEN=$ORDER(CPTA(CPT,IEN,"MOD",PXSIEN))
if PXSIEN=""
QUIT
Begin DoDot:4
+12 SET PXBKY(CPT,PXBC,"MOD",PXSIEN)=CPTA(CPT,IEN,"MOD",PXSIEN)
+13 SET PXBSAM(PXBC,"MOD",PXSIEN)=CPTA(CPT,IEN,"MOD",PXSIEN)
End DoDot:4
+14 IF $PIECE($GET(CPTA(CPT,IEN)),"^",3)]""
Begin DoDot:4
+15 SET PXBPRV($PIECE($GET(CPTA(CPT,IEN)),"^",3),$PIECE($GET(CPTA(CPT,IEN)),"^",1),IEN,PXBC)=QUANTITY
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+16 SET PXBCNT=+$GET(PXBC)
+17 QUIT
+18 ;
