PXKMAIN2 ;ISL/JVS - Special Routine ;5/21/96 13:20
;;1.0;PCE PATIENT CARE ENCOUNTER;**69**;Aug 12, 1996
; VARIABLES
; See variables lists under each line tag
;
;
SPEC ;Populate other v files
; VARIABLES
; PXKAV(0) = The AFTER variables created in PXKMAIN
; PXKBV(0) = The BEFORE variables created in PXKMAIN
; PXKFG(ED,DE,AD) =The EDIT,DELETE,ADD flags
; PXKCAT = The category being $o through (CPT,IMM etc...)
; PXKIN = The pointer value of first piece in the mapping file
; PXKPXD = An array with all the entries to be mapped this go around
; PXKDIEN = IEN of the coding file
;
S PXKDONE=0
Q:PXKFGED=1
I (PXKFGAD=1) D
.I $D(^PXD(811.1,"AA",PXKAV(0,1),""_PXKCAT_"",1)) D
..S PXKDONE=$O(^PXD(811.1,"AA",PXKAV(0,1),""_PXKCAT_"",1,PXKDONE))
..S PXJ(1)=$G(^PXD(811.1,PXKDONE,0)) ;8TH IEN
..S PXJ(2)=$P(PXJ(1),"^",2) ;SECOND PIECE OF 8TH IEN
..S PXJ(3)=$P(PXJ(2),";",1) ;FIRST PIECE OF ABOVE
..S PXJ(4)=$P(PXJ(1),"^",4) ;TO
..S PXKDONE=$O(^PXD(811.1,"AA",PXJ(3),""_PXJ(4)_"",1,0))
..S:PXKDONE="" PXKDONE=0 I '$D(PXKPXD($G(PXKDONE))) D POP
I (PXKFGDE=1) D
.I $D(^PXD(811.1,"AA",PXKBV(0,1),""_PXKCAT_"",1)) D
..S PXKDONE=$O(^PXD(811.1,"AA",PXKBV(0,1),""_PXKCAT_"",1,PXKDONE))
..S PXJ(1)=$G(^PXD(811.1,PXKDONE,0)) ;8TH IEN
..S PXJ(2)=$P(PXJ(1),"^",2) ;SECOND PIECE OF 8TH IEN
..S PXJ(3)=$P(PXJ(2),";",1) ;FIRST PIECE OF ABOVE
..S PXJ(4)=$P(PXJ(1),"^",4) ;TO
..S PXKDONE=$O(^PXD(811.1,"AA",PXJ(3),""_PXJ(4)_"",1,0))
..S:PXKDONE="" PXKDONE=0 I '$D(PXKPXD($G(PXKDONE))) D POP
K PXKDONE
Q
;
POP ;Population of more than one v file using PCE CODE MAPPING file 811.1
;
;N PXKPXD
N PXKROU,PXKIN,PXKX,PXKXX,PXKDIEN,PXKTO
S PXKIN=$S(PXKFGAD=1:PXKAV(0,1),PXKFGDE=1:PXKBV(0,1),1:"")
S PXKDIEN=0 F S PXKDIEN=$O(^PXD(811.1,"AA",PXKIN,PXKCAT,1,PXKDIEN)) Q:PXKDIEN="" D
.S PXKPXD(PXKDIEN)=$G(^PXD(811.1,PXKDIEN,0))
S (PXKX,PXKXX)=0 F S PXKX=$O(PXKPXD(PXKX)) Q:PXKX="" S PXKXX=PXKXX+.01 D
.I TMPPX[("^"_PXKX_"^") Q
.S PXKTO=$P(PXKPXD(PXKX),"^",4)
.S PXKROU=$P(PXKPXD(PXKX),"^",3)_"^PXKF"_PXKTO_"1" D @PXKROU
.S TMPPX=TMPPX_PXKX_"^"
S PXKNORG("SOR")=$G(^TMP("PXK",$J,"SOR"))
S PXKNORG("VSTIEN")=$G(^TMP("PXK",$J,"VST",1,"IEN"))
Q
;
RECALL ; Recall PXKMAIN to populate special circumstances
D EVENT^PXKMAIN K ^TMP("PXK",$J)
S PXKREF="^TMP(""PXKSAVE"",$J)"
F S PXKREF=$Q(@PXKREF) Q:$P(PXKREF,",",1)'["PXKSAVE" Q:$P(PXKREF,",",2)'[$J Q:PXKREF="" S PXKSAVE=PXKREF D
.S $P(PXKSAVE,"""",2)="PXK" S @PXKSAVE=$G(@PXKREF)
S ^TMP("PXK",$J,"SOR")=$G(PXKNORG("SOR"))
S ^TMP("PXK",$J,"VST",1,"IEN")=$G(PXKNORG("VSTIEN"))
K ^TMP("PXKSAVE",$J),PXKNORG
D EN1^PXKMAIN,EVENT^PXKMAIN
Q
;
;
PRVTYPE ;---POPULATE PROVIDER TYPE
;
;--**
I '$D(^TMP("PXK",$J,"PRV")) Q
I '$L($T(GET^XUA4A72)) Q
N PXKPSUB,PXKPRV,PXKDT,NOD0,TYPE
S PXKPSUB=0 F S PXKPSUB=$O(^TMP("PXK",$J,"PRV",PXKPSUB)) Q:PXKPSUB="" D
.S NOD0=$G(^TMP("PXK",$J,"PRV",PXKPSUB,0,"AFTER"))
.S PXKPRV=$P(NOD0,"^",1)
.I '$G(PXKPRV) Q
.S PXKDT=+$P($G(^AUPNVSIT($G(^TMP("PXK",$J,"VST",1,"IEN")),0)),"^",1)
.;--** ADD FUNCTION
.S TYPE=+$$GET^XUA4A72($G(PXKPRV),$G(PXKDT)) Q:TYPE<1
.I $P(NOD0,"^",6)']"" S $P(NOD0,"^",6)=TYPE
.S ^TMP("PXK",$J,"PRV",PXKPSUB,0,"AFTER")=NOD0
Q
PXKMAIN2 ;ISL/JVS - Special Routine ;5/21/96 13:20
+1 ;;1.0;PCE PATIENT CARE ENCOUNTER;**69**;Aug 12, 1996
+2 ; VARIABLES
+3 ; See variables lists under each line tag
+4 ;
+5 ;
SPEC ;Populate other v files
+1 ; VARIABLES
+2 ; PXKAV(0) = The AFTER variables created in PXKMAIN
+3 ; PXKBV(0) = The BEFORE variables created in PXKMAIN
+4 ; PXKFG(ED,DE,AD) =The EDIT,DELETE,ADD flags
+5 ; PXKCAT = The category being $o through (CPT,IMM etc...)
+6 ; PXKIN = The pointer value of first piece in the mapping file
+7 ; PXKPXD = An array with all the entries to be mapped this go around
+8 ; PXKDIEN = IEN of the coding file
+9 ;
+10 SET PXKDONE=0
+11 IF PXKFGED=1
QUIT
+12 IF (PXKFGAD=1)
Begin DoDot:1
+13 IF $DATA(^PXD(811.1,"AA",PXKAV(0,1),""_PXKCAT_"",1))
Begin DoDot:2
+14 SET PXKDONE=$ORDER(^PXD(811.1,"AA",PXKAV(0,1),""_PXKCAT_"",1,PXKDONE))
+15 ;8TH IEN
SET PXJ(1)=$GET(^PXD(811.1,PXKDONE,0))
+16 ;SECOND PIECE OF 8TH IEN
SET PXJ(2)=$PIECE(PXJ(1),"^",2)
+17 ;FIRST PIECE OF ABOVE
SET PXJ(3)=$PIECE(PXJ(2),";",1)
+18 ;TO
SET PXJ(4)=$PIECE(PXJ(1),"^",4)
+19 SET PXKDONE=$ORDER(^PXD(811.1,"AA",PXJ(3),""_PXJ(4)_"",1,0))
+20 IF PXKDONE=""
SET PXKDONE=0
IF '$DATA(PXKPXD($GET(PXKDONE)))
DO POP
End DoDot:2
End DoDot:1
+21 IF (PXKFGDE=1)
Begin DoDot:1
+22 IF $DATA(^PXD(811.1,"AA",PXKBV(0,1),""_PXKCAT_"",1))
Begin DoDot:2
+23 SET PXKDONE=$ORDER(^PXD(811.1,"AA",PXKBV(0,1),""_PXKCAT_"",1,PXKDONE))
+24 ;8TH IEN
SET PXJ(1)=$GET(^PXD(811.1,PXKDONE,0))
+25 ;SECOND PIECE OF 8TH IEN
SET PXJ(2)=$PIECE(PXJ(1),"^",2)
+26 ;FIRST PIECE OF ABOVE
SET PXJ(3)=$PIECE(PXJ(2),";",1)
+27 ;TO
SET PXJ(4)=$PIECE(PXJ(1),"^",4)
+28 SET PXKDONE=$ORDER(^PXD(811.1,"AA",PXJ(3),""_PXJ(4)_"",1,0))
+29 IF PXKDONE=""
SET PXKDONE=0
IF '$DATA(PXKPXD($GET(PXKDONE)))
DO POP
End DoDot:2
End DoDot:1
+30 KILL PXKDONE
+31 QUIT
+32 ;
POP ;Population of more than one v file using PCE CODE MAPPING file 811.1
+1 ;
+2 ;N PXKPXD
+3 NEW PXKROU,PXKIN,PXKX,PXKXX,PXKDIEN,PXKTO
+4 SET PXKIN=$SELECT(PXKFGAD=1:PXKAV(0,1),PXKFGDE=1:PXKBV(0,1),1:"")
+5 SET PXKDIEN=0
FOR
SET PXKDIEN=$ORDER(^PXD(811.1,"AA",PXKIN,PXKCAT,1,PXKDIEN))
IF PXKDIEN=""
QUIT
Begin DoDot:1
+6 SET PXKPXD(PXKDIEN)=$GET(^PXD(811.1,PXKDIEN,0))
End DoDot:1
+7 SET (PXKX,PXKXX)=0
FOR
SET PXKX=$ORDER(PXKPXD(PXKX))
IF PXKX=""
QUIT
SET PXKXX=PXKXX+.01
Begin DoDot:1
+8 IF TMPPX[("^"_PXKX_"^")
QUIT
+9 SET PXKTO=$PIECE(PXKPXD(PXKX),"^",4)
+10 SET PXKROU=$PIECE(PXKPXD(PXKX),"^",3)_"^PXKF"_PXKTO_"1"
DO @PXKROU
+11 SET TMPPX=TMPPX_PXKX_"^"
End DoDot:1
+12 SET PXKNORG("SOR")=$GET(^TMP("PXK",$JOB,"SOR"))
+13 SET PXKNORG("VSTIEN")=$GET(^TMP("PXK",$JOB,"VST",1,"IEN"))
+14 QUIT
+15 ;
RECALL ; Recall PXKMAIN to populate special circumstances
+1 DO EVENT^PXKMAIN
KILL ^TMP("PXK",$JOB)
+2 SET PXKREF="^TMP(""PXKSAVE"",$J)"
+3 FOR
SET PXKREF=$QUERY(@PXKREF)
IF $PIECE(PXKREF,",",1)'["PXKSAVE"
QUIT
IF $PIECE(PXKREF,",",2)'[$JOB
QUIT
IF PXKREF=""
QUIT
SET PXKSAVE=PXKREF
Begin DoDot:1
+4 SET $PIECE(PXKSAVE,"""",2)="PXK"
SET @PXKSAVE=$GET(@PXKREF)
End DoDot:1
+5 SET ^TMP("PXK",$JOB,"SOR")=$GET(PXKNORG("SOR"))
+6 SET ^TMP("PXK",$JOB,"VST",1,"IEN")=$GET(PXKNORG("VSTIEN"))
+7 KILL ^TMP("PXKSAVE",$JOB),PXKNORG
+8 DO EN1^PXKMAIN
DO EVENT^PXKMAIN
+9 QUIT
+10 ;
+11 ;
PRVTYPE ;---POPULATE PROVIDER TYPE
+1 ;
+2 ;--**
+3 IF '$DATA(^TMP("PXK",$JOB,"PRV"))
QUIT
+4 IF '$LENGTH($TEXT(GET^XUA4A72))
QUIT
+5 NEW PXKPSUB,PXKPRV,PXKDT,NOD0,TYPE
+6 SET PXKPSUB=0
FOR
SET PXKPSUB=$ORDER(^TMP("PXK",$JOB,"PRV",PXKPSUB))
IF PXKPSUB=""
QUIT
Begin DoDot:1
+7 SET NOD0=$GET(^TMP("PXK",$JOB,"PRV",PXKPSUB,0,"AFTER"))
+8 SET PXKPRV=$PIECE(NOD0,"^",1)
+9 IF '$GET(PXKPRV)
QUIT
+10 SET PXKDT=+$PIECE($GET(^AUPNVSIT($GET(^TMP("PXK",$JOB,"VST",1,"IEN")),0)),"^",1)
+11 ;--** ADD FUNCTION
+12 SET TYPE=+$$GET^XUA4A72($GET(PXKPRV),$GET(PXKDT))
IF TYPE<1
QUIT
+13 IF $PIECE(NOD0,"^",6)']""
SET $PIECE(NOD0,"^",6)=TYPE
+14 SET ^TMP("PXK",$JOB,"PRV",PXKPSUB,0,"AFTER")=NOD0
End DoDot:1
+15 QUIT
