PXKFCPT1 ;ISL/JVS,SCK - PROCEDURES Routine #2 ;10/20/2071
;;1.0;PCE PATIENT CARE ENCOUNTER;**11,73,124,194,209,215,211**;Aug 12, 1996;Build 454
;
;
IMM ;
N PXKSEQ1
I PXKFGAD=1 D IMMADD
I PXKFGDE=1 D IMMDEL
Q
IMMADD ;
S PXKKK=""
S PXKSEQ1=PXKSEQ+PXKXX
S PXKCPT=$P($P(PXKPXD(PXKX),"^",2),";")
POVNAR ;
N EVENTDT,PXK1
;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
S EVENTDT=$G(PXKAV(12,0))
I EVENTDT="" S EVENTDT=$P(^AUPNVSIT(PXKAV(0,3),0),U,1)
S PXK1=$$CPT^ICPTCOD(PXKCPT,EVENTDT)
S PXKCPTN=$P(PXK1,U,3) 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
..; PX*1*215 - If code already exists, quit; don't increment qty
..;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))
I $G(PXSTOP) Q
K PXSTOP
CATEGOR ;
N PXKSEQ2,PXK1,PXK2
S PXKCPTT(1)=$P(PXKCPT,"^",1)
;K ^UTILITY("DIQ1",$J)
;S DIC=81,DA=PXKCPTT(1),DR=3 D EN^DIQ1
S PXK1=$P($$CPT^ICPTCOD(PXKCPTT(1)),U,4)
S PXK2=$$GET1^DIQ(81.1,PXK1,.01)
Q:PXK2=""
;Q:$G(^UTILITY("DIQ1",$J,81,DA,3))=""
;S PXKCPTT(4.1)=$G(^UTILITY("DIQ1",$J,81,DA,3))
S PXKCPTT(4.1)=PXK2
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
;PX*1*124
S ^TMP("PXKSAVE",$J,"CPT",PXKSEQ1,0,"AFTER")=$G(PXKCPT)_"^"_$G(PXKAV(0,2))_"^"_$G(PXKAV(0,3))_"^"_$G(PXKCPTN)_"^"_$G(PXKAV(0,8))_"^^^^"
S ^TMP("PXKSAVE",$J,"CPT",PXKSEQ1,0,"AFTER")=^TMP("PXKSAVE",$J,"CPT",PXKSEQ1,0,"AFTER")_$G(PXKAV(0,9))_"^"_$G(PXKAV(0,10))_"^"_$G(PXKAV(0,11))_"^"_$G(PXKAV(0,12))_"^"_$G(PXKAV(0,13))_"^"_$G(PXKAV(0,14))_"^"_$G(PXKAV(0,15))_"^"_$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(PXKAV(12,1))_"^"_$G(PXKAV(12,2))_"^^"_$G(PXKAV(12,4))
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
Q
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
Q
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
Q
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
Q
SK ;--START OF SKIN TEST
D IMM
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXKFCPT1 4762 printed Apr 09, 2024@21:31:39 Page 2
PXKFCPT1 ;ISL/JVS,SCK - PROCEDURES Routine #2 ;10/20/2071
+1 ;;1.0;PCE PATIENT CARE ENCOUNTER;**11,73,124,194,209,215,211**;Aug 12, 1996;Build 454
+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 NEW EVENTDT,PXK1
+2 ;K ^UTILITY("DIQ1",$J)
+3 ;S DIC=81,DA=PXKCPT,DR=2 D EN^DIQ1
+4 ;S PXKCPTN=$G(^UTILITY("DIQ1",$J,81,DA,2))
+5 ;K ^UTILITY("DIQ1",$J),DIC,DA,DR D
+6 SET EVENTDT=$GET(PXKAV(12,0))
+7 IF EVENTDT=""
SET EVENTDT=$PIECE(^AUPNVSIT(PXKAV(0,3),0),U,1)
+8 SET PXK1=$$CPT^ICPTCOD(PXKCPT,EVENTDT)
+9 SET PXKCPTN=$PIECE(PXK1,U,3)
Begin DoDot:1
+10 if PXKCPTN=""
QUIT
IF $DATA(^AUTNPOV("B",PXKCPTN))
SET PXKCPTN=$ORDER(^AUTNPOV("B",PXKCPTN,0))
End DoDot:1
+11 ;
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 ; PX*1*215 - If code already exists, quit; don't increment qty
+5 ;S PXKQUN=($P(^AUPNVCPT(PXXX,0),"^",16)+1)
+6 SET PXSTOP=1
+7 ;S PXKKK=PXXX
+8 ;S ^TMP("PXKSAVE",$J,"CPT",PXKSEQ1,0,"BEFORE")=$G(^AUPNVCPT(PXXX,0))
End DoDot:2
End DoDot:1
if $GET(PXSTOP)
QUIT
+9 IF $GET(PXSTOP)
QUIT
+10 KILL PXSTOP
CATEGOR ;
+1 NEW PXKSEQ2,PXK1,PXK2
+2 SET PXKCPTT(1)=$PIECE(PXKCPT,"^",1)
+3 ;K ^UTILITY("DIQ1",$J)
+4 ;S DIC=81,DA=PXKCPTT(1),DR=3 D EN^DIQ1
+5 SET PXK1=$PIECE($$CPT^ICPTCOD(PXKCPTT(1)),U,4)
+6 SET PXK2=$$GET1^DIQ(81.1,PXK1,.01)
+7 if PXK2=""
QUIT
+8 ;Q:$G(^UTILITY("DIQ1",$J,81,DA,3))=""
+9 ;S PXKCPTT(4.1)=$G(^UTILITY("DIQ1",$J,81,DA,3))
+10 SET PXKCPTT(4.1)=PXK2
+11 SET PXKCPTT(5)=$EXTRACT(PXKCPTT(4.1),1,30)
+12 SET PXKCPTT(6)=$ORDER(^AUTNPOV("B",PXKCPTT(5),0))
+13 SET PXKPCA=$SELECT(PXKCPTT(6)="":PXKCPTT(5),PXKCPTT(6)'="":PXKCPTT(6),1:"")
+14 ;,^UTILITY("DIQ1",$J),DIC,DR,DA
KILL PXKCPTT
+15 ;PX*1*124
+16 SET ^TMP("PXKSAVE",$JOB,"CPT",PXKSEQ1,0,"AFTER")=$GET(PXKCPT)_"^"_$GET(PXKAV(0,2))_"^"_$GET(PXKAV(0,3))_"^"_$GET(PXKCPTN)_"^"_$GET(PXKAV(0,8))_"^^^^"
+17 SET ^TMP("PXKSAVE",$JOB,"CPT",PXKSEQ1,0,"AFTER")=^TMP("PXKSAVE",$JOB,"CPT",PXKSEQ1,0,"AFTER")_$GET(PXKAV(0,9))_"^"_$GET(PXKAV(0,10))_"^"_$GET(PXKAV(0,11))_"^"_$GET(PXKAV(0,12))_"^"_...
... $GET(PXKAV(0,13))_"^"_$GET(PXKAV(0,14))_"^"_$GET(PXKAV(0,15))_"^"_$GET(PXKQUN)
+18 SET PXKSEQ2=0
+19 FOR
SET PXKSEQ2=$ORDER(PXKAFT(1,PXKSEQ2))
if 'PXKSEQ2
QUIT
Begin DoDot:1
+20 SET ^TMP("PXKSAVE",$JOB,"CPT",PXKSEQ1,1,PXKSEQ2,"AFTER")=PXKAFT(1,PXKSEQ2)
End DoDot:1
+21 SET ^TMP("PXKSAVE",$JOB,"CPT",PXKSEQ1,12,"AFTER")=$GET(PXKAV(12,1))_"^"_$GET(PXKAV(12,2))_"^^"_$GET(PXKAV(12,4))
+22 SET ^TMP("PXKSAVE",$JOB,"CPT",PXKSEQ1,802,"AFTER")=$GET(PXKCA)
+23 SET ^TMP("PXKSAVE",$JOB,"CPT",PXKSEQ1,812,"AFTER")=$GET(PXKAFT(812))
+24 SET ^TMP("PXKSAVE",$JOB,"CPT",PXKSEQ1,"IEN")=PXKKK
+25 KILL PXKQUN,PXKCPTN,PXKCA,PXXX,PXKKK
+26 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
