PXAICPT ;ISL/JVS,ISA/KWP,ESW - SET THE PROCEDURE(CPT) NODES ; 4/18/03 12:17pm
;;1.0;PCE PATIENT CARE ENCOUNTER;**19,73,108,112**;Aug 12, 1996
;
;
Q
CPT ;--CREAT PROVIDERS
;
;
SET ;--SET AND NEW VARIABLES
N AFTER0,AFTER1,AFTER12,AFTER801,AFTER802,AFTER811,AFTER812
N BEFOR0,BEFOR1,BEFOR12,BEFOR801,BEFOR802,BEFOR811,BEFOR812
N PXAA,PXAB,SUB,PIECE,PXAAX,IENB,STOP
;New Modifier Variables
D SET^PXAIMOD
K PXAERR
S PXAERR(8)=PXAK
S PXAERR(7)="PROCEDURE"
;
S SUB="" F S SUB=$O(@PXADATA@("PROCEDURE",PXAK,SUB)) Q:SUB="" D
.S PXAA(SUB)=$G(@PXADATA@("PROCEDURE",PXAK,SUB))
;Setup PXAA array for Modifiers
S SUB=""
F S SUB=$O(@PXADATA@("PROCEDURE",PXAK,"MODIFIERS",SUB)) Q:SUB="" D
.S PXAA("MODIFIERS",SUB)=""
;
VAL ;--VALIDATE ENOUGH DATA
D VAL^PXAICPTV Q:$G(STOP)
;
;
SETVARA ;--SET VISIT VARIABLES
S $P(AFTER0,"^",1)=$G(PXAA("PROCEDURE"))
I $G(PXAA("DELETE")) S $P(AFTER0,"^",1)="@"
S $P(AFTER0,"^",2)=$G(PATIENT)
S $P(AFTER0,"^",3)=$G(PXAVISIT)
S $P(AFTER0,"^",4)=$G(PXAA("NARRATIVE")) D
.I $G(PXAA("NARRATIVE"))']""!($L($G(PXAA("NARRATIVE")))>245) D
..S $P(AFTER0,"^",4)=$$EXTTEXT^PXUTL1($G(PXAA("PROCEDURE")),1,81,2) ;--TEXT OF NARRATIVE
.I $G(PXAA("NARRATIVE"))]"" S $P(AFTER0,"^",4)=+$$PROVNARR^PXAPI($G(PXAA("NARRATIVE")),9000010.18)
I $P(AFTER0,"^",4)<0 D VAL04^PXAICPTV,ERR^PXAI Q:$D(STOP)
S $P(AFTER0,"^",5)=$G(PXAA("DIAGNOSIS"))
I $G(PXAA("QTY"))="" S PXAA("QTY")=1
S $P(AFTER0,"^",16)=$G(PXAA("QTY")) I $G(PXAA("QTY"))<1 S PXAA("DELETE")=1
;Set Modifier nodes in AFTER1
D SETVARA^PXAIMOD
;
S $P(AFTER12,"^",1)=$G(PXAA("EVENT D/T"))
S $P(AFTER12,"^",4)=$G(PXAA("ENC PROVIDER"))
;PX*1*108 - do not try to file a provider from a "DELETED" cpt
I $G(PXAA("ENC PROVIDER"))]"",'$G(PXAA("DELETE")) D
.S ^TMP("PXAIADDPRV",$J,$G(PXAA("ENC PROVIDER")))=""
;
S $P(AFTER802,"^",1)=$G(PXAA("CATEGORY"))
I $G(PXAA("CATEGORY"))]"" S $P(AFTER802,"^",1)=+$$PROVNARR^PXAPI($G(PXAA("CATEGORY")),9000010.18)
I $P(AFTER802,"^",1)<0 D VAL45^PXAICPTV,ERR^PXAI Q:$D(STOP)
S $P(AFTER811,"^",1)=$G(PXAA("COMMENT"))
;
;
;
;--PACKAGE AND SOURCE
;
S $P(AFTER812,"^",2)=$G(PXAPKG)
S $P(AFTER812,"^",3)=$G(PXASOURC)
;
SETPXKA ;--SET PXK ARRAY AFTER
S ^TMP("PXK",$J,"CPT",PXAK,0,"AFTER")=AFTER0
;Set ^TMP("PXK",$J,"CPT",PXAK,1,ien,"AFTER")=MODIEN
D SETPXKA^PXAIMOD
S ^TMP("PXK",$J,"CPT",PXAK,12,"AFTER")=AFTER12
S ^TMP("PXK",$J,"CPT",PXAK,802,"AFTER")=AFTER802
S ^TMP("PXK",$J,"CPT",PXAK,811,"AFTER")=AFTER811
S ^TMP("PXK",$J,"CPT",PXAK,812,"AFTER")=AFTER812
;
SETVARB ;--SET VARIABLES BEFORE
D
.N PXBKY,PXBSAM,PXBSKY,PXBCNT,PXI,PRV,ITEM
.D CPT^PXBGCPT(PXAVISIT)
.S PXAAX("PROCEDURE")=$P($G(^ICPT($G(PXAA("PROCEDURE")),0)),"^",1)
.I $G(PXAA("DELETE"))=1 S PXAAX("PROCEDURE")=$P($G(^ICPT($G(PXAA("PROCEDURE")),0)),"^",1)
.S ITEM=""
.I PXBCNT>0,$G(PXAAX("PROCEDURE"))]"" S ITEM=$O(PXBKY(PXAAX("PROCEDURE"),0))
.I ITEM]"" D
..;--LOOK UP USING CPT AND PROVIDER
..S PXI="" F S PXI=$O(PXBKY(PXAAX("PROCEDURE"),PXI)) Q:PXI="" D
...I $D(^IBE(357.69,PXAAX("PROCEDURE"))) D Q ;DBIA #: 1906
....S (^TMP("PXK",$J,"CPT",PXAK,"IEN"),IENB)=$O(PXBSKY(PXI,0))
...I $G(PXAA("ENC PROVIDER")) D Q
....S PRV=$P(^VA(200,$G(PXAA("ENC PROVIDER")),0),"^",1)
....I $P($G(PXBKY(PXAAX("PROCEDURE"),PXI)),"^",3)=PRV D
.....S (^TMP("PXK",$J,"CPT",PXAK,"IEN"),IENB)=$O(PXBSKY(PXI,0))
I $G(IENB) D
.F PIECE=0,12,802,811,812 S ^TMP("PXK",$J,"CPT",PXAK,PIECE,"BEFORE")=$G(^AUPNVCPT(IENB,PIECE))
.;Set ^TMP("PXK",$J,"CPT",PXAK,1,ien,"BEFORE")=MODIEN
.D SETVARB^PXAIMOD
E D
.S (BEFOR0,BEFOR12,BEFOR802,BEFOR811,BEFOR812)=""
.;
SETPXKB .;--SET PXK ARRAY BEFORE
.S ^TMP("PXK",$J,"CPT",PXAK,0,"BEFORE")=BEFOR0
.;Set ^TMP("PXK",$J,"CPT",PXAK,1,ien,"BEFORE")=MODIEN
.D SETPXKB^PXAIMOD
.S ^TMP("PXK",$J,"CPT",PXAK,12,"BEFORE")=BEFOR12
.S ^TMP("PXK",$J,"CPT",PXAK,802,"BEFORE")=BEFOR802
.S ^TMP("PXK",$J,"CPT",PXAK,811,"BEFORE")=BEFOR811
.S ^TMP("PXK",$J,"CPT",PXAK,812,"BEFORE")=BEFOR812
.S ^TMP("PXK",$J,"CPT",PXAK,"IEN")=""
;
MISC ;--MISCELLANEOUS NODE
;
Q
PXAICPT ;ISL/JVS,ISA/KWP,ESW - SET THE PROCEDURE(CPT) NODES ; 4/18/03 12:17pm
+1 ;;1.0;PCE PATIENT CARE ENCOUNTER;**19,73,108,112**;Aug 12, 1996
+2 ;
+3 ;
+4 QUIT
CPT ;--CREAT PROVIDERS
+1 ;
+2 ;
SET ;--SET AND NEW VARIABLES
+1 NEW AFTER0,AFTER1,AFTER12,AFTER801,AFTER802,AFTER811,AFTER812
+2 NEW BEFOR0,BEFOR1,BEFOR12,BEFOR801,BEFOR802,BEFOR811,BEFOR812
+3 NEW PXAA,PXAB,SUB,PIECE,PXAAX,IENB,STOP
+4 ;New Modifier Variables
+5 DO SET^PXAIMOD
+6 KILL PXAERR
+7 SET PXAERR(8)=PXAK
+8 SET PXAERR(7)="PROCEDURE"
+9 ;
+10 SET SUB=""
FOR
SET SUB=$ORDER(@PXADATA@("PROCEDURE",PXAK,SUB))
IF SUB=""
QUIT
Begin DoDot:1
+11 SET PXAA(SUB)=$GET(@PXADATA@("PROCEDURE",PXAK,SUB))
End DoDot:1
+12 ;Setup PXAA array for Modifiers
+13 SET SUB=""
+14 FOR
SET SUB=$ORDER(@PXADATA@("PROCEDURE",PXAK,"MODIFIERS",SUB))
IF SUB=""
QUIT
Begin DoDot:1
+15 SET PXAA("MODIFIERS",SUB)=""
End DoDot:1
+16 ;
VAL ;--VALIDATE ENOUGH DATA
+1 DO VAL^PXAICPTV
IF $GET(STOP)
QUIT
+2 ;
+3 ;
SETVARA ;--SET VISIT VARIABLES
+1 SET $PIECE(AFTER0,"^",1)=$GET(PXAA("PROCEDURE"))
+2 IF $GET(PXAA("DELETE"))
SET $PIECE(AFTER0,"^",1)="@"
+3 SET $PIECE(AFTER0,"^",2)=$GET(PATIENT)
+4 SET $PIECE(AFTER0,"^",3)=$GET(PXAVISIT)
+5 SET $PIECE(AFTER0,"^",4)=$GET(PXAA("NARRATIVE"))
Begin DoDot:1
+6 IF $GET(PXAA("NARRATIVE"))']""!($LENGTH($GET(PXAA("NARRATIVE")))>245)
Begin DoDot:2
+7 ;--TEXT OF NARRATIVE
SET $PIECE(AFTER0,"^",4)=$$EXTTEXT^PXUTL1($GET(PXAA("PROCEDURE")),1,81,2)
End DoDot:2
+8 IF $GET(PXAA("NARRATIVE"))]""
SET $PIECE(AFTER0,"^",4)=+$$PROVNARR^PXAPI($GET(PXAA("NARRATIVE")),9000010.18)
End DoDot:1
+9 IF $PIECE(AFTER0,"^",4)<0
DO VAL04^PXAICPTV
DO ERR^PXAI
IF $DATA(STOP)
QUIT
+10 SET $PIECE(AFTER0,"^",5)=$GET(PXAA("DIAGNOSIS"))
+11 IF $GET(PXAA("QTY"))=""
SET PXAA("QTY")=1
+12 SET $PIECE(AFTER0,"^",16)=$GET(PXAA("QTY"))
IF $GET(PXAA("QTY"))<1
SET PXAA("DELETE")=1
+13 ;Set Modifier nodes in AFTER1
+14 DO SETVARA^PXAIMOD
+15 ;
+16 SET $PIECE(AFTER12,"^",1)=$GET(PXAA("EVENT D/T"))
+17 SET $PIECE(AFTER12,"^",4)=$GET(PXAA("ENC PROVIDER"))
+18 ;PX*1*108 - do not try to file a provider from a "DELETED" cpt
+19 IF $GET(PXAA("ENC PROVIDER"))]""
IF '$GET(PXAA("DELETE"))
Begin DoDot:1
+20 SET ^TMP("PXAIADDPRV",$JOB,$GET(PXAA("ENC PROVIDER")))=""
End DoDot:1
+21 ;
+22 SET $PIECE(AFTER802,"^",1)=$GET(PXAA("CATEGORY"))
+23 IF $GET(PXAA("CATEGORY"))]""
SET $PIECE(AFTER802,"^",1)=+$$PROVNARR^PXAPI($GET(PXAA("CATEGORY")),9000010.18)
+24 IF $PIECE(AFTER802,"^",1)<0
DO VAL45^PXAICPTV
DO ERR^PXAI
IF $DATA(STOP)
QUIT
+25 SET $PIECE(AFTER811,"^",1)=$GET(PXAA("COMMENT"))
+26 ;
+27 ;
+28 ;
+29 ;--PACKAGE AND SOURCE
+30 ;
+31 SET $PIECE(AFTER812,"^",2)=$GET(PXAPKG)
+32 SET $PIECE(AFTER812,"^",3)=$GET(PXASOURC)
+33 ;
SETPXKA ;--SET PXK ARRAY AFTER
+1 SET ^TMP("PXK",$JOB,"CPT",PXAK,0,"AFTER")=AFTER0
+2 ;Set ^TMP("PXK",$J,"CPT",PXAK,1,ien,"AFTER")=MODIEN
+3 DO SETPXKA^PXAIMOD
+4 SET ^TMP("PXK",$JOB,"CPT",PXAK,12,"AFTER")=AFTER12
+5 SET ^TMP("PXK",$JOB,"CPT",PXAK,802,"AFTER")=AFTER802
+6 SET ^TMP("PXK",$JOB,"CPT",PXAK,811,"AFTER")=AFTER811
+7 SET ^TMP("PXK",$JOB,"CPT",PXAK,812,"AFTER")=AFTER812
+8 ;
SETVARB ;--SET VARIABLES BEFORE
+1 Begin DoDot:1
+2 NEW PXBKY,PXBSAM,PXBSKY,PXBCNT,PXI,PRV,ITEM
+3 DO CPT^PXBGCPT(PXAVISIT)
+4 SET PXAAX("PROCEDURE")=$PIECE($GET(^ICPT($GET(PXAA("PROCEDURE")),0)),"^",1)
+5 IF $GET(PXAA("DELETE"))=1
SET PXAAX("PROCEDURE")=$PIECE($GET(^ICPT($GET(PXAA("PROCEDURE")),0)),"^",1)
+6 SET ITEM=""
+7 IF PXBCNT>0
IF $GET(PXAAX("PROCEDURE"))]""
SET ITEM=$ORDER(PXBKY(PXAAX("PROCEDURE"),0))
+8 IF ITEM]""
Begin DoDot:2
+9 ;--LOOK UP USING CPT AND PROVIDER
+10 SET PXI=""
FOR
SET PXI=$ORDER(PXBKY(PXAAX("PROCEDURE"),PXI))
IF PXI=""
QUIT
Begin DoDot:3
+11 ;DBIA #: 1906
IF $DATA(^IBE(357.69,PXAAX("PROCEDURE")))
Begin DoDot:4
+12 SET (^TMP("PXK",$JOB,"CPT",PXAK,"IEN"),IENB)=$ORDER(PXBSKY(PXI,0))
End DoDot:4
QUIT
+13 IF $GET(PXAA("ENC PROVIDER"))
Begin DoDot:4
+14 SET PRV=$PIECE(^VA(200,$GET(PXAA("ENC PROVIDER")),0),"^",1)
+15 IF $PIECE($GET(PXBKY(PXAAX("PROCEDURE"),PXI)),"^",3)=PRV
Begin DoDot:5
+16 SET (^TMP("PXK",$JOB,"CPT",PXAK,"IEN"),IENB)=$ORDER(PXBSKY(PXI,0))
End DoDot:5
End DoDot:4
QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+17 IF $GET(IENB)
Begin DoDot:1
+18 FOR PIECE=0,12,802,811,812
SET ^TMP("PXK",$JOB,"CPT",PXAK,PIECE,"BEFORE")=$GET(^AUPNVCPT(IENB,PIECE))
+19 ;Set ^TMP("PXK",$J,"CPT",PXAK,1,ien,"BEFORE")=MODIEN
+20 DO SETVARB^PXAIMOD
End DoDot:1
+21 IF '$TEST
Begin DoDot:1
+22 SET (BEFOR0,BEFOR12,BEFOR802,BEFOR811,BEFOR812)=""
+23 ;
SETPXKB ;--SET PXK ARRAY BEFORE
+1 SET ^TMP("PXK",$JOB,"CPT",PXAK,0,"BEFORE")=BEFOR0
+2 ;Set ^TMP("PXK",$J,"CPT",PXAK,1,ien,"BEFORE")=MODIEN
+3 DO SETPXKB^PXAIMOD
+4 SET ^TMP("PXK",$JOB,"CPT",PXAK,12,"BEFORE")=BEFOR12
+5 SET ^TMP("PXK",$JOB,"CPT",PXAK,802,"BEFORE")=BEFOR802
+6 SET ^TMP("PXK",$JOB,"CPT",PXAK,811,"BEFORE")=BEFOR811
+7 SET ^TMP("PXK",$JOB,"CPT",PXAK,812,"BEFORE")=BEFOR812
+8 SET ^TMP("PXK",$JOB,"CPT",PXAK,"IEN")=""
End DoDot:1
+9 ;
MISC ;--MISCELLANEOUS NODE
+1 ;
+2 QUIT
