Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PXVRPC4A

PXVRPC4A.m

Go to the documentation of this file.
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