PXRHS04 ; SLC/SBW - PCE Visit Skin Test Data Extract ;Apr 09, 2018@11:14
;;1.0;PCE PATIENT CARE ENCOUNTER;**13,206,217**;Aug 12, 1996;Build 134
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,"P") = PLACEMENT HOSPITAL LOCATION [E;9000010;.22]
; ^ PLACE. HOSP. LOC. ABBREVIATION [E;44;1]
; ^ PLACE. LOC OF ENCOUNTER [E;9000010;.06] ^ PLACE. OUTSIDE LOC [E;9000010;2101]
; ^ PLACE. DATA SOURCE
; ^TMP("PXS",$J,SKIN,InvDt,IFN,"COM") = PLACEMENT COMMENTS [E;81101]
; ^TMP("PXS",$J,SKIN,InvDt,IFN,"S") = DATA SOURCE [E;81203]
;
; [] = [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
N PXPLACEIEN,PXPLACE12,PXPLACEVST,PVDATA,PSOURCE
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,PXSKIEN
. . . S (PXPLACEIEN,PXPLACE12,PXPLACEVST)=""
. . . ; Filter out placement entries
. . . I $D(^AUPNVSK("APT",PXIFN)) Q
. . . S DIC=9000010.12,DA=PXIFN,DIQ="REC(",DIQ(0)="IE"
. . . S DR=".01;.03;.04;.05;.06;1201;1202;1204;1208;81203;81101"
. . . D EN^DIQ1
. . . Q:'$D(REC)
. . . S VDATA=$$GETVDATA^PXRHS03(+REC(9000010.12,DA,.03,"I"))
. . . I REC(9000010.12,DA,1208,"I") D
. . . . S PXPLACEIEN=REC(9000010.12,DA,1208,"I")
. . . . S PXPLACE12=$G(^AUPNVSK(PXPLACEIEN,12))
. . . . S PXPLACEVST=$P($G(^AUPNVSK(PXPLACEIEN,0)),U,3)
. . . S SKIN=REC(9000010.12,DA,.01,"E") ;+ORIG
. . . S PXSKIEN=REC(9000010.12,DA,.01,"I") ;get SKIN TEST IEN
. . . ;replace Name with PRINT NAME for National records
. . . I $P($G(^AUTTSK(+PXSKIEN,12)),U)]"" S SKIN=$P(^AUTTSK(+PXSKIEN,12),U)
. . . I $L(SKIN)>11 D ;name longer than 11 characters
. . . . S SKIN=$E(SKIN,1,10)_"*" ;truncate
. . . S SKDT=REC(9000010.12,DA,1201,"I")
. . . S:SKDT']"" SKDT=$P(VDATA,U)
. . . I PXPLACEIEN D
. . . . S SKDT=$P(PXPLACE12,U,1)
. . . . I 'SKDT S SKDT=$P($G(^AUPNVSIT(+PXPLACEVST,0)),U,1)
. . . 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,81203,"E")
. . . S COMMENT=REC(9000010.12,DA,81101,"E")
. . . I PXPLACEIEN D
. . . . S OPROV=$P(PXPLACE12,U,2)
. . . . S OPROV=$P($G(^VA(200,+OPROV,0)),U,1)
. . . . S EPROV=$P(PXPLACE12,U,4)
. . . . S EPROV=$P($G(^VA(200,+EPROV,0)),U,1)
. . . . S COMMENT=$G(^AUPNVSK(PXPLACEIEN,811))
. . . . S PSOURCE=$P($G(^AUPNVSK(PXPLACEIEN,812)),U,3)
. . . . S PSOURCE=$P($G(^PX(839.7,+PSOURCE,0)),U,1)
. . . . S PVDATA=$$GETVDATA^PXRHS03(+PXPLACEVST)
. . . . S ^TMP("PXS",$J,SKIN,IDT,DA,"P")=$P(PVDATA,U,5)_U_$P(PVDATA,U,6)_U_$P(PVDATA,U,2)_U_$P(PVDATA,U,4)_U_PSOURCE
. . . 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
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXRHS04 4280 printed Nov 22, 2024@17:40:25 Page 2
PXRHS04 ; SLC/SBW - PCE Visit Skin Test Data Extract ;Apr 09, 2018@11:14
+1 ;;1.0;PCE PATIENT CARE ENCOUNTER;**13,206,217**;Aug 12, 1996;Build 134
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,"P") = PLACEMENT HOSPITAL LOCATION [E;9000010;.22]
+13 ; ^ PLACE. HOSP. LOC. ABBREVIATION [E;44;1]
+14 ; ^ PLACE. LOC OF ENCOUNTER [E;9000010;.06] ^ PLACE. OUTSIDE LOC [E;9000010;2101]
+15 ; ^ PLACE. DATA SOURCE
+16 ; ^TMP("PXS",$J,SKIN,InvDt,IFN,"COM") = PLACEMENT COMMENTS [E;81101]
+17 ; ^TMP("PXS",$J,SKIN,InvDt,IFN,"S") = DATA SOURCE [E;81203]
+18 ;
+19 ; [] = [I(nternal)/E(xternal); Optional file #; Record #]
+20 ; Subscripts:
+21 ; SKIN - Skin Test name
+22 ; InvDt - Inverse FileMan date of DATE OF event or visit
+23 ; IFN - Internal Record #
+24 ;
+25 if $GET(DFN)']""!'$DATA(^AUPNVSK("AA",DFN))
QUIT
+26 NEW PXSK,PXIVD,PXIFN,IHSDATE
+27 NEW PXPLACEIEN,PXPLACE12,PXPLACEVST,PVDATA,PSOURCE
+28 SET IHSDATE=9999999-$$HSDATE^PXRHS01
+29 KILL ^TMP("PXS",$JOB)
+30 SET PXSK=""
+31 FOR
SET PXSK=$ORDER(^AUPNVSK("AA",DFN,PXSK))
if PXSK=""
QUIT
Begin DoDot:1
+32 SET PXIVD=0
+33 FOR
SET PXIVD=$ORDER(^AUPNVSK("AA",DFN,PXSK,PXIVD))
if PXIVD'>0
QUIT
if PXIVD>IHSDATE
QUIT
Begin DoDot:2
+34 SET PXIFN=0
+35 FOR
SET PXIFN=$ORDER(^AUPNVSK("AA",DFN,PXSK,PXIVD,PXIFN))
if PXIFN'>0
QUIT
Begin DoDot:3
+36 NEW DIC,DIQ,DR,DA,REC,VDATA,SKIN,SKDT,RESULTC,RESULT,READING,RDT
+37 NEW OPROV,EPROV,HLOC,HLOCABB,SOURCE,IDT,COMMENT,PXSKIEN
+38 SET (PXPLACEIEN,PXPLACE12,PXPLACEVST)=""
+39 ; Filter out placement entries
+40 IF $DATA(^AUPNVSK("APT",PXIFN))
QUIT
+41 SET DIC=9000010.12
SET DA=PXIFN
SET DIQ="REC("
SET DIQ(0)="IE"
+42 SET DR=".01;.03;.04;.05;.06;1201;1202;1204;1208;81203;81101"
+43 DO EN^DIQ1
+44 if '$DATA(REC)
QUIT
+45 SET VDATA=$$GETVDATA^PXRHS03(+REC(9000010.12,DA,.03,"I"))
+46 IF REC(9000010.12,DA,1208,"I")
Begin DoDot:4
+47 SET PXPLACEIEN=REC(9000010.12,DA,1208,"I")
+48 SET PXPLACE12=$GET(^AUPNVSK(PXPLACEIEN,12))
+49 SET PXPLACEVST=$PIECE($GET(^AUPNVSK(PXPLACEIEN,0)),U,3)
End DoDot:4
+50 ;+ORIG
SET SKIN=REC(9000010.12,DA,.01,"E")
+51 ;get SKIN TEST IEN
SET PXSKIEN=REC(9000010.12,DA,.01,"I")
+52 ;replace Name with PRINT NAME for National records
+53 IF $PIECE($GET(^AUTTSK(+PXSKIEN,12)),U)]""
SET SKIN=$PIECE(^AUTTSK(+PXSKIEN,12),U)
+54 ;name longer than 11 characters
IF $LENGTH(SKIN)>11
Begin DoDot:4
+55 ;truncate
SET SKIN=$EXTRACT(SKIN,1,10)_"*"
End DoDot:4
+56 SET SKDT=REC(9000010.12,DA,1201,"I")
+57 if SKDT']""
SET SKDT=$PIECE(VDATA,U)
+58 IF PXPLACEIEN
Begin DoDot:4
+59 SET SKDT=$PIECE(PXPLACE12,U,1)
+60 IF 'SKDT
SET SKDT=$PIECE($GET(^AUPNVSIT(+PXPLACEVST,0)),U,1)
End DoDot:4
+61 SET IDT=9999999-SKDT
+62 SET RESULTC=REC(9000010.12,DA,.04,"I")
+63 SET RESULT=REC(9000010.12,DA,.04,"E")
+64 SET READING=REC(9000010.12,DA,.05,"E")
+65 SET RDT=REC(9000010.12,DA,.06,"I")
+66 SET OPROV=REC(9000010.12,DA,1202,"E")
+67 SET EPROV=REC(9000010.12,DA,1204,"E")
+68 SET HLOC=$PIECE(VDATA,U,5)
+69 SET HLOCABB=$PIECE(VDATA,U,6)
+70 SET SOURCE=REC(9000010.12,DA,81203,"E")
+71 SET COMMENT=REC(9000010.12,DA,81101,"E")
+72 IF PXPLACEIEN
Begin DoDot:4
+73 SET OPROV=$PIECE(PXPLACE12,U,2)
+74 SET OPROV=$PIECE($GET(^VA(200,+OPROV,0)),U,1)
+75 SET EPROV=$PIECE(PXPLACE12,U,4)
+76 SET EPROV=$PIECE($GET(^VA(200,+EPROV,0)),U,1)
+77 SET COMMENT=$GET(^AUPNVSK(PXPLACEIEN,811))
+78 SET PSOURCE=$PIECE($GET(^AUPNVSK(PXPLACEIEN,812)),U,3)
+79 SET PSOURCE=$PIECE($GET(^PX(839.7,+PSOURCE,0)),U,1)
+80 SET PVDATA=$$GETVDATA^PXRHS03(+PXPLACEVST)
+81 SET ^TMP("PXS",$JOB,SKIN,IDT,DA,"P")=$PIECE(PVDATA,U,5)_U_$PIECE(PVDATA,U,6)_U_$PIECE(PVDATA,U,2)_U_$PIECE(PVDATA,U,4)_U_PSOURCE
End DoDot:4
+82 SET ^TMP("PXS",$JOB,SKIN,IDT,DA,0)=SKIN_U_SKDT_U_RESULTC_U_RESULT_U_READING_U_RDT_U_OPROV_U_EPROV
+83 SET ^TMP("PXS",$JOB,SKIN,IDT,DA,1)=HLOC_U_HLOCABB_U_$PIECE(VDATA,U,2)_U_$PIECE(VDATA,U,4)
+84 SET ^TMP("PXS",$JOB,SKIN,IDT,DA,"S")=SOURCE
+85 SET ^TMP("PXS",$JOB,SKIN,IDT,DA,"COM")=COMMENT
End DoDot:3
End DoDot:2
End DoDot:1
+86 QUIT
