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
Q
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
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
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
