PXVRPC4A ;ISP/LMT - PCE RPCs for Immunization(s) Cont ;Oct 05, 2021@11:18:28
;;1.0;PCE PATIENT CARE ENCOUNTER;**217**;Aug 12, 1996;Build 134
;
;
IMMADMCODES(PXRSLT,PXVISIT,PXPCELIST,PXRETCPTDEL) ;
;
N PXADD,PXADM,PXADMCODES,PXCNT,PXCODE,PXCODESADD,PXCODESDEL,PXCODESYS,PXCPT,PXCPTDEL
N PXCPTIEN,PXCPTLIST,PXI,PXICD,PXICDDEL,PXICDIEN,PXIMM,PXNODE,PXQTY,PXRDCODE,PXSERIES,PXSK,PXSKTYP,PXVCPT
N PXVCPTDEL,PXVCPTIEN,PXVICD,PXVICDDEL,PXVICDIEN,PXVIMM,PXVIMMDEL,PXVIMMIEN,PXVSKIEN,PXVISITDT,PXVSK,PXVSKDEL
;
I '$G(PXVISIT) S PXVISIT=0
S PXVISITDT=DT
I PXVISIT S PXVISITDT=$P($G(^AUPNVSIT(PXVISIT,0)),U,1)
;
;get list of current V CPT codes
S PXVCPTIEN=0
F S PXVCPTIEN=$O(^AUPNVCPT("AD",PXVISIT,PXVCPTIEN)) Q:PXVCPTIEN="" D
. S PXCPTIEN=$P($G(^AUPNVCPT(PXVCPTIEN,0)),U,1)
. S PXCPT=$$CODEC^ICPTCOD(PXCPTIEN)
. I PXCPT=-1!(PXCPT="") Q
. S PXQTY=$P($G(^AUPNVCPT(PXVCPTIEN,0)),U,16)
. S PXVCPT(PXCPT)=PXCPTIEN_U_PXQTY_U_PXVCPTIEN
;
;get list of current V POV codes
S PXVICDIEN=0
F S PXVICDIEN=$O(^AUPNVPOV("AD",PXVISIT,PXVICDIEN)) Q:PXVICDIEN="" D
. S PXICDIEN=$P($G(^AUPNVPOV(PXVICDIEN,0)),U,1)
. S PXICD=$P($$CODEC^ICDEX(80,PXICDIEN),U,1)
. I PXICD=-1!(PXICD="") Q
. S PXVICD(PXICD)=PXICDIEN_U_PXVICDIEN
;
; get list of imms from V Immunization file
S PXVIMMIEN=0
F S PXVIMMIEN=$O(^AUPNVIMM("AD",PXVISIT,PXVIMMIEN)) Q:PXVIMMIEN="" D
. S PXIMM=$P($G(^AUPNVIMM(PXVIMMIEN,0)),U,1)
. S PXSERIES=$P($G(^AUPNVIMM(PXVIMMIEN,0)),U,4)
. I 'PXIMM Q
. S PXADMCODES=""
. D GETADMCPT(.PXADMCODES,PXIMM,PXSERIES,PXVISITDT,.PXVCPT)
. S PXVIMM(PXIMM)=PXSERIES_U_PXADMCODES
. D GETIMMCODES(.PXCODESADD,,PXIMM,PXVISITDT,0)
;
; get list of skin tests from V Skin Test file
S PXRDCODE=$$GET^XPAR("ALL","PXV SKIN TEST READING CPT",1,"I")
S PXVSKIEN=0
F S PXVSKIEN=$O(^AUPNVSK("AD",PXVISIT,PXVSKIEN)) Q:PXVSKIEN="" D
. S PXSK=$P($G(^AUPNVSK(PXVSKIEN,0)),U,1)
. I 'PXSK Q
. S PXVSK(PXSK)=""
. D GETSKCODES(.PXCODESADD,,PXSK,PXVISITDT,0)
. S PXSKTYP="A"
. I $P($G(^AUPNVSK(PXVSKIEN,12)),U,8) S PXSKTYP="R"
. I PXSKTYP="R",PXRDCODE'="" S PXCODESADD("CPT",PXRDCODE)=""
;
; get list of skin tests, CPTs, ICDs from PXPCELIST
S PXI=0
F S PXI=$O(PXPCELIST(PXI)) Q:'PXI D
. S PXNODE=$G(PXPCELIST(PXI))
. I $E(PXNODE,1,2)="SK" D SK(.PXVSK,.PXVSKDEL,.PXCODESADD,.PXCODESDEL,PXNODE,PXVISITDT,PXRDCODE)
. I $E(PXNODE,1,3)="CPT" D CPT(.PXVCPT,.PXVCPTDEL,PXNODE)
. I $E(PXNODE,1,3)="POV" D ICD(.PXVICD,.PXVICDDEL,PXNODE)
;
; get list of imms from PXPCELIST
; need a seperate FOR loop, as first need full VCPT list before calculating Imm Admin CPT codes
S PXI=0
F S PXI=$O(PXPCELIST(PXI)) Q:'PXI D
. S PXNODE=$G(PXPCELIST(PXI))
. I $E(PXNODE,1,3)="IMM" D IMM(.PXVIMM,.PXVIMMDEL,.PXCODESADD,.PXCODESDEL,PXNODE,PXVISITDT,.PXVCPT)
;
; get list of CPT admin codes needed for imms
S PXIMM=0
F S PXIMM=$O(PXVIMM(PXIMM)) Q:'PXIMM D
. S PXNODE=$G(PXVIMM(PXIMM))
. S PXSERIES=$P(PXNODE,U,1)
. S PXADM=$P(PXNODE,U,2)
. S PXADD=$P(PXNODE,U,5)
. I 'PXADM Q
. I '$D(PXCPTLIST(PXADM)) D
. . S PXCPTLIST(PXADM)=1_U_$P(PXNODE,U,4)
. E D
. . I PXADD S PXCPTLIST(PXADD)=(+$G(PXCPTLIST(PXADD))+1)_U_$P(PXNODE,U,7)
;
; check if need to delete any codes based off PXVIMMDEL.
; compare any admin codes from old imms (or series), and see if they can be deleted.
S PXIMM=0
F S PXIMM=$O(PXVIMMDEL(PXIMM)) Q:'PXIMM D
. S PXNODE=$G(PXVIMMDEL(PXIMM))
. S PXADM=$P(PXNODE,U,2)
. S PXADD=$P(PXNODE,U,5)
. I PXADM,$D(PXVCPT(PXADM)),'$D(PXCPTLIST(PXADM)) D
. . S PXCPTDEL(PXADM)=""
. I PXADD,$D(PXVCPT(PXADD)),'$D(PXCPTLIST(PXADD)) D
. . S PXCPTDEL(PXADD)=""
. ;
. ; see if caller wants us to return other mapped CPT and ICD codes to delete for imm
. I $G(PXVIMMDEL(PXIMM,"UPDATED")) Q ;not a true delete... just updated series
. F PXCODESYS="CPT","10D" D
. . S PXCODE=""
. . F S PXCODE=$O(PXCODESDEL("IMM",PXIMM,PXCODESYS,PXCODE)) Q:PXCODE="" D
. . . I PXCODESYS="CPT",$D(PXVCPT(PXCODE)),'$D(PXCODESADD(PXCODESYS,PXCODE)) D
. . . . S PXCPTDEL(PXCODE)=""
. . . I PXCODESYS="10D",$D(PXVICD(PXCODE)),'$D(PXCODESADD(PXCODESYS,PXCODE)) D
. . . . S PXICDDEL(PXCODE)=""
;
; see if caller wants us to return other mapped CPT and ICD codes to delete for skin tests
S PXSK=0
F S PXSK=$O(PXVSKDEL(PXSK)) Q:'PXSK D
. F PXCODESYS="CPT","10D" D
. . S PXCODE=""
. . F S PXCODE=$O(PXCODESDEL("SK",PXSK,PXCODESYS,PXCODE)) Q:PXCODE="" D
. . . I PXCODESYS="CPT",$D(PXVCPT(PXCODE)),'$D(PXCODESADD(PXCODESYS,PXCODE)) D
. . . . S PXCPTDEL(PXCODE)=""
. . . I PXCODESYS="10D",$D(PXVICD(PXCODE)),'$D(PXCODESADD(PXCODESYS,PXCODE)) D
. . . . S PXICDDEL(PXCODE)=""
;
; setup PXRSLT with CPT codes to add and delete
S PXCNT=0
S PXCPT=""
F S PXCPT=$O(PXCPTLIST(PXCPT)) Q:PXCPT="" D
. S PXCNT=PXCNT+1
. S PXNODE=$G(PXCPTLIST(PXCPT))
. S PXQTY=$P(PXNODE,U,1)
. I $D(PXVCPT(PXCPT)),$P($G(PXVCPT(PXCPT)),U,2)=PXQTY Q
. S PXRSLT(PXCNT)="CPT+^"_PXCPT_"^^"_$P(PXNODE,U,2)_U_PXQTY
;
S PXCPT=""
F S PXCPT=$O(PXCPTDEL(PXCPT)) Q:PXCPT="" D
. S PXCNT=PXCNT+1
. S PXRSLT(PXCNT)="CPT-^"_PXCPT
;
S PXICD=""
F S PXICD=$O(PXICDDEL(PXICD)) Q:PXICD="" D
. S PXCNT=PXCNT+1
. S PXRSLT(PXCNT)="POV-^"_PXICD
;
Q
;
IMM(PXVIMM,PXVIMMDEL,PXCODESADD,PXCODESDEL,PXNODE,PXVISITDT,PXVCPT) ;
N PXIMM,PXSERIES,PXADMCODES,PXOLDSERIES,PXOLDADMCODES
S PXIMM=$P(PXNODE,U,2)
I 'PXIMM Q
;
S PXSERIES=$P(PXNODE,U,5)
S PXADMCODES=""
D GETADMCPT(.PXADMCODES,PXIMM,PXSERIES,PXVISITDT,.PXVCPT)
;
I $E(PXNODE,4)="-" D Q ; if delete
. S PXVIMMDEL(PXIMM)=PXSERIES_U_PXADMCODES
. K PXVIMM(PXIMM)
. D GETIMMCODES(.PXCODESADD,.PXCODESDEL,PXIMM,PXVISITDT,1)
;
; If doing an update and series changed, see if old admin codes changed and need to be deleted
I $D(PXVIMM(PXIMM)) D
. S PXNODE=$G(PXVIMM(PXIMM))
. S PXOLDSERIES=$P(PXNODE,U,1)
. S PXOLDADMCODES=$P(PXNODE,U,2,7)
. ;I PXSERIES'=PXOLDSERIES,PXADMCODES'=PXOLDADMCODES D
. I PXADMCODES'=PXOLDADMCODES D
. . S PXVIMMDEL(PXIMM)=PXOLDSERIES_U_PXOLDADMCODES
. . S PXVIMMDEL(PXIMM,"UPDATED")=1
;
S PXVIMM(PXIMM)=PXSERIES_U_PXADMCODES
D GETIMMCODES(.PXCODESADD,,PXIMM,PXVISITDT,0)
Q
;
GETIMMCODES(PXCODESADD,PXCODESDEL,PXIMM,PXVISITDT,PXDEL) ;
;
N PXX,PXCODESYS,PXCODE
K ^TMP("PXVRPC4AIMM",$J)
D GETCS^PXVRPC4("PXVRPC4AIMM",PXIMM,PXVISITDT)
F PXCODESYS="CPT","10D" D
. S PXX=""
. F S PXX=$O(^TMP("PXVRPC4AIMM",$J,"CS",PXCODESYS,PXX)) Q:PXX="" D
. . S PXCODE=$P($G(^TMP("PXVRPC4AIMM",$J,"CS",PXCODESYS,PXX,0)),U,1)
. . I PXCODE="" Q
. . I PXDEL D
. . . S PXCODESDEL("IMM",PXIMM,PXCODESYS,PXCODE)=""
. . . K PXCODESADD(PXCODESYS,PXCODE,"IMM",PXIMM)
. . I 'PXDEL S PXCODESADD(PXCODESYS,PXCODE,"IMM",PXIMM)=""
K ^TMP("PXVRPC4AIMM",$J)
Q
;
SK(PXVSK,PXVSKDEL,PXCODESADD,PXCODESDEL,PXNODE,PXVISITDT,PXRDCODE) ;
N PXSK,PXSKTYP
S PXSK=$P(PXNODE,U,2)
I PXSK="" Q
;
S PXSKTYP="A"
I $P(PXNODE,U,16) S PXSKTYP="R"
;
I $E(PXNODE,3)="-" D Q ; if delete
. K PXVSK(PXSK)
. S PXVSKDEL(PXSK)=""
. D GETSKCODES(.PXCODESADD,.PXCODESDEL,PXSK,PXVISITDT,1)
. I PXSKTYP="R",PXRDCODE'="" S PXCODESDEL("SK",PXSK,"CPT",PXRDCODE)=""
;
S PXVSK(PXSK)=""
D GETSKCODES(.PXCODESADD,,PXSK,PXVISITDT,0)
I PXSKTYP="R",PXRDCODE'="" S PXCODESADD("CPT",PXRDCODE)=""
Q
;
GETSKCODES(PXCODESADD,PXCODESDEL,PXSK,PXVISITDT,PXDEL) ;
N PXSKCODES,PXX,PXCODESYS,PXCODE
K PXSKCODES
D GETCS^PXVRPC8(.PXSKCODES,0,PXSK,PXVISITDT)
S PXX=0
F S PXX=$O(PXSKCODES(PXX)) Q:'PXX D
. S PXCODESYS=$P($G(PXSKCODES(PXX)),U,2)
. I PXCODESYS'?1(1"CPT",1"10D") Q
. S PXCODE=$P($G(PXSKCODES(PXX)),U,3)
. I PXCODE="" Q
. I PXDEL D
. . S PXCODESDEL("SK",PXSK,PXCODESYS,PXCODE)=""
. . K PXCODESADD(PXCODESYS,PXCODE,"SK",PXSK)
. I 'PXDEL S PXCODESADD(PXCODESYS,PXCODE,"SK",PXSK)=""
Q
;
CPT(PXVCPT,PXVCPTDEL,PXNODE) ;
N PXCPT,PXQTY
S PXCPT=$P(PXNODE,U,2)
I PXCPT="" Q
S PXQTY=$P(PXNODE,U,5)
;
I $E(PXNODE,4)="-" D Q ; if delete
. K PXVCPT(PXCPT)
. S PXVCPTDEL(PXCPT)=""
;
S PXVCPT(PXCPT)="^"_PXQTY
Q
;
ICD(PXVICD,PXVICDDEL,PXNODE) ;
N PXICD
S PXICD=$P(PXNODE,U,2)
I PXICD="" Q
;
I $E(PXNODE,4)="-" D Q ; if delete
. K PXVICD(PXICD)
. S PXVICDDEL(PXICD)=""
;
S PXVICD(PXICD)=""
Q
;
GETADMCPT(PXRSLT,PXIMM,PXSERIES,PXDATE,PXCPTLIST) ;
;
N PXADMACS,PXADMICS,PXFLD,PXI,PXJ,PXNODE,PXSUB,PXADMICNT,PXADMACNT,PXCODE
;
S PXRSLT=""
S PXIMM=$G(PXIMM)
S PXSERIES=$G(PXSERIES)
I '$G(PXDATE) S PXDATE=DT
;
I 'PXIMM Q
;
S PXSUB="PXVIMMCODE"
K ^TMP(PXSUB,$J)
D GETCS^PXVRPC4(PXSUB,PXIMM,PXDATE)
;
S PXADMICS="CPTAI"_PXSERIES
S PXADMACS="CPTAA"_PXSERIES
I '$D(^TMP(PXSUB,$J,"CS",PXADMICS)) D
. S PXADMICS="CPTAI"
. S PXADMACS="CPTAA"
;
S PXADMICNT=0
S PXADMACNT=0
F PXFLD=PXADMICS,PXADMACS D
. I '$D(^TMP(PXSUB,$J,"CS",PXFLD)) Q
. S PXI=0 F S PXI=$O(^TMP(PXSUB,$J,"CS",PXFLD,PXI)) Q:'PXI D
. . S PXNODE=$G(^TMP(PXSUB,$J,"CS",PXFLD,PXI,0))
. . I PXNODE="" Q
. . ;
. . ; Take into account where mapping is CPT dependant (e.g., 91301-0011A)
. . S PXCODE=$P(PXNODE,U,1)
. . I PXCODE["-" D
. . . S PXCODE=$$GETCPTCODE(PXCODE,.PXCPTLIST)
. . . S $P(PXNODE,U,1)=PXCODE
. . I PXCODE="" Q
. . ;
. . I PXFLD=PXADMICS D
. . . S PXADMICNT=PXADMICNT+1
. . . F PXJ=1:1:3 S $P(PXRSLT,U,PXJ)=$P(PXNODE,U,PXJ)
. . I PXFLD=PXADMACS D
. . . S PXADMACNT=PXADMACNT+1
. . . F PXJ=4:1:6 S $P(PXRSLT,U,PXJ)=$P(PXNODE,U,PXJ-3)
;
; If multiple codes are mapped to same imm and series, don't file admin codes
I PXADMICNT>1!(PXADMACNT>1) S PXRSLT=""
;
K ^TMP(PXSUB,$J)
Q
;
GETCPTCODE(PXCODE,PXCPTLIST) ;
N PXCODE1,PXCODE2
;
S PXCODE1=$P(PXCODE,"-",1)
S PXCODE2=$P(PXCODE,"-",2)
I PXCODE1="" Q ""
I $D(PXCPTLIST(PXCODE1)) Q PXCODE2
;
Q ""
;
ISMAPTOADMCPT(PXIMM) ; Is it mapped to Series specific admin codes
I '$G(PXIMM) Q 0
I $O(^AUTTIMM(PXIMM,3,"B","CPTAI"))["CPTAI" Q 1
Q 0
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXVRPC4A 9995 printed Sep 23, 2025@20:08:02 Page 2
PXVRPC4A ;ISP/LMT - PCE RPCs for Immunization(s) Cont ;Oct 05, 2021@11:18:28
+1 ;;1.0;PCE PATIENT CARE ENCOUNTER;**217**;Aug 12, 1996;Build 134
+2 ;
+3 ;
IMMADMCODES(PXRSLT,PXVISIT,PXPCELIST,PXRETCPTDEL) ;
+1 ;
+2 NEW PXADD,PXADM,PXADMCODES,PXCNT,PXCODE,PXCODESADD,PXCODESDEL,PXCODESYS,PXCPT,PXCPTDEL
+3 NEW PXCPTIEN,PXCPTLIST,PXI,PXICD,PXICDDEL,PXICDIEN,PXIMM,PXNODE,PXQTY,PXRDCODE,PXSERIES,PXSK,PXSKTYP,PXVCPT
+4 NEW PXVCPTDEL,PXVCPTIEN,PXVICD,PXVICDDEL,PXVICDIEN,PXVIMM,PXVIMMDEL,PXVIMMIEN,PXVSKIEN,PXVISITDT,PXVSK,PXVSKDEL
+5 ;
+6 IF '$GET(PXVISIT)
SET PXVISIT=0
+7 SET PXVISITDT=DT
+8 IF PXVISIT
SET PXVISITDT=$PIECE($GET(^AUPNVSIT(PXVISIT,0)),U,1)
+9 ;
+10 ;get list of current V CPT codes
+11 SET PXVCPTIEN=0
+12 FOR
SET PXVCPTIEN=$ORDER(^AUPNVCPT("AD",PXVISIT,PXVCPTIEN))
if PXVCPTIEN=""
QUIT
Begin DoDot:1
+13 SET PXCPTIEN=$PIECE($GET(^AUPNVCPT(PXVCPTIEN,0)),U,1)
+14 SET PXCPT=$$CODEC^ICPTCOD(PXCPTIEN)
+15 IF PXCPT=-1!(PXCPT="")
QUIT
+16 SET PXQTY=$PIECE($GET(^AUPNVCPT(PXVCPTIEN,0)),U,16)
+17 SET PXVCPT(PXCPT)=PXCPTIEN_U_PXQTY_U_PXVCPTIEN
End DoDot:1
+18 ;
+19 ;get list of current V POV codes
+20 SET PXVICDIEN=0
+21 FOR
SET PXVICDIEN=$ORDER(^AUPNVPOV("AD",PXVISIT,PXVICDIEN))
if PXVICDIEN=""
QUIT
Begin DoDot:1
+22 SET PXICDIEN=$PIECE($GET(^AUPNVPOV(PXVICDIEN,0)),U,1)
+23 SET PXICD=$PIECE($$CODEC^ICDEX(80,PXICDIEN),U,1)
+24 IF PXICD=-1!(PXICD="")
QUIT
+25 SET PXVICD(PXICD)=PXICDIEN_U_PXVICDIEN
End DoDot:1
+26 ;
+27 ; get list of imms from V Immunization file
+28 SET PXVIMMIEN=0
+29 FOR
SET PXVIMMIEN=$ORDER(^AUPNVIMM("AD",PXVISIT,PXVIMMIEN))
if PXVIMMIEN=""
QUIT
Begin DoDot:1
+30 SET PXIMM=$PIECE($GET(^AUPNVIMM(PXVIMMIEN,0)),U,1)
+31 SET PXSERIES=$PIECE($GET(^AUPNVIMM(PXVIMMIEN,0)),U,4)
+32 IF 'PXIMM
QUIT
+33 SET PXADMCODES=""
+34 DO GETADMCPT(.PXADMCODES,PXIMM,PXSERIES,PXVISITDT,.PXVCPT)
+35 SET PXVIMM(PXIMM)=PXSERIES_U_PXADMCODES
+36 DO GETIMMCODES(.PXCODESADD,,PXIMM,PXVISITDT,0)
End DoDot:1
+37 ;
+38 ; get list of skin tests from V Skin Test file
+39 SET PXRDCODE=$$GET^XPAR("ALL","PXV SKIN TEST READING CPT",1,"I")
+40 SET PXVSKIEN=0
+41 FOR
SET PXVSKIEN=$ORDER(^AUPNVSK("AD",PXVISIT,PXVSKIEN))
if PXVSKIEN=""
QUIT
Begin DoDot:1
+42 SET PXSK=$PIECE($GET(^AUPNVSK(PXVSKIEN,0)),U,1)
+43 IF 'PXSK
QUIT
+44 SET PXVSK(PXSK)=""
+45 DO GETSKCODES(.PXCODESADD,,PXSK,PXVISITDT,0)
+46 SET PXSKTYP="A"
+47 IF $PIECE($GET(^AUPNVSK(PXVSKIEN,12)),U,8)
SET PXSKTYP="R"
+48 IF PXSKTYP="R"
IF PXRDCODE'=""
SET PXCODESADD("CPT",PXRDCODE)=""
End DoDot:1
+49 ;
+50 ; get list of skin tests, CPTs, ICDs from PXPCELIST
+51 SET PXI=0
+52 FOR
SET PXI=$ORDER(PXPCELIST(PXI))
if 'PXI
QUIT
Begin DoDot:1
+53 SET PXNODE=$GET(PXPCELIST(PXI))
+54 IF $EXTRACT(PXNODE,1,2)="SK"
DO SK(.PXVSK,.PXVSKDEL,.PXCODESADD,.PXCODESDEL,PXNODE,PXVISITDT,PXRDCODE)
+55 IF $EXTRACT(PXNODE,1,3)="CPT"
DO CPT(.PXVCPT,.PXVCPTDEL,PXNODE)
+56 IF $EXTRACT(PXNODE,1,3)="POV"
DO ICD(.PXVICD,.PXVICDDEL,PXNODE)
End DoDot:1
+57 ;
+58 ; get list of imms from PXPCELIST
+59 ; need a seperate FOR loop, as first need full VCPT list before calculating Imm Admin CPT codes
+60 SET PXI=0
+61 FOR
SET PXI=$ORDER(PXPCELIST(PXI))
if 'PXI
QUIT
Begin DoDot:1
+62 SET PXNODE=$GET(PXPCELIST(PXI))
+63 IF $EXTRACT(PXNODE,1,3)="IMM"
DO IMM(.PXVIMM,.PXVIMMDEL,.PXCODESADD,.PXCODESDEL,PXNODE,PXVISITDT,.PXVCPT)
End DoDot:1
+64 ;
+65 ; get list of CPT admin codes needed for imms
+66 SET PXIMM=0
+67 FOR
SET PXIMM=$ORDER(PXVIMM(PXIMM))
if 'PXIMM
QUIT
Begin DoDot:1
+68 SET PXNODE=$GET(PXVIMM(PXIMM))
+69 SET PXSERIES=$PIECE(PXNODE,U,1)
+70 SET PXADM=$PIECE(PXNODE,U,2)
+71 SET PXADD=$PIECE(PXNODE,U,5)
+72 IF 'PXADM
QUIT
+73 IF '$DATA(PXCPTLIST(PXADM))
Begin DoDot:2
+74 SET PXCPTLIST(PXADM)=1_U_$PIECE(PXNODE,U,4)
End DoDot:2
+75 IF '$TEST
Begin DoDot:2
+76 IF PXADD
SET PXCPTLIST(PXADD)=(+$GET(PXCPTLIST(PXADD))+1)_U_$PIECE(PXNODE,U,7)
End DoDot:2
End DoDot:1
+77 ;
+78 ; check if need to delete any codes based off PXVIMMDEL.
+79 ; compare any admin codes from old imms (or series), and see if they can be deleted.
+80 SET PXIMM=0
+81 FOR
SET PXIMM=$ORDER(PXVIMMDEL(PXIMM))
if 'PXIMM
QUIT
Begin DoDot:1
+82 SET PXNODE=$GET(PXVIMMDEL(PXIMM))
+83 SET PXADM=$PIECE(PXNODE,U,2)
+84 SET PXADD=$PIECE(PXNODE,U,5)
+85 IF PXADM
IF $DATA(PXVCPT(PXADM))
IF '$DATA(PXCPTLIST(PXADM))
Begin DoDot:2
+86 SET PXCPTDEL(PXADM)=""
End DoDot:2
+87 IF PXADD
IF $DATA(PXVCPT(PXADD))
IF '$DATA(PXCPTLIST(PXADD))
Begin DoDot:2
+88 SET PXCPTDEL(PXADD)=""
End DoDot:2
+89 ;
+90 ; see if caller wants us to return other mapped CPT and ICD codes to delete for imm
+91 ;not a true delete... just updated series
IF $GET(PXVIMMDEL(PXIMM,"UPDATED"))
QUIT
+92 FOR PXCODESYS="CPT","10D"
Begin DoDot:2
+93 SET PXCODE=""
+94 FOR
SET PXCODE=$ORDER(PXCODESDEL("IMM",PXIMM,PXCODESYS,PXCODE))
if PXCODE=""
QUIT
Begin DoDot:3
+95 IF PXCODESYS="CPT"
IF $DATA(PXVCPT(PXCODE))
IF '$DATA(PXCODESADD(PXCODESYS,PXCODE))
Begin DoDot:4
+96 SET PXCPTDEL(PXCODE)=""
End DoDot:4
+97 IF PXCODESYS="10D"
IF $DATA(PXVICD(PXCODE))
IF '$DATA(PXCODESADD(PXCODESYS,PXCODE))
Begin DoDot:4
+98 SET PXICDDEL(PXCODE)=""
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+99 ;
+100 ; see if caller wants us to return other mapped CPT and ICD codes to delete for skin tests
+101 SET PXSK=0
+102 FOR
SET PXSK=$ORDER(PXVSKDEL(PXSK))
if 'PXSK
QUIT
Begin DoDot:1
+103 FOR PXCODESYS="CPT","10D"
Begin DoDot:2
+104 SET PXCODE=""
+105 FOR
SET PXCODE=$ORDER(PXCODESDEL("SK",PXSK,PXCODESYS,PXCODE))
if PXCODE=""
QUIT
Begin DoDot:3
+106 IF PXCODESYS="CPT"
IF $DATA(PXVCPT(PXCODE))
IF '$DATA(PXCODESADD(PXCODESYS,PXCODE))
Begin DoDot:4
+107 SET PXCPTDEL(PXCODE)=""
End DoDot:4
+108 IF PXCODESYS="10D"
IF $DATA(PXVICD(PXCODE))
IF '$DATA(PXCODESADD(PXCODESYS,PXCODE))
Begin DoDot:4
+109 SET PXICDDEL(PXCODE)=""
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+110 ;
+111 ; setup PXRSLT with CPT codes to add and delete
+112 SET PXCNT=0
+113 SET PXCPT=""
+114 FOR
SET PXCPT=$ORDER(PXCPTLIST(PXCPT))
if PXCPT=""
QUIT
Begin DoDot:1
+115 SET PXCNT=PXCNT+1
+116 SET PXNODE=$GET(PXCPTLIST(PXCPT))
+117 SET PXQTY=$PIECE(PXNODE,U,1)
+118 IF $DATA(PXVCPT(PXCPT))
IF $PIECE($GET(PXVCPT(PXCPT)),U,2)=PXQTY
QUIT
+119 SET PXRSLT(PXCNT)="CPT+^"_PXCPT_"^^"_$PIECE(PXNODE,U,2)_U_PXQTY
End DoDot:1
+120 ;
+121 SET PXCPT=""
+122 FOR
SET PXCPT=$ORDER(PXCPTDEL(PXCPT))
if PXCPT=""
QUIT
Begin DoDot:1
+123 SET PXCNT=PXCNT+1
+124 SET PXRSLT(PXCNT)="CPT-^"_PXCPT
End DoDot:1
+125 ;
+126 SET PXICD=""
+127 FOR
SET PXICD=$ORDER(PXICDDEL(PXICD))
if PXICD=""
QUIT
Begin DoDot:1
+128 SET PXCNT=PXCNT+1
+129 SET PXRSLT(PXCNT)="POV-^"_PXICD
End DoDot:1
+130 ;
+131 QUIT
+132 ;
IMM(PXVIMM,PXVIMMDEL,PXCODESADD,PXCODESDEL,PXNODE,PXVISITDT,PXVCPT) ;
+1 NEW PXIMM,PXSERIES,PXADMCODES,PXOLDSERIES,PXOLDADMCODES
+2 SET PXIMM=$PIECE(PXNODE,U,2)
+3 IF 'PXIMM
QUIT
+4 ;
+5 SET PXSERIES=$PIECE(PXNODE,U,5)
+6 SET PXADMCODES=""
+7 DO GETADMCPT(.PXADMCODES,PXIMM,PXSERIES,PXVISITDT,.PXVCPT)
+8 ;
+9 ; if delete
IF $EXTRACT(PXNODE,4)="-"
Begin DoDot:1
+10 SET PXVIMMDEL(PXIMM)=PXSERIES_U_PXADMCODES
+11 KILL PXVIMM(PXIMM)
+12 DO GETIMMCODES(.PXCODESADD,.PXCODESDEL,PXIMM,PXVISITDT,1)
End DoDot:1
QUIT
+13 ;
+14 ; If doing an update and series changed, see if old admin codes changed and need to be deleted
+15 IF $DATA(PXVIMM(PXIMM))
Begin DoDot:1
+16 SET PXNODE=$GET(PXVIMM(PXIMM))
+17 SET PXOLDSERIES=$PIECE(PXNODE,U,1)
+18 SET PXOLDADMCODES=$PIECE(PXNODE,U,2,7)
+19 ;I PXSERIES'=PXOLDSERIES,PXADMCODES'=PXOLDADMCODES D
+20 IF PXADMCODES'=PXOLDADMCODES
Begin DoDot:2
+21 SET PXVIMMDEL(PXIMM)=PXOLDSERIES_U_PXOLDADMCODES
+22 SET PXVIMMDEL(PXIMM,"UPDATED")=1
End DoDot:2
End DoDot:1
+23 ;
+24 SET PXVIMM(PXIMM)=PXSERIES_U_PXADMCODES
+25 DO GETIMMCODES(.PXCODESADD,,PXIMM,PXVISITDT,0)
+26 QUIT
+27 ;
GETIMMCODES(PXCODESADD,PXCODESDEL,PXIMM,PXVISITDT,PXDEL) ;
+1 ;
+2 NEW PXX,PXCODESYS,PXCODE
+3 KILL ^TMP("PXVRPC4AIMM",$JOB)
+4 DO GETCS^PXVRPC4("PXVRPC4AIMM",PXIMM,PXVISITDT)
+5 FOR PXCODESYS="CPT","10D"
Begin DoDot:1
+6 SET PXX=""
+7 FOR
SET PXX=$ORDER(^TMP("PXVRPC4AIMM",$JOB,"CS",PXCODESYS,PXX))
if PXX=""
QUIT
Begin DoDot:2
+8 SET PXCODE=$PIECE($GET(^TMP("PXVRPC4AIMM",$JOB,"CS",PXCODESYS,PXX,0)),U,1)
+9 IF PXCODE=""
QUIT
+10 IF PXDEL
Begin DoDot:3
+11 SET PXCODESDEL("IMM",PXIMM,PXCODESYS,PXCODE)=""
+12 KILL PXCODESADD(PXCODESYS,PXCODE,"IMM",PXIMM)
End DoDot:3
+13 IF 'PXDEL
SET PXCODESADD(PXCODESYS,PXCODE,"IMM",PXIMM)=""
End DoDot:2
End DoDot:1
+14 KILL ^TMP("PXVRPC4AIMM",$JOB)
+15 QUIT
+16 ;
SK(PXVSK,PXVSKDEL,PXCODESADD,PXCODESDEL,PXNODE,PXVISITDT,PXRDCODE) ;
+1 NEW PXSK,PXSKTYP
+2 SET PXSK=$PIECE(PXNODE,U,2)
+3 IF PXSK=""
QUIT
+4 ;
+5 SET PXSKTYP="A"
+6 IF $PIECE(PXNODE,U,16)
SET PXSKTYP="R"
+7 ;
+8 ; if delete
IF $EXTRACT(PXNODE,3)="-"
Begin DoDot:1
+9 KILL PXVSK(PXSK)
+10 SET PXVSKDEL(PXSK)=""
+11 DO GETSKCODES(.PXCODESADD,.PXCODESDEL,PXSK,PXVISITDT,1)
+12 IF PXSKTYP="R"
IF PXRDCODE'=""
SET PXCODESDEL("SK",PXSK,"CPT",PXRDCODE)=""
End DoDot:1
QUIT
+13 ;
+14 SET PXVSK(PXSK)=""
+15 DO GETSKCODES(.PXCODESADD,,PXSK,PXVISITDT,0)
+16 IF PXSKTYP="R"
IF PXRDCODE'=""
SET PXCODESADD("CPT",PXRDCODE)=""
+17 QUIT
+18 ;
GETSKCODES(PXCODESADD,PXCODESDEL,PXSK,PXVISITDT,PXDEL) ;
+1 NEW PXSKCODES,PXX,PXCODESYS,PXCODE
+2 KILL PXSKCODES
+3 DO GETCS^PXVRPC8(.PXSKCODES,0,PXSK,PXVISITDT)
+4 SET PXX=0
+5 FOR
SET PXX=$ORDER(PXSKCODES(PXX))
if 'PXX
QUIT
Begin DoDot:1
+6 SET PXCODESYS=$PIECE($GET(PXSKCODES(PXX)),U,2)
+7 IF PXCODESYS'?1(1"CPT",1"10D")
QUIT
+8 SET PXCODE=$PIECE($GET(PXSKCODES(PXX)),U,3)
+9 IF PXCODE=""
QUIT
+10 IF PXDEL
Begin DoDot:2
+11 SET PXCODESDEL("SK",PXSK,PXCODESYS,PXCODE)=""
+12 KILL PXCODESADD(PXCODESYS,PXCODE,"SK",PXSK)
End DoDot:2
+13 IF 'PXDEL
SET PXCODESADD(PXCODESYS,PXCODE,"SK",PXSK)=""
End DoDot:1
+14 QUIT
+15 ;
CPT(PXVCPT,PXVCPTDEL,PXNODE) ;
+1 NEW PXCPT,PXQTY
+2 SET PXCPT=$PIECE(PXNODE,U,2)
+3 IF PXCPT=""
QUIT
+4 SET PXQTY=$PIECE(PXNODE,U,5)
+5 ;
+6 ; if delete
IF $EXTRACT(PXNODE,4)="-"
Begin DoDot:1
+7 KILL PXVCPT(PXCPT)
+8 SET PXVCPTDEL(PXCPT)=""
End DoDot:1
QUIT
+9 ;
+10 SET PXVCPT(PXCPT)="^"_PXQTY
+11 QUIT
+12 ;
ICD(PXVICD,PXVICDDEL,PXNODE) ;
+1 NEW PXICD
+2 SET PXICD=$PIECE(PXNODE,U,2)
+3 IF PXICD=""
QUIT
+4 ;
+5 ; if delete
IF $EXTRACT(PXNODE,4)="-"
Begin DoDot:1
+6 KILL PXVICD(PXICD)
+7 SET PXVICDDEL(PXICD)=""
End DoDot:1
QUIT
+8 ;
+9 SET PXVICD(PXICD)=""
+10 QUIT
+11 ;
GETADMCPT(PXRSLT,PXIMM,PXSERIES,PXDATE,PXCPTLIST) ;
+1 ;
+2 NEW PXADMACS,PXADMICS,PXFLD,PXI,PXJ,PXNODE,PXSUB,PXADMICNT,PXADMACNT,PXCODE
+3 ;
+4 SET PXRSLT=""
+5 SET PXIMM=$GET(PXIMM)
+6 SET PXSERIES=$GET(PXSERIES)
+7 IF '$GET(PXDATE)
SET PXDATE=DT
+8 ;
+9 IF 'PXIMM
QUIT
+10 ;
+11 SET PXSUB="PXVIMMCODE"
+12 KILL ^TMP(PXSUB,$JOB)
+13 DO GETCS^PXVRPC4(PXSUB,PXIMM,PXDATE)
+14 ;
+15 SET PXADMICS="CPTAI"_PXSERIES
+16 SET PXADMACS="CPTAA"_PXSERIES
+17 IF '$DATA(^TMP(PXSUB,$JOB,"CS",PXADMICS))
Begin DoDot:1
+18 SET PXADMICS="CPTAI"
+19 SET PXADMACS="CPTAA"
End DoDot:1
+20 ;
+21 SET PXADMICNT=0
+22 SET PXADMACNT=0
+23 FOR PXFLD=PXADMICS,PXADMACS
Begin DoDot:1
+24 IF '$DATA(^TMP(PXSUB,$JOB,"CS",PXFLD))
QUIT
+25 SET PXI=0
FOR
SET PXI=$ORDER(^TMP(PXSUB,$JOB,"CS",PXFLD,PXI))
if 'PXI
QUIT
Begin DoDot:2
+26 SET PXNODE=$GET(^TMP(PXSUB,$JOB,"CS",PXFLD,PXI,0))
+27 IF PXNODE=""
QUIT
+28 ;
+29 ; Take into account where mapping is CPT dependant (e.g., 91301-0011A)
+30 SET PXCODE=$PIECE(PXNODE,U,1)
+31 IF PXCODE["-"
Begin DoDot:3
+32 SET PXCODE=$$GETCPTCODE(PXCODE,.PXCPTLIST)
+33 SET $PIECE(PXNODE,U,1)=PXCODE
End DoDot:3
+34 IF PXCODE=""
QUIT
+35 ;
+36 IF PXFLD=PXADMICS
Begin DoDot:3
+37 SET PXADMICNT=PXADMICNT+1
+38 FOR PXJ=1:1:3
SET $PIECE(PXRSLT,U,PXJ)=$PIECE(PXNODE,U,PXJ)
End DoDot:3
+39 IF PXFLD=PXADMACS
Begin DoDot:3
+40 SET PXADMACNT=PXADMACNT+1
+41 FOR PXJ=4:1:6
SET $PIECE(PXRSLT,U,PXJ)=$PIECE(PXNODE,U,PXJ-3)
End DoDot:3
End DoDot:2
End DoDot:1
+42 ;
+43 ; If multiple codes are mapped to same imm and series, don't file admin codes
+44 IF PXADMICNT>1!(PXADMACNT>1)
SET PXRSLT=""
+45 ;
+46 KILL ^TMP(PXSUB,$JOB)
+47 QUIT
+48 ;
GETCPTCODE(PXCODE,PXCPTLIST) ;
+1 NEW PXCODE1,PXCODE2
+2 ;
+3 SET PXCODE1=$PIECE(PXCODE,"-",1)
+4 SET PXCODE2=$PIECE(PXCODE,"-",2)
+5 IF PXCODE1=""
QUIT ""
+6 IF $DATA(PXCPTLIST(PXCODE1))
QUIT PXCODE2
+7 ;
+8 QUIT ""
+9 ;
ISMAPTOADMCPT(PXIMM) ; Is it mapped to Series specific admin codes
+1 IF '$GET(PXIMM)
QUIT 0
+2 IF $ORDER(^AUTTIMM(PXIMM,3,"B","CPTAI"))["CPTAI"
QUIT 1
+3 QUIT 0
