Routine: PXAICPT

PXAICPT ;ISL/JVS,PKR,ISA/KWP,ESW,SCK - SET THE PROCEDURE(CPT) NODES ;01/26/2021

 ;;1.0;PCE PATIENT CARE ENCOUNTER;**19,73,108,112,149,124,164,194,211**;Aug 12, 1996;Build 454

CPT ;

SET ;--SET AND NEW VARIABLES

 N AFTER0,AFTER1,AFTER12,AFTER801,AFTER802,AFTER811,AFTER812

 N BEFOR0,BEFOR1,BEFOR12,BEFOR801,BEFOR802,BEFOR811,BEFOR812

 N EVENTDT,PXAA,PXAB,SUB,PIECE,IENB,STOP

 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 V CPT VARIABLES

 S $P(AFTER0,U,1)=$G(PXAA("PROCEDURE"))

 I $G(PXAA("DELETE")) S $P(AFTER0,U,1)="@"

 S $P(AFTER0,U,2)=$G(PATIENT)

 S $P(AFTER0,U,3)=$G(PXAVISIT)

 ;If Provider Narrative is not passed or is too long use the

 ;CPT short description.

 I ($G(PXAA("NARRATIVE"))="")!($L($G(PXAA("NARRATIVE")))>245) D

 .S EVENTDT=$G(PXAA("EVENT D/T"))

 .I EVENTDT="" S EVENTDT=$P(^AUPNVSIT(PXAVISIT,0),U,1)

 .S PXAA("NARRATIVE")=$P($$CPT^ICPTCOD($G(PXAA("PROCEDURE")),EVENTDT),U,3)

 ;Get the Provider Narrative pointer.

 S $P(AFTER0,U,4)=+$$PROVNARR^PXAPI($G(PXAA("NARRATIVE")),9000010.18)

 I $P(AFTER0,U,4)'>0 D VAL04^PXAICPTV,ERR^PXAI("NARRATIVE",1) Q:$D(STOP)

 S $P(AFTER0,U,5)=$G(PXAA("DIAGNOSIS"))

 ;PX*1*124 - add dx

 S $P(AFTER0,U,9)=$G(PXAA("DIAGNOSIS 2"))

 S $P(AFTER0,U,10)=$G(PXAA("DIAGNOSIS 3"))

 S $P(AFTER0,U,11)=$G(PXAA("DIAGNOSIS 4"))

 S $P(AFTER0,U,12)=$G(PXAA("DIAGNOSIS 5"))

 S $P(AFTER0,U,13)=$G(PXAA("DIAGNOSIS 6"))

 S $P(AFTER0,U,14)=$G(PXAA("DIAGNOSIS 7"))

 S $P(AFTER0,U,15)=$G(PXAA("DIAGNOSIS 8"))

 I $G(PXAA("QTY"))="" S PXAA("QTY")=1

 S $P(AFTER0,U,16)=$G(PXAA("QTY")) I $G(PXAA("QTY"))<1 S PXAA("DELETE")=1

 S $P(AFTER0,U,17)=$G(PXAA("ORD REFERENCE"))

 I $$SWSTAT^IBBAPI() D  ;PX*1.0*164

 . S $P(AFTER0,U,19)=$G(PXAA("DEPARTMENT"))

 . I $P(AFTER0,U,19)="",$G(^AUPNVSIT(PXAVISIT,0)),$P(^AUPNVSIT(PXAVISIT,0),U,8) S $P(AFTER0,U,19)=$P($G(^DIC(40.7,$P(^AUPNVSIT(PXAVISIT,0),U,8),0)),U,2)

 S $P(AFTER12,U,1)=$G(PXAA("EVENT D/T"))

 ;PX*1*124 - add ord prv

 S $P(AFTER12,U,2)=$G(PXAA("ORD PROVIDER"))

 S $P(AFTER12,U,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")))="ENC"

 ;PX*1*124 - do not try to file a provider from a "DELETED" cpt

 I $G(PXAA("ORD PROVIDER"))]"",'$G(PXAA("DELETE")) D

 .S ^TMP("PXAIADDPRV",$J,$G(PXAA("ORD PROVIDER")))="ORD"

 I $G(PXAA("CATEGORY"))="" S $P(AFTER802,U,1)=""

 E  D

 . S $P(AFTER802,U,1)=+$$PROVNARR^PXAPI(PXAA("CATEGORY"),9000010.18)

 . I $P(AFTER802,U,1)'>0 D

 .. D VAL802^PXAICPTV,ERR^PXAI("CATEGORY",1)

 .. S $P(AFTER802,U,1)=""

 S $P(AFTER811,U,1)=$G(PXAA("COMMENT"))

 ;--PACKAGE AND SOURCE

 S $P(AFTER812,U,2)=$S($G(PXAA("PKG"))'="":PXAA("PKG"),1:$G(PXAPKG))

 S $P(AFTER812,U,3)=$S($G(PXAA("SOURCE"))'="":PXAA("SOURCE"),1:$G(PXASOURC))

 N PXBKY,PXBSAM,PXBSKY,PXBCNT,PXI,PRV,ITEM

 D CPT^PXBGCPT(PXAVISIT)

 S ITEM=""

 I PXBCNT>0,$G(PXAA("PROCEDURE"))]"" S ITEM=$O(PXBKY(PXAA("PROCEDURE"),0))

 S IENB=+$S(ITEM'="":$O(PXBSKY(ITEM,"")),1:0)

SETPXKA ;--SET PXK ARRAY AFTER

 S ^TMP("PXK",$J,"CPT",PXAK,0,"AFTER")=AFTER0

 D SETPXKA^PXAIMOD(IENB,PXAK,.PXAA)

 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

 I IENB>0 D

 .S ^TMP("PXK",$J,"CPT",PXAK,"IEN")=IENB

 .F PIECE=0,12,802,811,812 S ^TMP("PXK",$J,"CPT",PXAK,PIECE,"BEFORE")=$G(^AUPNVCPT(IENB,PIECE))

 E  D

 .S (BEFOR0,BEFOR12,BEFOR802,BEFOR811,BEFOR812)=""

.;

SETPXKB .;--SET PXK ARRAY BEFORE

 .S ^TMP("PXK",$J,"CPT",PXAK,0,"BEFORE")=BEFOR0

 .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")=$S(IENB>0:IENB,1:"")

 D SETPXKB^PXAIMOD(IENB,PXAK,.PXAA)

 ;Package and Data Source cannot be edited.

 S BEFOR812=^TMP("PXK",$J,"CPT",PXAK,812,"BEFORE")

 I BEFOR812'="" D

 . I AFTER812=BEFOR812 Q

 . I $P(BEFOR812,U,2)'="" S $P(AFTER812,U,2)=$P(BEFOR812,U,2)

 . I $P(BEFOR812,U,3)'="" S $P(AFTER812,U,3)=$P(BEFOR812,U,3)

 . S ^TMP("PXK",$J,"CPT",PXAK,812,"AFTER")=AFTER812

MISC ;--MISCELLANEOUS NODE

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXAICPT   4733     printed  Feb 18, 2025@23:52:02                                                                                                                                                                                                     Page 2

PXAICPT   ;ISL/JVS,PKR,ISA/KWP,ESW,SCK - SET THE PROCEDURE(CPT) NODES ;01/26/2021

 +1       ;;1.0;PCE PATIENT CARE ENCOUNTER;**19,73,108,112,149,124,164,194,211**;Aug 12, 1996;Build 454

 +2       ;

 +3        QUIT

CPT       ;

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 EVENTDT,PXAA,PXAB,SUB,PIECE,IENB,STOP

 +4        KILL PXAERR

 +5        SET PXAERR(8)=PXAK

 +6        SET PXAERR(7)="PROCEDURE"

 +7       ;

 +8        SET SUB=""

FOR

               SET SUB=$ORDER(@PXADATA@("PROCEDURE",PXAK,SUB))

               if SUB=""

                   QUIT

               Begin DoDot:1

 +9                SET PXAA(SUB)=$GET(@PXADATA@("PROCEDURE",PXAK,SUB))

               End DoDot:1

 +10      ;Setup PXAA array for Modifiers

 +11       SET SUB=""

 +12       FOR

               SET SUB=$ORDER(@PXADATA@("PROCEDURE",PXAK,"MODIFIERS",SUB))

               if SUB=""

                   QUIT

               Begin DoDot:1

 +13               SET PXAA("MODIFIERS",SUB)=""

               End DoDot:1

 +14      ;

VAL       ;--VALIDATE ENOUGH DATA

 +1        DO VAL^PXAICPTV

           if $GET(STOP)

               QUIT

 +2       ;

SETVARA   ;--SET V CPT VARIABLES

 +1        SET $PIECE(AFTER0,U,1)=$GET(PXAA("PROCEDURE"))

 +2        IF $GET(PXAA("DELETE"))

               SET $PIECE(AFTER0,U,1)="@"

 +3        SET $PIECE(AFTER0,U,2)=$GET(PATIENT)

 +4        SET $PIECE(AFTER0,U,3)=$GET(PXAVISIT)

 +5       ;If Provider Narrative is not passed or is too long use the

 +6       ;CPT short description.

 +7        IF ($GET(PXAA("NARRATIVE"))="")!($LENGTH($GET(PXAA("NARRATIVE")))>245)

               Begin DoDot:1

 +8                SET EVENTDT=$GET(PXAA("EVENT D/T"))

 +9                IF EVENTDT=""

                       SET EVENTDT=$PIECE(^AUPNVSIT(PXAVISIT,0),U,1)

 +10               SET PXAA("NARRATIVE")=$PIECE($$CPT^ICPTCOD($GET(PXAA("PROCEDURE")),EVENTDT),U,3)

               End DoDot:1

 +11      ;Get the Provider Narrative pointer.

 +12       SET $PIECE(AFTER0,U,4)=+$$PROVNARR^PXAPI($GET(PXAA("NARRATIVE")),9000010.18)

 +13       IF $PIECE(AFTER0,U,4)'>0

               DO VAL04^PXAICPTV

               DO ERR^PXAI("NARRATIVE",1)

               if $DATA(STOP)

                   QUIT

 +14       SET $PIECE(AFTER0,U,5)=$GET(PXAA("DIAGNOSIS"))

 +15      ;PX*1*124 - add dx

 +16       SET $PIECE(AFTER0,U,9)=$GET(PXAA("DIAGNOSIS 2"))

 +17       SET $PIECE(AFTER0,U,10)=$GET(PXAA("DIAGNOSIS 3"))

 +18       SET $PIECE(AFTER0,U,11)=$GET(PXAA("DIAGNOSIS 4"))

 +19       SET $PIECE(AFTER0,U,12)=$GET(PXAA("DIAGNOSIS 5"))

 +20       SET $PIECE(AFTER0,U,13)=$GET(PXAA("DIAGNOSIS 6"))

 +21       SET $PIECE(AFTER0,U,14)=$GET(PXAA("DIAGNOSIS 7"))

 +22       SET $PIECE(AFTER0,U,15)=$GET(PXAA("DIAGNOSIS 8"))

 +23       IF $GET(PXAA("QTY"))=""

               SET PXAA("QTY")=1

 +24       SET $PIECE(AFTER0,U,16)=$GET(PXAA("QTY"))

           IF $GET(PXAA("QTY"))<1

               SET PXAA("DELETE")=1

 +25       SET $PIECE(AFTER0,U,17)=$GET(PXAA("ORD REFERENCE"))

 +26      ;PX*1.0*164

           IF $$SWSTAT^IBBAPI()

               Begin DoDot:1

 +27               SET $PIECE(AFTER0,U,19)=$GET(PXAA("DEPARTMENT"))

 +28               IF $PIECE(AFTER0,U,19)=""

                       IF $GET(^AUPNVSIT(PXAVISIT,0))

                           IF $PIECE(^AUPNVSIT(PXAVISIT,0),U,8)

                               SET $PIECE(AFTER0,U,19)=$PIECE($GET(^DIC(40.7,$PIECE(^AUPNVSIT(PXAVISIT,0),U,8),0)),U,2)

               End DoDot:1

 +29      ;

 +30       SET $PIECE(AFTER12,U,1)=$GET(PXAA("EVENT D/T"))

 +31      ;PX*1*124 - add ord prv

 +32       SET $PIECE(AFTER12,U,2)=$GET(PXAA("ORD PROVIDER"))

 +33       SET $PIECE(AFTER12,U,4)=$GET(PXAA("ENC PROVIDER"))

 +34      ;PX*1*108 - do not try to file a provider from a "DELETED" cpt

 +35       IF $GET(PXAA("ENC PROVIDER"))]""

               IF '$GET(PXAA("DELETE"))

                   Begin DoDot:1

 +36                   SET ^TMP("PXAIADDPRV",$JOB,$GET(PXAA("ENC PROVIDER")))="ENC"

                   End DoDot:1

 +37      ;PX*1*124 - do not try to file a provider from a "DELETED" cpt

 +38       IF $GET(PXAA("ORD PROVIDER"))]""

               IF '$GET(PXAA("DELETE"))

                   Begin DoDot:1

 +39                   SET ^TMP("PXAIADDPRV",$JOB,$GET(PXAA("ORD PROVIDER")))="ORD"

                   End DoDot:1

 +40      ;

 +41       IF $GET(PXAA("CATEGORY"))=""

               SET $PIECE(AFTER802,U,1)=""

 +42      IF '$TEST

               Begin DoDot:1

 +43               SET $PIECE(AFTER802,U,1)=+$$PROVNARR^PXAPI(PXAA("CATEGORY"),9000010.18)

 +44               IF $PIECE(AFTER802,U,1)'>0

                       Begin DoDot:2

 +45                       DO VAL802^PXAICPTV

                           DO ERR^PXAI("CATEGORY",1)

 +46                       SET $PIECE(AFTER802,U,1)=""

                       End DoDot:2

               End DoDot:1

 +47      ;

 +48       SET $PIECE(AFTER811,U,1)=$GET(PXAA("COMMENT"))

 +49      ;

 +50      ;--PACKAGE AND SOURCE

 +51       SET $PIECE(AFTER812,U,2)=$SELECT($GET(PXAA("PKG"))'="":PXAA("PKG"),1:$GET(PXAPKG))

 +52       SET $PIECE(AFTER812,U,3)=$SELECT($GET(PXAA("SOURCE"))'="":PXAA("SOURCE"),1:$GET(PXASOURC))

 +53      ;

 +54       NEW PXBKY,PXBSAM,PXBSKY,PXBCNT,PXI,PRV,ITEM

 +55       DO CPT^PXBGCPT(PXAVISIT)

 +56       SET ITEM=""

 +57       IF PXBCNT>0

               IF $GET(PXAA("PROCEDURE"))]""

                   SET ITEM=$ORDER(PXBKY(PXAA("PROCEDURE"),0))

 +58       SET IENB=+$SELECT(ITEM'="":$ORDER(PXBSKY(ITEM,"")),1:0)

 +59      ;

SETPXKA   ;--SET PXK ARRAY AFTER

 +1        SET ^TMP("PXK",$JOB,"CPT",PXAK,0,"AFTER")=AFTER0

 +2        DO SETPXKA^PXAIMOD(IENB,PXAK,.PXAA)

 +3        SET ^TMP("PXK",$JOB,"CPT",PXAK,12,"AFTER")=AFTER12

 +4        SET ^TMP("PXK",$JOB,"CPT",PXAK,802,"AFTER")=AFTER802

 +5        SET ^TMP("PXK",$JOB,"CPT",PXAK,811,"AFTER")=AFTER811

 +6        SET ^TMP("PXK",$JOB,"CPT",PXAK,812,"AFTER")=AFTER812

 +7       ;

SETVARB   ;--SET VARIABLES BEFORE

 +1        IF IENB>0

               Begin DoDot:1

 +2                SET ^TMP("PXK",$JOB,"CPT",PXAK,"IEN")=IENB

 +3                FOR PIECE=0,12,802,811,812

                       SET ^TMP("PXK",$JOB,"CPT",PXAK,PIECE,"BEFORE")=$GET(^AUPNVCPT(IENB,PIECE))

               End DoDot:1

 +4       IF '$TEST

               Begin DoDot:1

 +5                SET (BEFOR0,BEFOR12,BEFOR802,BEFOR811,BEFOR812)=""

 +6       ;

SETPXKB   ;--SET PXK ARRAY BEFORE

 +1                SET ^TMP("PXK",$JOB,"CPT",PXAK,0,"BEFORE")=BEFOR0

 +2                SET ^TMP("PXK",$JOB,"CPT",PXAK,12,"BEFORE")=BEFOR12

 +3                SET ^TMP("PXK",$JOB,"CPT",PXAK,802,"BEFORE")=BEFOR802

 +4                SET ^TMP("PXK",$JOB,"CPT",PXAK,811,"BEFORE")=BEFOR811

 +5                SET ^TMP("PXK",$JOB,"CPT",PXAK,812,"BEFORE")=BEFOR812

 +6                SET ^TMP("PXK",$JOB,"CPT",PXAK,"IEN")=$SELECT(IENB>0:IENB,1:"")

               End DoDot:1

 +7        DO SETPXKB^PXAIMOD(IENB,PXAK,.PXAA)

 +8       ;

 +9       ;Package and Data Source cannot be edited.

 +10       SET BEFOR812=^TMP("PXK",$JOB,"CPT",PXAK,812,"BEFORE")

 +11       IF BEFOR812'=""

               Begin DoDot:1

 +12               IF AFTER812=BEFOR812

                       QUIT

 +13               IF $PIECE(BEFOR812,U,2)'=""

                       SET $PIECE(AFTER812,U,2)=$PIECE(BEFOR812,U,2)

 +14               IF $PIECE(BEFOR812,U,3)'=""

                       SET $PIECE(AFTER812,U,3)=$PIECE(BEFOR812,U,3)

 +15               SET ^TMP("PXK",$JOB,"CPT",PXAK,812,"AFTER")=AFTER812

               End DoDot:1

 +16      ;

MISC      ;--MISCELLANEOUS NODE

 +1       ;

 +2        QUIT

PXAICPT.m