PXKMAIN2 ;ISL/JVS - Special Routine ;Oct 23, 2018@12:50
;;1.0;PCE PATIENT CARE ENCOUNTER;**69,186,215,217**;Aug 12, 1996;Build 134
; VARIABLES
; See variables lists under each line tag
;
;
SPEC ;Populate other v files
;
; As of PX*1*215, this entry point (and related POP tag) has been deprecated and
; replaced with SPEC2. This is part of deprecating the PCE CODE MAPPING file,
; and instead using the CODING SYSTEM multiple from the Immunization and
; Skin Test files.
;
; VARIABLES
; PXKAV(0) = The AFTER variables created in PXKMAIN
; PXKBV(0) = The BEFORE variables created in PXKMAIN
; PXKFG(ED,DE,AD) =The EDIT,DELETE,ADD flags
; PXKCAT = The category being $o through (CPT,IMM etc...)
; PXKIN = The pointer value of first piece in the mapping file
; PXKPXD = An array with all the entries to be mapped this go around
; PXKDIEN = IEN of the coding file
;
S PXKDONE=0
Q:PXKFGED=1
I (PXKFGAD=1) D
.I $D(^PXD(811.1,"AA",PXKAV(0,1),""_PXKCAT_"",1)) D
..S PXKDONE=$O(^PXD(811.1,"AA",PXKAV(0,1),""_PXKCAT_"",1,PXKDONE))
..S PXJ(1)=$G(^PXD(811.1,PXKDONE,0)) ;8TH IEN
..S PXJ(2)=$P(PXJ(1),"^",2) ;SECOND PIECE OF 8TH IEN
..S PXJ(3)=$P(PXJ(2),";",1) ;FIRST PIECE OF ABOVE
..S PXJ(4)=$P(PXJ(1),"^",4) ;TO
..S PXKDONE=$O(^PXD(811.1,"AA",PXJ(3),""_PXJ(4)_"",1,0))
..S:PXKDONE="" PXKDONE=0 I '$D(PXKPXD($G(PXKDONE))) D POP
I (PXKFGDE=1) D
.I $D(^PXD(811.1,"AA",PXKBV(0,1),""_PXKCAT_"",1)) D
..S PXKDONE=$O(^PXD(811.1,"AA",PXKBV(0,1),""_PXKCAT_"",1,PXKDONE))
..S PXJ(1)=$G(^PXD(811.1,PXKDONE,0)) ;8TH IEN
..S PXJ(2)=$P(PXJ(1),"^",2) ;SECOND PIECE OF 8TH IEN
..S PXJ(3)=$P(PXJ(2),";",1) ;FIRST PIECE OF ABOVE
..S PXJ(4)=$P(PXJ(1),"^",4) ;TO
..S PXKDONE=$O(^PXD(811.1,"AA",PXJ(3),""_PXJ(4)_"",1,0))
..S:PXKDONE="" PXKDONE=0 I '$D(PXKPXD($G(PXKDONE))) D POP
K PXKDONE
Q
;
POP ;Population of more than one v file using PCE CODE MAPPING file 811.1
;
;N PXKPXD
N PXKROU,PXKIN,PXKX,PXKXX,PXKDIEN,PXKTO
S PXKIN=$S(PXKFGAD=1:PXKAV(0,1),PXKFGDE=1:PXKBV(0,1),1:"")
S PXKDIEN=0 F S PXKDIEN=$O(^PXD(811.1,"AA",PXKIN,PXKCAT,1,PXKDIEN)) Q:PXKDIEN="" D
.S PXKPXD(PXKDIEN)=$G(^PXD(811.1,PXKDIEN,0))
S (PXKX,PXKXX)=0 F S PXKX=$O(PXKPXD(PXKX)) Q:PXKX="" S PXKXX=PXKXX+.01 D
.I TMPPX[("^"_PXKX_"^") Q
.S PXKTO=$P(PXKPXD(PXKX),"^",4)
.S PXKROU=$P(PXKPXD(PXKX),"^",3)_"^PXKF"_PXKTO_"1" D @PXKROU
.S TMPPX=TMPPX_PXKX_"^"
S PXKNORG("SOR")=$G(^TMP("PXK",$J,"SOR"))
S PXKNORG("VSTIEN")=$G(^TMP("PXK",$J,"VST",1,"IEN"))
Q
;
;
SPEC2 ;
; Populates V CPT and V POV files based off Immunization and
; Skin Test Coding System mappings.
;
; As of PX*1*215, this entry point replaces SPEC.
; We now use the Coding System multiple instead of the PCE Code Mapping file.
;
N PXCODE,PXCODESYS,PXFROMENTRY,PXGLBL,PXKROU,PXKX,PXKXX,PXSKTYP,PXVISIT,PXVSC
;
I PXKFGED=1 Q
;
S PXFROMENTRY=$S(PXKFGAD=1:PXKAV(0,1),PXKFGDE=1:PXKBV(0,1),1:"0")
I 'PXFROMENTRY Q
;
I PXKCAT="IMM" S PXGLBL="^AUTTIMM("_PXFROMENTRY_")"
I PXKCAT="SK" S PXGLBL="^AUTTSK("_PXFROMENTRY_")"
; Only file codes from IMM/SK -> V CPT and V POV
I $G(PXGLBL)="" Q
;
; Only file for VA-Administered (non-historical) entries
S PXVISIT=$G(^TMP("PXK",$J,"VST",1,"IEN"))
S PXVSC=$P($G(^AUPNVSIT(+PXVISIT,0)),U,7)
I "AHISORD"'[PXVSC Q
;
; Is this a skin test placement ("A") or reading ("R")?
I PXKCAT="SK" D
. N X
. S X=$S(PXKFGAD=1:$G(PXKAV(12,8)),PXKFGDE=1:$P($G(@PXKREF@(PXKCAT,PXKSEQ,12,"BEFORE")),U,8),1:"")
. S PXSKTYP=$S(X:"R",1:"A")
;
F PXCODESYS="CPT","10D" D
. ;
. ; For Immunizations, don't delete ICD-10 code unless there are no more immunizations for the Visit
. I PXKCAT="IMM",PXKFGDE=1,PXCODESYS="10D",$O(^AUPNVIMM("AD",+PXVISIT,0)) Q
. ;
. S PXCODE=$$GETCODE(PXKCAT,PXGLBL,PXCODESYS,$G(PXSKTYP))
. I PXCODE="" Q
. ;
. I PXCODESYS="CPT" S PXCODE=$$CODEN^ICPTCOD(PXCODE)
. I PXCODESYS="10D" S PXCODE=+$$CODEN^ICDEX(PXCODE,80) ;IA 5747
. I PXCODE'>0 Q
. ;
. S PXKX=($O(PXKPXD(""),-1))+1
. S PXKPXD(PXKX)=PXFROMENTRY_";"_$S(PXKCAT="IMM":"AUTTIMM(",1:"AUTTSK(")
. S PXKPXD(PXKX)=PXKPXD(PXKX)_U_PXCODE_";"_$S(PXCODESYS="CPT":"ICPT(",1:"ICD9(")
. S PXKPXD(PXKX)=PXKPXD(PXKX)_U_PXKCAT_U_PXCODESYS_U_"1"
. S PXKXX=PXKX*.01
. ;
. S PXKROU=PXKCAT_"^PXKF"_$S(PXCODESYS="CPT":"CPT",1:"POV")_"1"
. D @PXKROU
. ;
. S PXKNORG("SOR")=$G(^TMP("PXK",$J,"SOR"))
. S PXKNORG("VSTIEN")=$G(^TMP("PXK",$J,"VST",1,"IEN"))
;
Q
;
;
GETCODE(PXKCAT,PXGLBL,PXCODESYS,PXSKTYP) ;
;
N PXCIEN,PXCODE,PXCOUNT,PXCSIEN
;
; For skin test reading, get CPT code from the PXV SKIN TEST READING CPT parameter
I PXKCAT="SK",$G(PXSKTYP)="R",PXCODESYS="CPT" D Q PXCODE
. S PXCODE=$$GET^XPAR("ALL","PXV SKIN TEST READING CPT",1,"I")
;
S PXCSIEN=$O(@PXGLBL@(3,"B",PXCODESYS,0))
I 'PXCSIEN Q ""
;
S PXCODE=""
S PXCOUNT=0
S PXCIEN=0
F S PXCIEN=$O(@PXGLBL@(3,PXCSIEN,1,PXCIEN)) Q:'PXCIEN D
. S PXCODE=$P($G(@PXGLBL@(3,PXCSIEN,1,PXCIEN,0)),U,1)
. S PXCOUNT=PXCOUNT+1
;
; Only file, when there is one code mapped to the IMM/SK entry
I PXCOUNT'=1 Q ""
;
Q PXCODE
;
;
RECALL ; Recall PXKMAIN to populate special circumstances
D EVENT^PXKMAIN K ^TMP("PXK",$J)
S PXKREF="^TMP(""PXKSAVE"",$J)"
F S PXKREF=$Q(@PXKREF) Q:$P(PXKREF,",",1)'["PXKSAVE" Q:$P(PXKREF,",",2)'[$J Q:PXKREF="" S PXKSAVE=PXKREF D
.S $P(PXKSAVE,"""",2)="PXK" S @PXKSAVE=$G(@PXKREF)
S ^TMP("PXK",$J,"SOR")=$G(PXKNORG("SOR"))
S ^TMP("PXK",$J,"VST",1,"IEN")=$G(PXKNORG("VSTIEN"))
K ^TMP("PXKSAVE",$J),PXKNORG
D EN1^PXKMAIN,EVENT^PXKMAIN
Q
;
;
PRVTYPE ;---POPULATE PROVIDER TYPE
;
;--**
I '$D(^TMP("PXK",$J,"PRV")) Q
I '$L($T(GET^XUA4A72)) Q
N PXKPSUB,PXKPRV,PXKDT,NOD0,TYPE
S PXKPSUB=0 F S PXKPSUB=$O(^TMP("PXK",$J,"PRV",PXKPSUB)) Q:PXKPSUB="" D
.S NOD0=$G(^TMP("PXK",$J,"PRV",PXKPSUB,0,"AFTER"))
.S PXKPRV=$P(NOD0,"^",1)
.I '$G(PXKPRV) Q
.S PXKDT=+$P($G(^AUPNVSIT($G(^TMP("PXK",$J,"VST",1,"IEN")),0)),"^",1)
.;--** ADD FUNCTION
.S TYPE=+$$GET^XUA4A72($G(PXKPRV),+$P($G(PXKDT),".")) Q:TYPE<1
.I $P(NOD0,"^",6)']"" S $P(NOD0,"^",6)=TYPE
.S ^TMP("PXK",$J,"PRV",PXKPSUB,0,"AFTER")=NOD0
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXKMAIN2 6187 printed Nov 22, 2024@17:39:29 Page 2
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
+2 ; VARIABLES
+3 ; See variables lists under each line tag
+4 ;
+5 ;
SPEC ;Populate other v files
+1 ;
+2 ; As of PX*1*215, this entry point (and related POP tag) has been deprecated and
+3 ; replaced with SPEC2. This is part of deprecating the PCE CODE MAPPING file,
+4 ; and instead using the CODING SYSTEM multiple from the Immunization and
+5 ; Skin Test files.
+6 ;
+7 ; VARIABLES
+8 ; PXKAV(0) = The AFTER variables created in PXKMAIN
+9 ; PXKBV(0) = The BEFORE variables created in PXKMAIN
+10 ; PXKFG(ED,DE,AD) =The EDIT,DELETE,ADD flags
+11 ; PXKCAT = The category being $o through (CPT,IMM etc...)
+12 ; PXKIN = The pointer value of first piece in the mapping file
+13 ; PXKPXD = An array with all the entries to be mapped this go around
+14 ; PXKDIEN = IEN of the coding file
+15 ;
+16 SET PXKDONE=0
+17 if PXKFGED=1
QUIT
+18 IF (PXKFGAD=1)
Begin DoDot:1
+19 IF $DATA(^PXD(811.1,"AA",PXKAV(0,1),""_PXKCAT_"",1))
Begin DoDot:2
+20 SET PXKDONE=$ORDER(^PXD(811.1,"AA",PXKAV(0,1),""_PXKCAT_"",1,PXKDONE))
+21 ;8TH IEN
SET PXJ(1)=$GET(^PXD(811.1,PXKDONE,0))
+22 ;SECOND PIECE OF 8TH IEN
SET PXJ(2)=$PIECE(PXJ(1),"^",2)
+23 ;FIRST PIECE OF ABOVE
SET PXJ(3)=$PIECE(PXJ(2),";",1)
+24 ;TO
SET PXJ(4)=$PIECE(PXJ(1),"^",4)
+25 SET PXKDONE=$ORDER(^PXD(811.1,"AA",PXJ(3),""_PXJ(4)_"",1,0))
+26 if PXKDONE=""
SET PXKDONE=0
IF '$DATA(PXKPXD($GET(PXKDONE)))
DO POP
End DoDot:2
End DoDot:1
+27 IF (PXKFGDE=1)
Begin DoDot:1
+28 IF $DATA(^PXD(811.1,"AA",PXKBV(0,1),""_PXKCAT_"",1))
Begin DoDot:2
+29 SET PXKDONE=$ORDER(^PXD(811.1,"AA",PXKBV(0,1),""_PXKCAT_"",1,PXKDONE))
+30 ;8TH IEN
SET PXJ(1)=$GET(^PXD(811.1,PXKDONE,0))
+31 ;SECOND PIECE OF 8TH IEN
SET PXJ(2)=$PIECE(PXJ(1),"^",2)
+32 ;FIRST PIECE OF ABOVE
SET PXJ(3)=$PIECE(PXJ(2),";",1)
+33 ;TO
SET PXJ(4)=$PIECE(PXJ(1),"^",4)
+34 SET PXKDONE=$ORDER(^PXD(811.1,"AA",PXJ(3),""_PXJ(4)_"",1,0))
+35 if PXKDONE=""
SET PXKDONE=0
IF '$DATA(PXKPXD($GET(PXKDONE)))
DO POP
End DoDot:2
End DoDot:1
+36 KILL PXKDONE
+37 QUIT
+38 ;
POP ;Population of more than one v file using PCE CODE MAPPING file 811.1
+1 ;
+2 ;N PXKPXD
+3 NEW PXKROU,PXKIN,PXKX,PXKXX,PXKDIEN,PXKTO
+4 SET PXKIN=$SELECT(PXKFGAD=1:PXKAV(0,1),PXKFGDE=1:PXKBV(0,1),1:"")
+5 SET PXKDIEN=0
FOR
SET PXKDIEN=$ORDER(^PXD(811.1,"AA",PXKIN,PXKCAT,1,PXKDIEN))
if PXKDIEN=""
QUIT
Begin DoDot:1
+6 SET PXKPXD(PXKDIEN)=$GET(^PXD(811.1,PXKDIEN,0))
End DoDot:1
+7 SET (PXKX,PXKXX)=0
FOR
SET PXKX=$ORDER(PXKPXD(PXKX))
if PXKX=""
QUIT
SET PXKXX=PXKXX+.01
Begin DoDot:1
+8 IF TMPPX[("^"_PXKX_"^")
QUIT
+9 SET PXKTO=$PIECE(PXKPXD(PXKX),"^",4)
+10 SET PXKROU=$PIECE(PXKPXD(PXKX),"^",3)_"^PXKF"_PXKTO_"1"
DO @PXKROU
+11 SET TMPPX=TMPPX_PXKX_"^"
End DoDot:1
+12 SET PXKNORG("SOR")=$GET(^TMP("PXK",$JOB,"SOR"))
+13 SET PXKNORG("VSTIEN")=$GET(^TMP("PXK",$JOB,"VST",1,"IEN"))
+14 QUIT
+15 ;
+16 ;
SPEC2 ;
+1 ; Populates V CPT and V POV files based off Immunization and
+2 ; Skin Test Coding System mappings.
+3 ;
+4 ; As of PX*1*215, this entry point replaces SPEC.
+5 ; We now use the Coding System multiple instead of the PCE Code Mapping file.
+6 ;
+7 NEW PXCODE,PXCODESYS,PXFROMENTRY,PXGLBL,PXKROU,PXKX,PXKXX,PXSKTYP,PXVISIT,PXVSC
+8 ;
+9 IF PXKFGED=1
QUIT
+10 ;
+11 SET PXFROMENTRY=$SELECT(PXKFGAD=1:PXKAV(0,1),PXKFGDE=1:PXKBV(0,1),1:"0")
+12 IF 'PXFROMENTRY
QUIT
+13 ;
+14 IF PXKCAT="IMM"
SET PXGLBL="^AUTTIMM("_PXFROMENTRY_")"
+15 IF PXKCAT="SK"
SET PXGLBL="^AUTTSK("_PXFROMENTRY_")"
+16 ; Only file codes from IMM/SK -> V CPT and V POV
+17 IF $GET(PXGLBL)=""
QUIT
+18 ;
+19 ; Only file for VA-Administered (non-historical) entries
+20 SET PXVISIT=$GET(^TMP("PXK",$JOB,"VST",1,"IEN"))
+21 SET PXVSC=$PIECE($GET(^AUPNVSIT(+PXVISIT,0)),U,7)
+22 IF "AHISORD"'[PXVSC
QUIT
+23 ;
+24 ; Is this a skin test placement ("A") or reading ("R")?
+25 IF PXKCAT="SK"
Begin DoDot:1
+26 NEW X
+27 SET X=$SELECT(PXKFGAD=1:$GET(PXKAV(12,8)),PXKFGDE=1:$PIECE($GET(@PXKREF@(PXKCAT,PXKSEQ,12,"BEFORE")),U,8),1:"")
+28 SET PXSKTYP=$SELECT(X:"R",1:"A")
End DoDot:1
+29 ;
+30 FOR PXCODESYS="CPT","10D"
Begin DoDot:1
+31 ;
+32 ; For Immunizations, don't delete ICD-10 code unless there are no more immunizations for the Visit
+33 IF PXKCAT="IMM"
IF PXKFGDE=1
IF PXCODESYS="10D"
IF $ORDER(^AUPNVIMM("AD",+PXVISIT,0))
QUIT
+34 ;
+35 SET PXCODE=$$GETCODE(PXKCAT,PXGLBL,PXCODESYS,$GET(PXSKTYP))
+36 IF PXCODE=""
QUIT
+37 ;
+38 IF PXCODESYS="CPT"
SET PXCODE=$$CODEN^ICPTCOD(PXCODE)
+39 ;IA 5747
IF PXCODESYS="10D"
SET PXCODE=+$$CODEN^ICDEX(PXCODE,80)
+40 IF PXCODE'>0
QUIT
+41 ;
+42 SET PXKX=($ORDER(PXKPXD(""),-1))+1
+43 SET PXKPXD(PXKX)=PXFROMENTRY_";"_$SELECT(PXKCAT="IMM":"AUTTIMM(",1:"AUTTSK(")
+44 SET PXKPXD(PXKX)=PXKPXD(PXKX)_U_PXCODE_";"_$SELECT(PXCODESYS="CPT":"ICPT(",1:"ICD9(")
+45 SET PXKPXD(PXKX)=PXKPXD(PXKX)_U_PXKCAT_U_PXCODESYS_U_"1"
+46 SET PXKXX=PXKX*.01
+47 ;
+48 SET PXKROU=PXKCAT_"^PXKF"_$SELECT(PXCODESYS="CPT":"CPT",1:"POV")_"1"
+49 DO @PXKROU
+50 ;
+51 SET PXKNORG("SOR")=$GET(^TMP("PXK",$JOB,"SOR"))
+52 SET PXKNORG("VSTIEN")=$GET(^TMP("PXK",$JOB,"VST",1,"IEN"))
End DoDot:1
+53 ;
+54 QUIT
+55 ;
+56 ;
GETCODE(PXKCAT,PXGLBL,PXCODESYS,PXSKTYP) ;
+1 ;
+2 NEW PXCIEN,PXCODE,PXCOUNT,PXCSIEN
+3 ;
+4 ; For skin test reading, get CPT code from the PXV SKIN TEST READING CPT parameter
+5 IF PXKCAT="SK"
IF $GET(PXSKTYP)="R"
IF PXCODESYS="CPT"
Begin DoDot:1
+6 SET PXCODE=$$GET^XPAR("ALL","PXV SKIN TEST READING CPT",1,"I")
End DoDot:1
QUIT PXCODE
+7 ;
+8 SET PXCSIEN=$ORDER(@PXGLBL@(3,"B",PXCODESYS,0))
+9 IF 'PXCSIEN
QUIT ""
+10 ;
+11 SET PXCODE=""
+12 SET PXCOUNT=0
+13 SET PXCIEN=0
+14 FOR
SET PXCIEN=$ORDER(@PXGLBL@(3,PXCSIEN,1,PXCIEN))
if 'PXCIEN
QUIT
Begin DoDot:1
+15 SET PXCODE=$PIECE($GET(@PXGLBL@(3,PXCSIEN,1,PXCIEN,0)),U,1)
+16 SET PXCOUNT=PXCOUNT+1
End DoDot:1
+17 ;
+18 ; Only file, when there is one code mapped to the IMM/SK entry
+19 IF PXCOUNT'=1
QUIT ""
+20 ;
+21 QUIT PXCODE
+22 ;
+23 ;
RECALL ; Recall PXKMAIN to populate special circumstances
+1 DO EVENT^PXKMAIN
KILL ^TMP("PXK",$JOB)
+2 SET PXKREF="^TMP(""PXKSAVE"",$J)"
+3 FOR
SET PXKREF=$QUERY(@PXKREF)
if $PIECE(PXKREF,",",1)'["PXKSAVE"
QUIT
if $PIECE(PXKREF,",",2)'[$JOB
QUIT
if PXKREF=""
QUIT
SET PXKSAVE=PXKREF
Begin DoDot:1
+4 SET $PIECE(PXKSAVE,"""",2)="PXK"
SET @PXKSAVE=$GET(@PXKREF)
End DoDot:1
+5 SET ^TMP("PXK",$JOB,"SOR")=$GET(PXKNORG("SOR"))
+6 SET ^TMP("PXK",$JOB,"VST",1,"IEN")=$GET(PXKNORG("VSTIEN"))
+7 KILL ^TMP("PXKSAVE",$JOB),PXKNORG
+8 DO EN1^PXKMAIN
DO EVENT^PXKMAIN
+9 QUIT
+10 ;
+11 ;
PRVTYPE ;---POPULATE PROVIDER TYPE
+1 ;
+2 ;--**
+3 IF '$DATA(^TMP("PXK",$JOB,"PRV"))
QUIT
+4 IF '$LENGTH($TEXT(GET^XUA4A72))
QUIT
+5 NEW PXKPSUB,PXKPRV,PXKDT,NOD0,TYPE
+6 SET PXKPSUB=0
FOR
SET PXKPSUB=$ORDER(^TMP("PXK",$JOB,"PRV",PXKPSUB))
if PXKPSUB=""
QUIT
Begin DoDot:1
+7 SET NOD0=$GET(^TMP("PXK",$JOB,"PRV",PXKPSUB,0,"AFTER"))
+8 SET PXKPRV=$PIECE(NOD0,"^",1)
+9 IF '$GET(PXKPRV)
QUIT
+10 SET PXKDT=+$PIECE($GET(^AUPNVSIT($GET(^TMP("PXK",$JOB,"VST",1,"IEN")),0)),"^",1)
+11 ;--** ADD FUNCTION
+12 SET TYPE=+$$GET^XUA4A72($GET(PXKPRV),+$PIECE($GET(PXKDT),"."))
if TYPE<1
QUIT
+13 IF $PIECE(NOD0,"^",6)']""
SET $PIECE(NOD0,"^",6)=TYPE
+14 SET ^TMP("PXK",$JOB,"PRV",PXKPSUB,0,"AFTER")=NOD0
End DoDot:1
+15 QUIT
