Routine: PXRHS04

PXRHS04 ; SLC/SBW - PCE Visit Skin Test Data Extract ;11/25/96

 ;;1.0;PCE PATIENT CARE ENCOUNTER;**13**;Aug 12, 1996

SKIN(DFN) ; Control branching

 ;INPUT  : DFN      - Pointer to PATIENT file (#2)

 ;OUTPUT :

 ;  Data from V SKIN TEST (9000010.12) file

 ;  ^TMP("PXS,$J,SKIN,InvDt,IFN,0) = SKIN TEST [E;.01]

 ;     ^ EVENT DATE/TIME or VISIT/ADMIT DATE&TIME [I;1201 or .03]

 ;     ^ RESULTS CODE [I;.04] ^ RESULTS [E;.04] ^ READING [E;.05]

 ;     ^ DATE READ [I;.06] ^ ORDERING PROVIDER [E;1202]

 ;     ^ ENCOUNTER PROVIDER [E;1204]

 ;  ^TMP("PXS",$J,SKIN,InvDt,IFN,1) = ^ HOSPITAL LOCATION [E;9000010;.22]

 ;     ^ HOSP. LOC. ABBREVIATION [E;44;1]

 ;     ^ LOC OF ENCOUNTER [E;9000010;.06] ^ OUTSIDE LOC [E;9000010;2101]

 ;  ^TMP("PXS",$J,SKIN,InvDt,IFN,"S") = DATA SOURCE [E;80102]

 ;   [] = [I(nternal)/E(xternal); Optional file #; Record #]

 ;   Subscripts:

 ;     SKIN  - Skin Test name

 ;     InvDt - Inverse FileMan date of DATE OF event or visit

 ;     IFN   - Internal Record #

 Q:$G(DFN)']""!'$D(^AUPNVSK("AA",DFN))

 N PXSK,PXIVD,PXIFN,IHSDATE

 S IHSDATE=9999999-$$HSDATE^PXRHS01

 K ^TMP("PXS",$J)

 S PXSK=""

 F  S PXSK=$O(^AUPNVSK("AA",DFN,PXSK)) Q:PXSK=""  D

 . S PXIVD=0

 . F  S PXIVD=$O(^AUPNVSK("AA",DFN,PXSK,PXIVD)) Q:PXIVD'>0  Q:PXIVD>IHSDATE  D

 . . S PXIFN=0

 . . F  S PXIFN=$O(^AUPNVSK("AA",DFN,PXSK,PXIVD,PXIFN)) Q:PXIFN'>0  D

 . . . N DIC,DIQ,DR,DA,REC,VDATA,SKIN,SKDT,RESULTC,RESULT,READING,RDT

 . . . N OPROV,EPROV,HLOC,HLOCABB,SOURCE,IDT,COMMENT

 . . . S DIC=9000010.12,DA=PXIFN,DIQ="REC(",DIQ(0)="IE"

 . . . S DR=".01;.03;.04;.05;.06;1201;1202;1204;80102;81101"

 . . . D EN^DIQ1

 . . . Q:'$D(REC)

 . . . S VDATA=$$GETVDATA^PXRHS03(+REC(9000010.12,DA,.03,"I"))

 . . . S SKIN=REC(9000010.12,DA,.01,"E")

 . . . S SKDT=REC(9000010.12,DA,1201,"I")

 . . . S:SKDT']"" SKDT=$P(VDATA,U)

 . . . S IDT=9999999-SKDT

 . . . S RESULTC=REC(9000010.12,DA,.04,"I")

 . . . S RESULT=REC(9000010.12,DA,.04,"E")

 . . . S READING=REC(9000010.12,DA,.05,"E")

 . . . S RDT=REC(9000010.12,DA,.06,"I")

 . . . S OPROV=REC(9000010.12,DA,1202,"E")

 . . . S EPROV=REC(9000010.12,DA,1204,"E")

 . . . S HLOC=$P(VDATA,U,5)

 . . . S HLOCABB=$P(VDATA,U,6)

 . . . S SOURCE=REC(9000010.12,DA,80102,"E")

 . . . S COMMENT=REC(9000010.12,DA,81101,"E")

 . . . S ^TMP("PXS",$J,SKIN,IDT,DA,0)=SKIN_U_SKDT_U_RESULTC_U_RESULT_U_READING_U_RDT_U_OPROV_U_EPROV

 . . . S ^TMP("PXS",$J,SKIN,IDT,DA,1)=HLOC_U_HLOCABB_U_$P(VDATA,U,2)_U_$P(VDATA,U,4)

 . . . S ^TMP("PXS",$J,SKIN,IDT,DA,"S")=SOURCE

 . . . S ^TMP("PXS",$J,SKIN,IDT,DA,"COM")=COMMENT

PXRHS04   ; SLC/SBW - PCE Visit Skin Test Data Extract ;11/25/96

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

SKIN(DFN) ; Control branching

 +1       ;INPUT  : DFN      - Pointer to PATIENT file (#2)

 +2       ;OUTPUT :

 +3       ;  Data from V SKIN TEST (9000010.12) file

 +4       ;  ^TMP("PXS,$J,SKIN,InvDt,IFN,0) = SKIN TEST [E;.01]

 +5       ;     ^ EVENT DATE/TIME or VISIT/ADMIT DATE&TIME [I;1201 or .03]

 +6       ;     ^ RESULTS CODE [I;.04] ^ RESULTS [E;.04] ^ READING [E;.05]

 +7       ;     ^ DATE READ [I;.06] ^ ORDERING PROVIDER [E;1202]

 +8       ;     ^ ENCOUNTER PROVIDER [E;1204]

 +9       ;  ^TMP("PXS",$J,SKIN,InvDt,IFN,1) = ^ HOSPITAL LOCATION [E;9000010;.22]

 +10      ;     ^ HOSP. LOC. ABBREVIATION [E;44;1]

 +11      ;     ^ LOC OF ENCOUNTER [E;9000010;.06] ^ OUTSIDE LOC [E;9000010;2101]

 +12      ;  ^TMP("PXS",$J,SKIN,InvDt,IFN,"S") = DATA SOURCE [E;80102]

 +13      ;

 +14      ;   [] = [I(nternal)/E(xternal); Optional file #; Record #]

 +15      ;   Subscripts:

 +16      ;     SKIN  - Skin Test name

 +17      ;     InvDt - Inverse FileMan date of DATE OF event or visit

 +18      ;     IFN   - Internal Record #

 +19      ;

 +20       IF $GET(DFN)']""!'$DATA(^AUPNVSK("AA",DFN))

               QUIT

 +21       NEW PXSK,PXIVD,PXIFN,IHSDATE

 +22       SET IHSDATE=9999999-$$HSDATE^PXRHS01

 +23       KILL ^TMP("PXS",$JOB)

 +24       SET PXSK=""

 +25       FOR

               SET PXSK=$ORDER(^AUPNVSK("AA",DFN,PXSK))

               IF PXSK=""

                   QUIT

               Begin DoDot:1

 +26               SET PXIVD=0

 +27               FOR

                       SET PXIVD=$ORDER(^AUPNVSK("AA",DFN,PXSK,PXIVD))

                       IF PXIVD'>0

                           QUIT

                       IF PXIVD>IHSDATE

                           QUIT

                       Begin DoDot:2

 +28                       SET PXIFN=0

 +29                       FOR

                               SET PXIFN=$ORDER(^AUPNVSK("AA",DFN,PXSK,PXIVD,PXIFN))

                               IF PXIFN'>0

                                   QUIT

                               Begin DoDot:3

 +30                               NEW DIC,DIQ,DR,DA,REC,VDATA,SKIN,SKDT,RESULTC,RESULT,READING,RDT

 +31                               NEW OPROV,EPROV,HLOC,HLOCABB,SOURCE,IDT,COMMENT

 +32                               SET DIC=9000010.12

                                   SET DA=PXIFN

                                   SET DIQ="REC("

                                   SET DIQ(0)="IE"

 +33                               SET DR=".01;.03;.04;.05;.06;1201;1202;1204;80102;81101"

 +34                               DO EN^DIQ1

 +35                               IF '$DATA(REC)

                                       QUIT

 +36                               SET VDATA=$$GETVDATA^PXRHS03(+REC(9000010.12,DA,.03,"I"))

 +37                               SET SKIN=REC(9000010.12,DA,.01,"E")

 +38                               SET SKDT=REC(9000010.12,DA,1201,"I")

 +39                               IF SKDT']""

                                       SET SKDT=$PIECE(VDATA,U)

 +40                               SET IDT=9999999-SKDT

 +41                               SET RESULTC=REC(9000010.12,DA,.04,"I")

 +42                               SET RESULT=REC(9000010.12,DA,.04,"E")

 +43                               SET READING=REC(9000010.12,DA,.05,"E")

 +44                               SET RDT=REC(9000010.12,DA,.06,"I")

 +45                               SET OPROV=REC(9000010.12,DA,1202,"E")

 +46                               SET EPROV=REC(9000010.12,DA,1204,"E")

 +47                               SET HLOC=$PIECE(VDATA,U,5)

 +48                               SET HLOCABB=$PIECE(VDATA,U,6)

 +49                               SET SOURCE=REC(9000010.12,DA,80102,"E")

 +50                               SET COMMENT=REC(9000010.12,DA,81101,"E")

 +51                               SET ^TMP("PXS",$JOB,SKIN,IDT,DA,0)=SKIN_U_SKDT_U_RESULTC_U_RESULT_U_READING_U_RDT_U_OPROV_U_EPROV

 +52                               SET ^TMP("PXS",$JOB,SKIN,IDT,DA,1)=HLOC_U_HLOCABB_U_$PIECE(VDATA,U,2)_U_$PIECE(VDATA,U,4)

 +53                               SET ^TMP("PXS",$JOB,SKIN,IDT,DA,"S")=SOURCE

 +54                               SET ^TMP("PXS",$JOB,SKIN,IDT,DA,"COM")=COMMENT

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

 +55       QUIT

PXRHS04.m