Routine: PXKFCPT1

PXKFCPT1 ;ISL/JVS - PROCEDURES Routine #2 ;11/5/96  14:28

 ;;1.0;PCE PATIENT CARE ENCOUNTER;**11,73**;Aug 12, 1996

IMM ;

 N PXKSEQ1

 I PXKFGAD=1 D IMMADD

 I PXKFGDE=1 D IMMDEL

IMMADD ;

 S PXKKK=""

 S PXKSEQ1=PXKSEQ+PXKXX

 S PXKCPT=$P($P(PXKPXD(PXKX),"^",2),";")

POVNAR ;

 K ^UTILITY("DIQ1",$J)

 S DIC=81,DA=PXKCPT,DR=2 D EN^DIQ1

 S PXKCPTN=$G(^UTILITY("DIQ1",$J,81,DA,2))

 K ^UTILITY("DIQ1",$J),DIC,DA,DR D

 .Q:PXKCPTN=""  I $D(^AUTNPOV("B",PXKCPTN)) S PXKCPTN=$O(^AUTNPOV("B",PXKCPTN,0))

QUANTIT S PXKQUN=1,PXSTOP=0

 S PXXX=0

 F  S PXXX=$O(^AUPNVCPT("AD",PXKAV(0,3),PXXX)) Q:PXXX=""  D  Q:$G(PXSTOP)

 .I +$P(^AUPNVCPT(PXXX,0),"^")=PXKCPT D

 ..S PXKQUN=($P(^AUPNVCPT(PXXX,0),"^",16)+1)

 ..S PXSTOP=1

 ..S PXKKK=PXXX

 ..S ^TMP("PXKSAVE",$J,"CPT",PXKSEQ1,0,"BEFORE")=$G(^AUPNVCPT(PXXX,0))

 K PXSTOP

