- PXKMAIN2 ;ISL/JVS - Special Routine ;Oct 23, 2018@12:50
- ;;1.0;PCE PATIENT CARE ENCOUNTER;**69,186,215,217**;Aug 12, 1996;Build 134
- ; VARIABLES
- ; See variables lists under each line tag
- ;
- ;
- SPEC ;Populate other v files
- ;
- ; As of PX*1*215, this entry point (and related POP tag) has been deprecated and
- ; replaced with SPEC2. This is part of deprecating the PCE CODE MAPPING file,
- ; and instead using the CODING SYSTEM multiple from the Immunization and
- ; Skin Test 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
- ;
- ;
- SPEC2 ;
- ; Populates V CPT and V POV files based off Immunization and
- ; Skin Test Coding System mappings.
- ;
- ; As of PX*1*215, this entry point replaces SPEC.
- ; We now use the Coding System multiple instead of the PCE Code Mapping file.
- ;
- N PXCODE,PXCODESYS,PXFROMENTRY,PXGLBL,PXKROU,PXKX,PXKXX,PXSKTYP,PXVISIT,PXVSC
- ;
- I PXKFGED=1 Q
- ;
- S PXFROMENTRY=$S(PXKFGAD=1:PXKAV(0,1),PXKFGDE=1:PXKBV(0,1),1:"0")
- I 'PXFROMENTRY Q
- ;
- I PXKCAT="IMM" S PXGLBL="^AUTTIMM("_PXFROMENTRY_")"
- I PXKCAT="SK" S PXGLBL="^AUTTSK("_PXFROMENTRY_")"
- ; Only file codes from IMM/SK -> V CPT and V POV
- I $G(PXGLBL)="" Q
- ;
- ; Only file for VA-Administered (non-historical) entries
- S PXVISIT=$G(^TMP("PXK",$J,"VST",1,"IEN"))
- S PXVSC=$P($G(^AUPNVSIT(+PXVISIT,0)),U,7)
- I "AHISORD"'[PXVSC Q
- ;
- ; Is this a skin test placement ("A") or reading ("R")?
- I PXKCAT="SK" D
- . N X
- . S X=$S(PXKFGAD=1:$G(PXKAV(12,8)),PXKFGDE=1:$P($G(@PXKREF@(PXKCAT,PXKSEQ,12,"BEFORE")),U,8),1:"")
- . S PXSKTYP=$S(X:"R",1:"A")
- ;
- F PXCODESYS="CPT","10D" D
- . ;
- . ; For Immunizations, don't delete ICD-10 code unless there are no more immunizations for the Visit
- . I PXKCAT="IMM",PXKFGDE=1,PXCODESYS="10D",$O(^AUPNVIMM("AD",+PXVISIT,0)) Q
- . ;
- . S PXCODE=$$GETCODE(PXKCAT,PXGLBL,PXCODESYS,$G(PXSKTYP))
- . I PXCODE="" Q
- . ;
- . I PXCODESYS="CPT" S PXCODE=$$CODEN^ICPTCOD(PXCODE)
- . I PXCODESYS="10D" S PXCODE=+$$CODEN^ICDEX(PXCODE,80) ;IA 5747
- . I PXCODE'>0 Q
- . ;
- . S PXKX=($O(PXKPXD(""),-1))+1
- . S PXKPXD(PXKX)=PXFROMENTRY_";"_$S(PXKCAT="IMM":"AUTTIMM(",1:"AUTTSK(")
- . S PXKPXD(PXKX)=PXKPXD(PXKX)_U_PXCODE_";"_$S(PXCODESYS="CPT":"ICPT(",1:"ICD9(")
- . S PXKPXD(PXKX)=PXKPXD(PXKX)_U_PXKCAT_U_PXCODESYS_U_"1"
- . S PXKXX=PXKX*.01
- . ;
- . S PXKROU=PXKCAT_"^PXKF"_$S(PXCODESYS="CPT":"CPT",1:"POV")_"1"
- . D @PXKROU
- . ;
- . S PXKNORG("SOR")=$G(^TMP("PXK",$J,"SOR"))
- . S PXKNORG("VSTIEN")=$G(^TMP("PXK",$J,"VST",1,"IEN"))
- ;
- Q
- ;
- ;
- GETCODE(PXKCAT,PXGLBL,PXCODESYS,PXSKTYP) ;
- ;
- N PXCIEN,PXCODE,PXCOUNT,PXCSIEN
- ;
- ; For skin test reading, get CPT code from the PXV SKIN TEST READING CPT parameter
- I PXKCAT="SK",$G(PXSKTYP)="R",PXCODESYS="CPT" D Q PXCODE
- . S PXCODE=$$GET^XPAR("ALL","PXV SKIN TEST READING CPT",1,"I")
- ;
- S PXCSIEN=$O(@PXGLBL@(3,"B",PXCODESYS,0))
- I 'PXCSIEN Q ""
- ;
- S PXCODE=""
- S PXCOUNT=0
- S PXCIEN=0
- F S PXCIEN=$O(@PXGLBL@(3,PXCSIEN,1,PXCIEN)) Q:'PXCIEN D
- . S PXCODE=$P($G(@PXGLBL@(3,PXCSIEN,1,PXCIEN,0)),U,1)
- . S PXCOUNT=PXCOUNT+1
- ;
- ; Only file, when there is one code mapped to the IMM/SK entry
- I PXCOUNT'=1 Q ""
- ;
- Q PXCODE
- ;
- ;
- 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),+$P($G(PXKDT),".")) Q:TYPE<1
- .I $P(NOD0,"^",6)']"" S $P(NOD0,"^",6)=TYPE
- .S ^TMP("PXK",$J,"PRV",PXKPSUB,0,"AFTER")=NOD0
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXKMAIN2 6187 printed Feb 18, 2025@23:55:45 Page 2
- PXKMAIN2 ;ISL/JVS - Special Routine ;Oct 23, 2018@12:50
- +1 ;;1.0;PCE PATIENT CARE ENCOUNTER;**69,186,215,217**;Aug 12, 1996;Build 134
- +2 ; VARIABLES
- +3 ; See variables lists under each line tag
- +4 ;
- +5 ;
- SPEC ;Populate other v files
- +1 ;
- +2 ; As of PX*1*215, this entry point (and related POP tag) has been deprecated and
- +3 ; replaced with SPEC2. This is part of deprecating the PCE CODE MAPPING file,
- +4 ; and instead using the CODING SYSTEM multiple from the Immunization and
- +5 ; Skin Test files.
- +6 ;
- +7 ; VARIABLES
- +8 ; PXKAV(0) = The AFTER variables created in PXKMAIN
- +9 ; PXKBV(0) = The BEFORE variables created in PXKMAIN
- +10 ; PXKFG(ED,DE,AD) =The EDIT,DELETE,ADD flags
- +11 ; PXKCAT = The category being $o through (CPT,IMM etc...)
- +12 ; PXKIN = The pointer value of first piece in the mapping file
- +13 ; PXKPXD = An array with all the entries to be mapped this go around
- +14 ; PXKDIEN = IEN of the coding file
- +15 ;
- +16 SET PXKDONE=0
- +17 if PXKFGED=1
- QUIT
- +18 IF (PXKFGAD=1)
- Begin DoDot:1
- +19 IF $DATA(^PXD(811.1,"AA",PXKAV(0,1),""_PXKCAT_"",1))
- Begin DoDot:2
- +20 SET PXKDONE=$ORDER(^PXD(811.1,"AA",PXKAV(0,1),""_PXKCAT_"",1,PXKDONE))
- +21 ;8TH IEN
- SET PXJ(1)=$GET(^PXD(811.1,PXKDONE,0))
- +22 ;SECOND PIECE OF 8TH IEN
- SET PXJ(2)=$PIECE(PXJ(1),"^",2)
- +23 ;FIRST PIECE OF ABOVE
- SET PXJ(3)=$PIECE(PXJ(2),";",1)
- +24 ;TO
- SET PXJ(4)=$PIECE(PXJ(1),"^",4)
- +25 SET PXKDONE=$ORDER(^PXD(811.1,"AA",PXJ(3),""_PXJ(4)_"",1,0))
- +26 if PXKDONE=""
- SET PXKDONE=0
- IF '$DATA(PXKPXD($GET(PXKDONE)))
- DO POP
- End DoDot:2
- End DoDot:1
- +27 IF (PXKFGDE=1)
- Begin DoDot:1
- +28 IF $DATA(^PXD(811.1,"AA",PXKBV(0,1),""_PXKCAT_"",1))
- Begin DoDot:2
- +29 SET PXKDONE=$ORDER(^PXD(811.1,"AA",PXKBV(0,1),""_PXKCAT_"",1,PXKDONE))
- +30 ;8TH IEN
- SET PXJ(1)=$GET(^PXD(811.1,PXKDONE,0))
- +31 ;SECOND PIECE OF 8TH IEN
- SET PXJ(2)=$PIECE(PXJ(1),"^",2)
- +32 ;FIRST PIECE OF ABOVE
- SET PXJ(3)=$PIECE(PXJ(2),";",1)
- +33 ;TO
- SET PXJ(4)=$PIECE(PXJ(1),"^",4)
- +34 SET PXKDONE=$ORDER(^PXD(811.1,"AA",PXJ(3),""_PXJ(4)_"",1,0))
- +35 if PXKDONE=""
- SET PXKDONE=0
- IF '$DATA(PXKPXD($GET(PXKDONE)))
- DO POP
- End DoDot:2
- End DoDot:1
- +36 KILL PXKDONE
- +37 QUIT
- +38 ;
- 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 ;
- +16 ;
- SPEC2 ;
- +1 ; Populates V CPT and V POV files based off Immunization and
- +2 ; Skin Test Coding System mappings.
- +3 ;
- +4 ; As of PX*1*215, this entry point replaces SPEC.
- +5 ; We now use the Coding System multiple instead of the PCE Code Mapping file.
- +6 ;
- +7 NEW PXCODE,PXCODESYS,PXFROMENTRY,PXGLBL,PXKROU,PXKX,PXKXX,PXSKTYP,PXVISIT,PXVSC
- +8 ;
- +9 IF PXKFGED=1
- QUIT
- +10 ;
- +11 SET PXFROMENTRY=$SELECT(PXKFGAD=1:PXKAV(0,1),PXKFGDE=1:PXKBV(0,1),1:"0")
- +12 IF 'PXFROMENTRY
- QUIT
- +13 ;
- +14 IF PXKCAT="IMM"
- SET PXGLBL="^AUTTIMM("_PXFROMENTRY_")"
- +15 IF PXKCAT="SK"
- SET PXGLBL="^AUTTSK("_PXFROMENTRY_")"
- +16 ; Only file codes from IMM/SK -> V CPT and V POV
- +17 IF $GET(PXGLBL)=""
- QUIT
- +18 ;
- +19 ; Only file for VA-Administered (non-historical) entries
- +20 SET PXVISIT=$GET(^TMP("PXK",$JOB,"VST",1,"IEN"))
- +21 SET PXVSC=$PIECE($GET(^AUPNVSIT(+PXVISIT,0)),U,7)
- +22 IF "AHISORD"'[PXVSC
- QUIT
- +23 ;
- +24 ; Is this a skin test placement ("A") or reading ("R")?
- +25 IF PXKCAT="SK"
- Begin DoDot:1
- +26 NEW X
- +27 SET X=$SELECT(PXKFGAD=1:$GET(PXKAV(12,8)),PXKFGDE=1:$PIECE($GET(@PXKREF@(PXKCAT,PXKSEQ,12,"BEFORE")),U,8),1:"")
- +28 SET PXSKTYP=$SELECT(X:"R",1:"A")
- End DoDot:1
- +29 ;
- +30 FOR PXCODESYS="CPT","10D"
- Begin DoDot:1
- +31 ;
- +32 ; For Immunizations, don't delete ICD-10 code unless there are no more immunizations for the Visit
- +33 IF PXKCAT="IMM"
- IF PXKFGDE=1
- IF PXCODESYS="10D"
- IF $ORDER(^AUPNVIMM("AD",+PXVISIT,0))
- QUIT
- +34 ;
- +35 SET PXCODE=$$GETCODE(PXKCAT,PXGLBL,PXCODESYS,$GET(PXSKTYP))
- +36 IF PXCODE=""
- QUIT
- +37 ;
- +38 IF PXCODESYS="CPT"
- SET PXCODE=$$CODEN^ICPTCOD(PXCODE)
- +39 ;IA 5747
- IF PXCODESYS="10D"
- SET PXCODE=+$$CODEN^ICDEX(PXCODE,80)
- +40 IF PXCODE'>0
- QUIT
- +41 ;
- +42 SET PXKX=($ORDER(PXKPXD(""),-1))+1
- +43 SET PXKPXD(PXKX)=PXFROMENTRY_";"_$SELECT(PXKCAT="IMM":"AUTTIMM(",1:"AUTTSK(")
- +44 SET PXKPXD(PXKX)=PXKPXD(PXKX)_U_PXCODE_";"_$SELECT(PXCODESYS="CPT":"ICPT(",1:"ICD9(")
- +45 SET PXKPXD(PXKX)=PXKPXD(PXKX)_U_PXKCAT_U_PXCODESYS_U_"1"
- +46 SET PXKXX=PXKX*.01
- +47 ;
- +48 SET PXKROU=PXKCAT_"^PXKF"_$SELECT(PXCODESYS="CPT":"CPT",1:"POV")_"1"
- +49 DO @PXKROU
- +50 ;
- +51 SET PXKNORG("SOR")=$GET(^TMP("PXK",$JOB,"SOR"))
- +52 SET PXKNORG("VSTIEN")=$GET(^TMP("PXK",$JOB,"VST",1,"IEN"))
- End DoDot:1
- +53 ;
- +54 QUIT
- +55 ;
- +56 ;
- GETCODE(PXKCAT,PXGLBL,PXCODESYS,PXSKTYP) ;
- +1 ;
- +2 NEW PXCIEN,PXCODE,PXCOUNT,PXCSIEN
- +3 ;
- +4 ; For skin test reading, get CPT code from the PXV SKIN TEST READING CPT parameter
- +5 IF PXKCAT="SK"
- IF $GET(PXSKTYP)="R"
- IF PXCODESYS="CPT"
- Begin DoDot:1
- +6 SET PXCODE=$$GET^XPAR("ALL","PXV SKIN TEST READING CPT",1,"I")
- End DoDot:1
- QUIT PXCODE
- +7 ;
- +8 SET PXCSIEN=$ORDER(@PXGLBL@(3,"B",PXCODESYS,0))
- +9 IF 'PXCSIEN
- QUIT ""
- +10 ;
- +11 SET PXCODE=""
- +12 SET PXCOUNT=0
- +13 SET PXCIEN=0
- +14 FOR
- SET PXCIEN=$ORDER(@PXGLBL@(3,PXCSIEN,1,PXCIEN))
- if 'PXCIEN
- QUIT
- Begin DoDot:1
- +15 SET PXCODE=$PIECE($GET(@PXGLBL@(3,PXCSIEN,1,PXCIEN,0)),U,1)
- +16 SET PXCOUNT=PXCOUNT+1
- End DoDot:1
- +17 ;
- +18 ; Only file, when there is one code mapped to the IMM/SK entry
- +19 IF PXCOUNT'=1
- QUIT ""
- +20 ;
- +21 QUIT PXCODE
- +22 ;
- +23 ;
- 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),+$PIECE($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