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

PXKMAIN2.m

Go to the documentation of this file.
  1. PXKMAIN2 ;ISL/JVS - Special Routine ;Oct 23, 2018@12:50
  1. ;;1.0;PCE PATIENT CARE ENCOUNTER;**69,186,215,217**;Aug 12, 1996;Build 134
  1. ; VARIABLES
  1. ; See variables lists under each line tag
  1. ;
  1. ;
  1. SPEC ;Populate other v files
  1. ;
  1. ; As of PX*1*215, this entry point (and related POP tag) has been deprecated and
  1. ; replaced with SPEC2. This is part of deprecating the PCE CODE MAPPING file,
  1. ; and instead using the CODING SYSTEM multiple from the Immunization and
  1. ; Skin Test files.
  1. ;
  1. ; VARIABLES
  1. ; PXKAV(0) = The AFTER variables created in PXKMAIN
  1. ; PXKBV(0) = The BEFORE variables created in PXKMAIN
  1. ; PXKFG(ED,DE,AD) =The EDIT,DELETE,ADD flags
  1. ; PXKCAT = The category being $o through (CPT,IMM etc...)
  1. ; PXKIN = The pointer value of first piece in the mapping file
  1. ; PXKPXD = An array with all the entries to be mapped this go around
  1. ; PXKDIEN = IEN of the coding file
  1. ;
  1. S PXKDONE=0
  1. Q:PXKFGED=1
  1. I (PXKFGAD=1) D
  1. .I $D(^PXD(811.1,"AA",PXKAV(0,1),""_PXKCAT_"",1)) D
  1. ..S PXKDONE=$O(^PXD(811.1,"AA",PXKAV(0,1),""_PXKCAT_"",1,PXKDONE))
  1. ..S PXJ(1)=$G(^PXD(811.1,PXKDONE,0)) ;8TH IEN
  1. ..S PXJ(2)=$P(PXJ(1),"^",2) ;SECOND PIECE OF 8TH IEN
  1. ..S PXJ(3)=$P(PXJ(2),";",1) ;FIRST PIECE OF ABOVE
  1. ..S PXJ(4)=$P(PXJ(1),"^",4) ;TO
  1. ..S PXKDONE=$O(^PXD(811.1,"AA",PXJ(3),""_PXJ(4)_"",1,0))
  1. ..S:PXKDONE="" PXKDONE=0 I '$D(PXKPXD($G(PXKDONE))) D POP
  1. I (PXKFGDE=1) D
  1. .I $D(^PXD(811.1,"AA",PXKBV(0,1),""_PXKCAT_"",1)) D
  1. ..S PXKDONE=$O(^PXD(811.1,"AA",PXKBV(0,1),""_PXKCAT_"",1,PXKDONE))
  1. ..S PXJ(1)=$G(^PXD(811.1,PXKDONE,0)) ;8TH IEN
  1. ..S PXJ(2)=$P(PXJ(1),"^",2) ;SECOND PIECE OF 8TH IEN
  1. ..S PXJ(3)=$P(PXJ(2),";",1) ;FIRST PIECE OF ABOVE
  1. ..S PXJ(4)=$P(PXJ(1),"^",4) ;TO
  1. ..S PXKDONE=$O(^PXD(811.1,"AA",PXJ(3),""_PXJ(4)_"",1,0))
  1. ..S:PXKDONE="" PXKDONE=0 I '$D(PXKPXD($G(PXKDONE))) D POP
  1. K PXKDONE
  1. Q
  1. ;
  1. POP ;Population of more than one v file using PCE CODE MAPPING file 811.1
  1. ;
  1. ;N PXKPXD
  1. N PXKROU,PXKIN,PXKX,PXKXX,PXKDIEN,PXKTO
  1. S PXKIN=$S(PXKFGAD=1:PXKAV(0,1),PXKFGDE=1:PXKBV(0,1),1:"")
  1. S PXKDIEN=0 F S PXKDIEN=$O(^PXD(811.1,"AA",PXKIN,PXKCAT,1,PXKDIEN)) Q:PXKDIEN="" D
  1. .S PXKPXD(PXKDIEN)=$G(^PXD(811.1,PXKDIEN,0))
  1. S (PXKX,PXKXX)=0 F S PXKX=$O(PXKPXD(PXKX)) Q:PXKX="" S PXKXX=PXKXX+.01 D
  1. .I TMPPX[("^"_PXKX_"^") Q
  1. .S PXKTO=$P(PXKPXD(PXKX),"^",4)
  1. .S PXKROU=$P(PXKPXD(PXKX),"^",3)_"^PXKF"_PXKTO_"1" D @PXKROU
  1. .S TMPPX=TMPPX_PXKX_"^"
  1. S PXKNORG("SOR")=$G(^TMP("PXK",$J,"SOR"))
  1. S PXKNORG("VSTIEN")=$G(^TMP("PXK",$J,"VST",1,"IEN"))
  1. Q
  1. ;
  1. ;
  1. SPEC2 ;
  1. ; Populates V CPT and V POV files based off Immunization and
  1. ; Skin Test Coding System mappings.
  1. ;
  1. ; As of PX*1*215, this entry point replaces SPEC.
  1. ; We now use the Coding System multiple instead of the PCE Code Mapping file.
  1. ;
  1. N PXCODE,PXCODESYS,PXFROMENTRY,PXGLBL,PXKROU,PXKX,PXKXX,PXSKTYP,PXVISIT,PXVSC
  1. ;
  1. I PXKFGED=1 Q
  1. ;
  1. S PXFROMENTRY=$S(PXKFGAD=1:PXKAV(0,1),PXKFGDE=1:PXKBV(0,1),1:"0")
  1. I 'PXFROMENTRY Q
  1. ;
  1. I PXKCAT="IMM" S PXGLBL="^AUTTIMM("_PXFROMENTRY_")"
  1. I PXKCAT="SK" S PXGLBL="^AUTTSK("_PXFROMENTRY_")"
  1. ; Only file codes from IMM/SK -> V CPT and V POV
  1. I $G(PXGLBL)="" Q
  1. ;
  1. ; Only file for VA-Administered (non-historical) entries
  1. S PXVISIT=$G(^TMP("PXK",$J,"VST",1,"IEN"))
  1. S PXVSC=$P($G(^AUPNVSIT(+PXVISIT,0)),U,7)
  1. I "AHISORD"'[PXVSC Q
  1. ;
  1. ; Is this a skin test placement ("A") or reading ("R")?
  1. I PXKCAT="SK" D
  1. . N X
  1. . S X=$S(PXKFGAD=1:$G(PXKAV(12,8)),PXKFGDE=1:$P($G(@PXKREF@(PXKCAT,PXKSEQ,12,"BEFORE")),U,8),1:"")
  1. . S PXSKTYP=$S(X:"R",1:"A")
  1. ;
  1. F PXCODESYS="CPT","10D" D
  1. . ;
  1. . ; For Immunizations, don't delete ICD-10 code unless there are no more immunizations for the Visit
  1. . I PXKCAT="IMM",PXKFGDE=1,PXCODESYS="10D",$O(^AUPNVIMM("AD",+PXVISIT,0)) Q
  1. . ;
  1. . S PXCODE=$$GETCODE(PXKCAT,PXGLBL,PXCODESYS,$G(PXSKTYP))
  1. . I PXCODE="" Q
  1. . ;
  1. . I PXCODESYS="CPT" S PXCODE=$$CODEN^ICPTCOD(PXCODE)
  1. . I PXCODESYS="10D" S PXCODE=+$$CODEN^ICDEX(PXCODE,80) ;IA 5747
  1. . I PXCODE'>0 Q
  1. . ;
  1. . S PXKX=($O(PXKPXD(""),-1))+1
  1. . S PXKPXD(PXKX)=PXFROMENTRY_";"_$S(PXKCAT="IMM":"AUTTIMM(",1:"AUTTSK(")
  1. . S PXKPXD(PXKX)=PXKPXD(PXKX)_U_PXCODE_";"_$S(PXCODESYS="CPT":"ICPT(",1:"ICD9(")
  1. . S PXKPXD(PXKX)=PXKPXD(PXKX)_U_PXKCAT_U_PXCODESYS_U_"1"
  1. . S PXKXX=PXKX*.01
  1. . ;
  1. . S PXKROU=PXKCAT_"^PXKF"_$S(PXCODESYS="CPT":"CPT",1:"POV")_"1"
  1. . D @PXKROU
  1. . ;
  1. . S PXKNORG("SOR")=$G(^TMP("PXK",$J,"SOR"))
  1. . S PXKNORG("VSTIEN")=$G(^TMP("PXK",$J,"VST",1,"IEN"))
  1. ;
  1. Q
  1. ;
  1. ;
  1. GETCODE(PXKCAT,PXGLBL,PXCODESYS,PXSKTYP) ;
  1. ;
  1. N PXCIEN,PXCODE,PXCOUNT,PXCSIEN
  1. ;
  1. ; For skin test reading, get CPT code from the PXV SKIN TEST READING CPT parameter
  1. I PXKCAT="SK",$G(PXSKTYP)="R",PXCODESYS="CPT" D Q PXCODE
  1. . S PXCODE=$$GET^XPAR("ALL","PXV SKIN TEST READING CPT",1,"I")
  1. ;
  1. S PXCSIEN=$O(@PXGLBL@(3,"B",PXCODESYS,0))
  1. I 'PXCSIEN Q ""
  1. ;
  1. S PXCODE=""
  1. S PXCOUNT=0
  1. S PXCIEN=0
  1. F S PXCIEN=$O(@PXGLBL@(3,PXCSIEN,1,PXCIEN)) Q:'PXCIEN D
  1. . S PXCODE=$P($G(@PXGLBL@(3,PXCSIEN,1,PXCIEN,0)),U,1)
  1. . S PXCOUNT=PXCOUNT+1
  1. ;
  1. ; Only file, when there is one code mapped to the IMM/SK entry
  1. I PXCOUNT'=1 Q ""
  1. ;
  1. Q PXCODE
  1. ;
  1. ;
  1. RECALL ; Recall PXKMAIN to populate special circumstances
  1. D EVENT^PXKMAIN K ^TMP("PXK",$J)
  1. S PXKREF="^TMP(""PXKSAVE"",$J)"
  1. F S PXKREF=$Q(@PXKREF) Q:$P(PXKREF,",",1)'["PXKSAVE" Q:$P(PXKREF,",",2)'[$J Q:PXKREF="" S PXKSAVE=PXKREF D
  1. .S $P(PXKSAVE,"""",2)="PXK" S @PXKSAVE=$G(@PXKREF)
  1. S ^TMP("PXK",$J,"SOR")=$G(PXKNORG("SOR"))
  1. S ^TMP("PXK",$J,"VST",1,"IEN")=$G(PXKNORG("VSTIEN"))
  1. K ^TMP("PXKSAVE",$J),PXKNORG
  1. D EN1^PXKMAIN,EVENT^PXKMAIN
  1. Q
  1. ;
  1. ;
  1. PRVTYPE ;---POPULATE PROVIDER TYPE
  1. ;
  1. ;--**
  1. I '$D(^TMP("PXK",$J,"PRV")) Q
  1. I '$L($T(GET^XUA4A72)) Q
  1. N PXKPSUB,PXKPRV,PXKDT,NOD0,TYPE
  1. S PXKPSUB=0 F S PXKPSUB=$O(^TMP("PXK",$J,"PRV",PXKPSUB)) Q:PXKPSUB="" D
  1. .S NOD0=$G(^TMP("PXK",$J,"PRV",PXKPSUB,0,"AFTER"))
  1. .S PXKPRV=$P(NOD0,"^",1)
  1. .I '$G(PXKPRV) Q
  1. .S PXKDT=+$P($G(^AUPNVSIT($G(^TMP("PXK",$J,"VST",1,"IEN")),0)),"^",1)
  1. .;--** ADD FUNCTION
  1. .S TYPE=+$$GET^XUA4A72($G(PXKPRV),+$P($G(PXKDT),".")) Q:TYPE<1
  1. .I $P(NOD0,"^",6)']"" S $P(NOD0,"^",6)=TYPE
  1. .S ^TMP("PXK",$J,"PRV",PXKPSUB,0,"AFTER")=NOD0
  1. Q