CATEGOR ;

 N PXKSEQ2

 S PXKCPTT(1)=$P(PXKCPT,"^",1)

 K ^UTILITY("DIQ1",$J)

 S DIC=81,DA=PXKCPTT(1),DR=3 D EN^DIQ1

 Q:$G(^UTILITY("DIQ1",$J,81,DA,3))=""

 S PXKCPTT(4.1)=$G(^UTILITY("DIQ1",$J,81,DA,3))

 S PXKCPTT(5)=$E(PXKCPTT(4.1),1,30)

 S PXKCPTT(6)=$O(^AUTNPOV("B",PXKCPTT(5),0))

 S PXKPCA=$S(PXKCPTT(6)="":PXKCPTT(5),PXKCPTT(6)'="":PXKCPTT(6),1:"")

 K PXKCPTT,^UTILITY("DIQ1",$J),DIC,DR,DA

 S ^TMP("PXKSAVE",$J,"CPT",PXKSEQ1,0,"AFTER")=$G(PXKCPT)_"^"_$G(PXKAV(0,2))_"^"_$G(PXKAV(0,3))_"^"_$G(PXKCPTN)_"^^^^^^^^^^^^"_$G(PXKQUN)

 S PXKSEQ2=0

 F  S PXKSEQ2=$O(PXKAFT(1,PXKSEQ2)) Q:'PXKSEQ2  D

 .S ^TMP("PXKSAVE",$J,"CPT",PXKSEQ1,1,PXKSEQ2,"AFTER")=PXKAFT(1,PXKSEQ2)

 S ^TMP("PXKSAVE",$J,"CPT",PXKSEQ1,12,"AFTER")=$G(PXKAFT(12))

 S ^TMP("PXKSAVE",$J,"CPT",PXKSEQ1,802,"AFTER")=$G(PXKCA)

 S ^TMP("PXKSAVE",$J,"CPT",PXKSEQ1,812,"AFTER")=$G(PXKAFT(812))

 S ^TMP("PXKSAVE",$J,"CPT",PXKSEQ1,"IEN")=PXKKK

 K PXKQUN,PXKCPTN,PXKCA,PXXX,PXKKK

IMMDEL ;Retrieve all CPT information for VISIT from V CPT file

 S PXKSEQ1=PXKSEQ+PXKXX

 S (XPFG,XP)=0 F  Q:XPFG  S XP=$O(^AUPNVCPT("AD",PXKVST,XP)) Q:XP=""  D

 .I $P(^AUPNVCPT(XP,0),"^",1)=$P($P(PXKPXD(PXKX),"^",2),";") D  S XPFG=1

 ..I $P($G(^AUPNVCPT(XP,0)),"^",16)=1 D IMMDEL1

 ..I $D(XP),$P($G(^AUPNVCPT(XP,0)),"^",16)>1 D IMMDEL2

IMMDEL1 ;

 N PXKSEQ2,PXKMOD

 S ^TMP("PXKSAVE",$J,"CPT",PXKSEQ1,0,"BEFORE")=$G(^AUPNVCPT(XP,0))

 S PXKSEQ2=0

 F  S PXKSEQ2=$O(^AUPNVCPT(XP,1,PXKSEQ2)) Q:'PXKSEQ2  D

 .S PXKMOD=^AUPNVCPT(XP,1,PXKSEQ2,0)

 .S ^TMP("PXKSAVE",$J,"CPT",PXKSEQ1,1,PXKSEQ2,"BEFORE")=PXKMOD

 S ^TMP("PXKSAVE",$J,"CPT",PXKSEQ1,12,"BEFORE")=$G(^AUPNVCPT(XP,12))

 S ^TMP("PXKSAVE",$J,"CPT",PXKSEQ1,802,"BEFORE")=$G(^AUPNVCPT(XP,802))

 S ^TMP("PXKSAVE",$J,"CPT",PXKSEQ1,812,"BEFORE")=$G(^AUPNVCPT(XP,812))

 S ^TMP("PXKSAVE",$J,"CPT",PXKSEQ1,"IEN")=XP

 S ^TMP("PXKSAVE",$J,"CPT",PXKSEQ1,0,"AFTER")="@"

 S ^TMP("PXKSAVE",$J,"CPT",PXKSEQ1,12,"AFTER")=""

 S ^TMP("PXKSAVE",$J,"CPT",PXKSEQ1,802,"AFTER")=""

 S ^TMP("PXKSAVE",$J,"CPT",PXKSEQ1,812,"AFTER")=""

 K XPFG,XP

IMMDEL2 ;

 N PXKSEQ2,PXKMOD

 S PXTEMP=$P($G(^AUPNVCPT(XP,0)),"^",16)

 S ^TMP("PXKSAVE",$J,"CPT",PXKSEQ1,0,"BEFORE")=$G(^AUPNVCPT(XP,0))

 S PXKSEQ2=0

 F  S PXKSEQ2=$O(^AUPNVCPT(XP,1,PXKSEQ2)) Q:'PXKSEQ2  D

 .S PXKMOD=^AUPNVCPT(XP,1,PXKSEQ2,0)

 .S ^TMP("PXKSAVE",$J,"CPT",PXKSEQ1,1,PXKSEQ2,"BEFORE")=PXKMOD

 S ^TMP("PXKSAVE",$J,"CPT",PXKSEQ1,12,"BEFORE")=$G(^AUPNVCPT(XP,12))

 S ^TMP("PXKSAVE",$J,"CPT",PXKSEQ1,802,"BEFORE")=$G(^AUPNVCPT(XP,802))

 S ^TMP("PXKSAVE",$J,"CPT",PXKSEQ1,812,"BEFORE")=$G(^AUPNVCPT(XP,812))

 S ^TMP("PXKSAVE",$J,"CPT",PXKSEQ1,"IEN")=XP

 S ^TMP("PXKSAVE",$J,"CPT",PXKSEQ1,0,"AFTER")=$G(^AUPNVCPT(XP,0))

 S PXKSEQ2=0

 F  S PXKSEQ2=$O(^AUPNVCPT(XP,1,PXKSEQ2)) Q:'PXKSEQ2  D

 .S PXKMOD=^AUPNVCPT(XP,1,PXKSEQ2,0)

 .S ^TMP("PXKSAVE",$J,"CPT",PXKSEQ1,1,PXKSEQ2,"BEFORE")=PXKMOD

 S ^TMP("PXKSAVE",$J,"CPT",PXKSEQ1,12,"AFTER")=$G(^AUPNVCPT(XP,12))

 S ^TMP("PXKSAVE",$J,"CPT",PXKSEQ1,802,"AFTER")=$G(^AUPNVCPT(XP,802))

 S ^TMP("PXKSAVE",$J,"CPT",PXKSEQ1,812,"AFTER")=$G(^AUPNVCPT(XP,812))

 S $P(^TMP("PXKSAVE",$J,"CPT",PXKSEQ1,0,"AFTER"),"^",16)=((PXTEMP)-(1))

 K XPFG,XP,PXTEMP

SK ;--START OF SKIN TEST

 D IMM

PXKFCPT1  ;ISL/JVS - PROCEDURES Routine #2 ;11/5/96  14:28

 +1       ;;1.0;PCE PATIENT CARE ENCOUNTER;**11,73**;Aug 12, 1996

 +2       ;

 +3       ;

IMM       ;

 +1        NEW PXKSEQ1

 +2        IF PXKFGAD=1

               DO IMMADD

 +3        IF PXKFGDE=1

               DO IMMDEL

 +4        QUIT

IMMADD    ;

 +1        SET PXKKK=""

 +2        SET PXKSEQ1=PXKSEQ+PXKXX

 +3        SET PXKCPT=$PIECE($PIECE(PXKPXD(PXKX),"^",2),";")

POVNAR    ;

 +1        KILL ^UTILITY("DIQ1",$JOB)

 +2        SET DIC=81

           SET DA=PXKCPT

           SET DR=2

           DO EN^DIQ1

 +3        SET PXKCPTN=$GET(^UTILITY("DIQ1",$JOB,81,DA,2))

 +4        KILL ^UTILITY("DIQ1",$JOB),DIC,DA,DR

           Begin DoDot:1

 +5            IF PXKCPTN=""

                   QUIT

               IF $DATA(^AUTNPOV("B",PXKCPTN))

                   SET PXKCPTN=$ORDER(^AUTNPOV("B",PXKCPTN,0))

           End DoDot:1

 +6       ;

QUANTIT    SET PXKQUN=1

           SET PXSTOP=0

 +1        SET PXXX=0

 +2        FOR

               SET PXXX=$ORDER(^AUPNVCPT("AD",PXKAV(0,3),PXXX))

               IF PXXX=""

                   QUIT

               Begin DoDot:1

 +3                IF +$PIECE(^AUPNVCPT(PXXX,0),"^")=PXKCPT

                       Begin DoDot:2

 +4                        SET PXKQUN=($PIECE(^AUPNVCPT(PXXX,0),"^",16)+1)

 +5                        SET PXSTOP=1

 +6                        SET PXKKK=PXXX

 +7                        SET ^TMP("PXKSAVE",$JOB,"CPT",PXKSEQ1,0,"BEFORE")=$GET(^AUPNVCPT(PXXX,0))

                       End DoDot:2

               End DoDot:1

               IF $GET(PXSTOP)

                   QUIT

 +8        KILL PXSTOP

CATEGOR   ;

 +1        NEW PXKSEQ2

 +2        SET PXKCPTT(1)=$PIECE(PXKCPT,"^",1)

 +3        KILL ^UTILITY("DIQ1",$JOB)

 +4        SET DIC=81

           SET DA=PXKCPTT(1)

           SET DR=3

           DO EN^DIQ1

 +5        IF $GET(^UTILITY("DIQ1",$JOB,81,DA,3))=""

               QUIT

 +6        SET PXKCPTT(4.1)=$GET(^UTILITY("DIQ1",$JOB,81,DA,3))

 +7        SET PXKCPTT(5)=$EXTRACT(PXKCPTT(4.1),1,30)

 +8        SET PXKCPTT(6)=$ORDER(^AUTNPOV("B",PXKCPTT(5),0))

 +9        SET PXKPCA=$SELECT(PXKCPTT(6)="":PXKCPTT(5),PXKCPTT(6)'="":PXKCPTT(6),1:"")

 +10       KILL PXKCPTT,^UTILITY("DIQ1",$JOB),DIC,DR,DA

 +11       SET ^TMP("PXKSAVE",$JOB,"CPT",PXKSEQ1,0,"AFTER")=$GET(PXKCPT)_"^"_$GET(PXKAV(0,2))_"^"_$GET(PXKAV(0,3))_"^"_$GET(PXKCPTN)_"^^^^^^^^^^^^"_$GET(PXKQUN)

 +12       SET PXKSEQ2=0

 +13       FOR

               SET PXKSEQ2=$ORDER(PXKAFT(1,PXKSEQ2))

               IF 'PXKSEQ2

                   QUIT

               Begin DoDot:1

 +14               SET ^TMP("PXKSAVE",$JOB,"CPT",PXKSEQ1,1,PXKSEQ2,"AFTER")=PXKAFT(1,PXKSEQ2)

               End DoDot:1

 +15       SET ^TMP("PXKSAVE",$JOB,"CPT",PXKSEQ1,12,"AFTER")=$GET(PXKAFT(12))

 +16       SET ^TMP("PXKSAVE",$JOB,"CPT",PXKSEQ1,802,"AFTER")=$GET(PXKCA)

 +17       SET ^TMP("PXKSAVE",$JOB,"CPT",PXKSEQ1,812,"AFTER")=$GET(PXKAFT(812))

 +18       SET ^TMP("PXKSAVE",$JOB,"CPT",PXKSEQ1,"IEN")=PXKKK

 +19       KILL PXKQUN,PXKCPTN,PXKCA,PXXX,PXKKK

 +20       QUIT

IMMDEL    ;Retrieve all CPT information for VISIT from V CPT file

 +1        SET PXKSEQ1=PXKSEQ+PXKXX

 +2        SET (XPFG,XP)=0

FOR

               IF XPFG

                   QUIT

               SET XP=$ORDER(^AUPNVCPT("AD",PXKVST,XP))

               IF XP=""

                   QUIT

               Begin DoDot:1

 +3                IF $PIECE(^AUPNVCPT(XP,0),"^",1)=$PIECE($PIECE(PXKPXD(PXKX),"^",2),";")

                       Begin DoDot:2

 +4                        IF $PIECE($GET(^AUPNVCPT(XP,0)),"^",16)=1

                               DO IMMDEL1

 +5                        IF $DATA(XP)

                               IF $PIECE($GET(^AUPNVCPT(XP,0)),"^",16)>1

                                   DO IMMDEL2

                       End DoDot:2

                       SET XPFG=1

               End DoDot:1

 +6        QUIT

IMMDEL1   ;

 +1        NEW PXKSEQ2,PXKMOD

 +2        SET ^TMP("PXKSAVE",$JOB,"CPT",PXKSEQ1,0,"BEFORE")=$GET(^AUPNVCPT(XP,0))

 +3        SET PXKSEQ2=0

 +4        FOR

               SET PXKSEQ2=$ORDER(^AUPNVCPT(XP,1,PXKSEQ2))

               IF 'PXKSEQ2

                   QUIT

               Begin DoDot:1

 +5                SET PXKMOD=^AUPNVCPT(XP,1,PXKSEQ2,0)

 +6                SET ^TMP("PXKSAVE",$JOB,"CPT",PXKSEQ1,1,PXKSEQ2,"BEFORE")=PXKMOD

               End DoDot:1

 +7        SET ^TMP("PXKSAVE",$JOB,"CPT",PXKSEQ1,12,"BEFORE")=$GET(^AUPNVCPT(XP,12))

 +8        SET ^TMP("PXKSAVE",$JOB,"CPT",PXKSEQ1,802,"BEFORE")=$GET(^AUPNVCPT(XP,802))

 +9        SET ^TMP("PXKSAVE",$JOB,"CPT",PXKSEQ1,812,"BEFORE")=$GET(^AUPNVCPT(XP,812))

 +10       SET ^TMP("PXKSAVE",$JOB,"CPT",PXKSEQ1,"IEN")=XP

 +11       SET ^TMP("PXKSAVE",$JOB,"CPT",PXKSEQ1,0,"AFTER")="@"

 +12       SET ^TMP("PXKSAVE",$JOB,"CPT",PXKSEQ1,12,"AFTER")=""

 +13       SET ^TMP("PXKSAVE",$JOB,"CPT",PXKSEQ1,802,"AFTER")=""

 +14       SET ^TMP("PXKSAVE",$JOB,"CPT",PXKSEQ1,812,"AFTER")=""

 +15       KILL XPFG,XP

 +16       QUIT

IMMDEL2   ;

 +1        NEW PXKSEQ2,PXKMOD

 +2        SET PXTEMP=$PIECE($GET(^AUPNVCPT(XP,0)),"^",16)

 +3        SET ^TMP("PXKSAVE",$JOB,"CPT",PXKSEQ1,0,"BEFORE")=$GET(^AUPNVCPT(XP,0))

 +4        SET PXKSEQ2=0

 +5        FOR

               SET PXKSEQ2=$ORDER(^AUPNVCPT(XP,1,PXKSEQ2))

               IF 'PXKSEQ2

                   QUIT

               Begin DoDot:1

 +6                SET PXKMOD=^AUPNVCPT(XP,1,PXKSEQ2,0)

 +7                SET ^TMP("PXKSAVE",$JOB,"CPT",PXKSEQ1,1,PXKSEQ2,"BEFORE")=PXKMOD

               End DoDot:1

 +8        SET ^TMP("PXKSAVE",$JOB,"CPT",PXKSEQ1,12,"BEFORE")=$GET(^AUPNVCPT(XP,12))

 +9        SET ^TMP("PXKSAVE",$JOB,"CPT",PXKSEQ1,802,"BEFORE")=$GET(^AUPNVCPT(XP,802))

 +10       SET ^TMP("PXKSAVE",$JOB,"CPT",PXKSEQ1,812,"BEFORE")=$GET(^AUPNVCPT(XP,812))

 +11       SET ^TMP("PXKSAVE",$JOB,"CPT",PXKSEQ1,"IEN")=XP

 +12       SET ^TMP("PXKSAVE",$JOB,"CPT",PXKSEQ1,0,"AFTER")=$GET(^AUPNVCPT(XP,0))

 +13       SET PXKSEQ2=0

 +14       FOR

               SET PXKSEQ2=$ORDER(^AUPNVCPT(XP,1,PXKSEQ2))

               IF 'PXKSEQ2

                   QUIT

               Begin DoDot:1

 +15               SET PXKMOD=^AUPNVCPT(XP,1,PXKSEQ2,0)

 +16               SET ^TMP("PXKSAVE",$JOB,"CPT",PXKSEQ1,1,PXKSEQ2,"BEFORE")=PXKMOD

               End DoDot:1

 +17       SET ^TMP("PXKSAVE",$JOB,"CPT",PXKSEQ1,12,"AFTER")=$GET(^AUPNVCPT(XP,12))

 +18       SET ^TMP("PXKSAVE",$JOB,"CPT",PXKSEQ1,802,"AFTER")=$GET(^AUPNVCPT(XP,802))

 +19       SET ^TMP("PXKSAVE",$JOB,"CPT",PXKSEQ1,812,"AFTER")=$GET(^AUPNVCPT(XP,812))

 +20       SET $PIECE(^TMP("PXKSAVE",$JOB,"CPT",PXKSEQ1,0,"AFTER"),"^",16)=((PXTEMP)-(1))

 +21       KILL XPFG,XP,PXTEMP

 +22       QUIT

SK        ;--START OF SKIN TEST

 +1        DO IMM

 +2        QUIT

PXKFCPT1.m