PXVRPC8 ;ISP/LMT - PCE RPCs for Skin Tests ;Jan 18, 2023@14:49:16
;;1.0;PCE PATIENT CARE ENCOUNTER;**216,217,233**;Aug 12, 1996;Build 3
;
;
; Reference to ^DIA(9999999.28,"C") in ICR #2602
;
;
SKSHORT(PXRSLT,PXDATE,PXFLTR,PXOREXC,PXLOC) ;
;
; Returns list of skin tests
;
;Input:
; PXRSLT - Return value passed by reference (Required)
; PXDATE - Date (optional; defaults to TODAY)
; Used for determining skin test status
; PXFLTR - Filter (Optional; Defaults to "S:A")
; Possible values are:
; R:X - Return entry with IEN X.
; N:X - Return entry with #.01 field equal to X
; S:A - Return all active entries.
; S:I - Return all inactive entries.
; S:B - Return all entries (both active and inactive).
; PXOREXC - Should entries defined in ORWPCE EXCLUDE SKIN TESTS be excluded? (optional)
; Used when PXFLTR is set to S:x.
; PXLOC - Used when excluding entries listed in ORWPCE EXCLUDE SKIN TESTS. (Optional)
; This is the location used when getting the parameter value at the Location level.
;
;Returns:
; (0)=Count of elements returned (0 if nothing found)
; (n)=SK^IEN^NAME^PRINT NAME
; (n)=CS^Coding System^Code^Variable pointer^Short Description
;
N PXAUDIT,PXCNT,PXFLTRTYP,PXFLTRVAL,PXGETCSTAT,PXIEN,PXLST,PXNODE,PXSTAT
;
I '$G(PXDATE) S PXDATE=DT
I $P($G(PXFLTR),":",1)'?1(1"R",1"N",1"S") S PXFLTR="S:A"
S PXFLTRTYP=$P(PXFLTR,":",1)
S PXFLTRVAL=$P(PXFLTR,":",2)
S PXCNT=0
;
S PXAUDIT=0
I $$GET1^DID(9999999.28,.03,"","AUDIT")="YES, ALWAYS" S PXAUDIT=1
S PXGETCSTAT=$$GETCSTAT(PXDATE,PXAUDIT)
;
I PXFLTRTYP="R" D
. S PXIEN=PXFLTRVAL
. I 'PXIEN Q
. I '$D(^AUTTSK(PXIEN,0)) Q
. D ADDENTRY(.PXRSLT,.PXCNT,.PXIEN,.PXDATE)
;
I PXFLTRTYP="N" D
. I PXFLTRVAL="" Q
. S PXIEN=$O(^AUTTSK("B",PXFLTRVAL,0))
. I 'PXIEN Q
. D ADDENTRY(.PXRSLT,.PXCNT,.PXIEN,.PXDATE)
;
I PXFLTRTYP="S" D
. I PXFLTRVAL'?1(1"A",1"I",1"B") S PXFLTRVAL="A"
. S PXIEN=0
. F S PXIEN=$O(^AUTTSK(PXIEN)) Q:'PXIEN D
. . I $G(PXOREXC),$$EXCLUDED^PXVRPC4(.PXLST,PXIEN,2,$G(PXLOC)) Q
. . S PXSTAT=$$GETSTAT(PXIEN,PXDATE,PXGETCSTAT,PXAUDIT)
. . I PXFLTRVAL="A",'PXSTAT Q
. . I PXFLTRVAL="I",PXSTAT Q
. . D ADDENTRY(.PXRSLT,.PXCNT,.PXIEN,.PXDATE)
;
S PXRSLT(0)=PXCNT
;
Q
;
ADDENTRY(PXRSLT,PXCNT,PXIEN,PXDATE) ;
;
N PXNODE
;
S PXCNT=$G(PXCNT)+1
S PXNODE=$G(^AUTTSK(PXIEN,0))
S PXRSLT(PXCNT)="SK^"_PXIEN_U_$P(PXNODE,U,1)_U_$P($G(^AUTTSK(PXIEN,12)),U,1)
D GETCS(.PXRSLT,.PXCNT,.PXIEN,.PXDATE)
;
Q
;
GETSTAT(PXSK,PXDATE,PXCURR,PXAUDIT) ;
;
N PXLASTEDIT,PXSTAT
;
I PXCURR Q '$P($G(^AUTTSK(PXSK,0)),U,3)
;
I PXAUDIT D
. S PXLASTEDIT=$P($$LAST^DIAUTL(9999999.28,PXSK,".03"),U,1)
. I PXDATE>PXLASTEDIT S PXCURR=1
I PXCURR Q '$P($G(^AUTTSK(PXSK,0)),U,3)
;
S PXSTAT=$P($$GETSTAT^XTID(9999999.28,"",PXSK_",",$G(PXDATE)),U,1)
I PXSTAT="" S PXSTAT=1
Q PXSTAT
;
GETCSTAT(PXDATE,PXAUDIT) ;
;
; Should we get current status of SK entries or should we call GETSTAT^XTID
; to get status as of a specific date?
; Since GETSTAT^XTID is slow, we try to avoid it when possible.
;
; Returns: 0 - Call GETSTAT^XTID
; 1 - Get current status
;
N PXLASTEDITDT,PXRSLT
;
S PXRSLT=0
;
I '$G(PXDATE) D Q PXRSLT
. S PXRSLT=1
;
I $P(PXDATE,".",1)=DT D Q PXRSLT
. S PXRSLT=1
;
; If Inactive Flag is being audited (which should be the case)
; then get current status, if file has not been updated since PXDATE
I PXAUDIT D
. S PXLASTEDITDT=$O(^DIA(9999999.28,"C",""),-1) ;ICR #2602
. I PXDATE>PXLASTEDITDT S PXRSLT=1
;
Q PXRSLT
;
SKSITES(PXRSLT) ;
;
; Returns a list of default sites for skin tests.
;
;Input:
; PXRSLT - Return value passed by reference (Required)
;
;Returns:
; (0)=Count of elements returned (0 if nothing found)
; (n)=IEN^NAME
; (n)=IEN^NAME
;
N PXCNT,PXIEN,PXSITE,PXSITES
;
; Try first to get list from parameter
D GETLST^XPAR(.PXRSLT,"ALL","PXV SKIN TEST ADMIN SITES","N")
I $G(PXRSLT)>0 D Q
. S PXRSLT(0)=PXRSLT
;
; if parameter is not set, use these sites
S PXSITES("RA")=""
S PXSITES("LA")=""
S PXSITES("RLFA")=""
S PXSITES("LLFA")=""
;
S PXCNT=0
;
S PXSITE=""
F S PXSITE=$O(PXSITES(PXSITE)) Q:PXSITE="" D
. S PXIEN=$O(^PXV(920.3,"B",PXSITE,0))
. I 'PXIEN Q
. S PXCNT=PXCNT+1
. S PXRSLT(PXCNT)=PXIEN_U_$P($G(^PXV(920.3,PXIEN,0)),U,1)
;
S PXRSLT(0)=PXCNT
;
Q
;
SKLIST(PXRSLT,DFN,PXSK,PXDATE,PXMAX) ;
;
; Returns a list of V Skin Test entries that have been placed within the last x days.
; The number of days to look back is defined in the PXV SK DAYS BACK parameter.
;
;Input:
; PXRSLT - Return value passed by reference (Required)
; DFN - Patient's DFN (Required)
; Only V Skin Test entries for this patient will be returned.
; PXSK - Skin Test IEN (Optional)
; If passed in, only V Skin Test entries for this Skin Test will be returned.
; If not passed in, all V Skin Tests entries will be returned.
; PXDATE - Date (Optional; defaults to Today)
; The system will search back x number of days from this date.
; PXMAX - The max number of entries to return per skin test (Optional)
;
;Returns:
; (0)=Count of elements returned (0 if nothing found)
; (1)=DATERANGE ^ Start Date ^ Stop Date
; (n)=PLACEMENT ^ V Skin Test IEN ^ Skin Test IEN ^ Skin Test Name ^ Date/Time of Placement
;
N PXARR,PXCNT,PXDAYSBACK,PXEVENTDT,PXI,PXNUM,PXSKIEN,PXSTART,PXSTOP,PXVSK0,PXVISIT,PXVSK
N PXPPDIEN,PXSKNM,PXSORT1
;
S PXCNT=0
;
I '$G(DFN) D Q
. S PXRSLT(0)=PXCNT
I '$G(PXDATE) S PXDATE=DT
S PXSK=$G(PXSK)
;
S PXPPDIEN=$O(^AUTTSK("B","PPD TUBERCULIN",0))
I 'PXPPDIEN S PXPPDIEN=$O(^AUTTSK("AVUID",5198083,0))
;
S PXSTOP=$P(PXDATE,".",1)
S PXDAYSBACK=$$GET^XPAR("ALL","PXV SK DAYS BACK")
I PXDAYSBACK<1 S PXDAYSBACK=7
S PXSTART=$P($$FMADD^XLFDT(PXDATE,-PXDAYSBACK),".",1)
;
S PXVSK=0
F S PXVSK=$O(^AUPNVSK("C",DFN,PXVSK)) Q:'PXVSK D
. S PXVSK0=$G(^AUPNVSK(PXVSK,0))
. S PXSKIEN=$P(PXVSK0,U,1)
. I 'PXSKIEN Q
. I PXSK,PXSK'=PXSKIEN Q
. ; if both Reading and Results are populated, quit
. I $P(PXVSK0,U,4)'="",$P(PXVSK0,U,5)'="" Q
. I $D(^AUPNVSK("APT",PXVSK)) Q
. S PXEVENTDT=$P($G(^AUPNVSK(PXVSK,12)),U,1)
. I 'PXEVENTDT D
. . S PXVISIT=$P(PXVSK0,U,3)
. . S PXEVENTDT=$P($G(^AUPNVSIT(+PXVISIT,0)),U,1)
. I 'PXEVENTDT Q
. I PXEVENTDT<PXSTART Q
. I PXEVENTDT>(PXSTOP_".24") Q
. S PXSKNM=$P($G(^AUTTSK(PXSKIEN,0)),U,1)
. S PXSORT1=PXSKNM
. ; Sort PPD first
. I PXSKIEN=PXPPDIEN S PXSORT1="0"_PXSORT1
. S PXARR(PXSORT1,PXEVENTDT)="PLACEMENT^"_PXVSK_U_PXSKIEN_U_PXSKNM_U_PXEVENTDT
;
S PXCNT=PXCNT+1
S PXRSLT(PXCNT)="DATERANGE"_U_PXSTART_U_PXSTOP
;
S PXSORT1=""
F S PXSORT1=$O(PXARR(PXSORT1)) Q:PXSORT1="" D
. S PXNUM=0
. S PXEVENTDT=""
. F S PXEVENTDT=$O(PXARR(PXSORT1,PXEVENTDT),-1) Q:'PXEVENTDT D
. . S PXNUM=PXNUM+1
. . I $G(PXMAX),PXNUM>PXMAX Q
. . S PXCNT=PXCNT+1
. . S PXRSLT(PXCNT)=$G(PXARR(PXSORT1,PXEVENTDT))
;
S PXRSLT(0)=PXCNT
;
Q
;
GETCS(PXRSLT,PXCNT,PXSK,PXDATE) ;
;
N PXCODE,PXCODESYS,PXLEX,PXLEXADATE,PXLEXARY,PXLEXIDATE,PXLEXNODE,PXX,PXY
;
S PXDATE=$P(PXDATE,".",1)
;
S PXX=0
F S PXX=$O(^AUTTSK(PXSK,3,PXX)) Q:'PXX D
. S PXCODESYS=$G(^AUTTSK(PXSK,3,PXX,0))
. I PXCODESYS="" Q
. S PXY=0 F S PXY=$O(^AUTTSK(PXSK,3,PXX,1,PXY)) Q:'PXY D
. . S PXCODE=$G(^AUTTSK(PXSK,3,PXX,1,PXY,0))
. . I PXCODE="" Q
. . ;
. . K PXLEXARY
. . S PXLEX=$$PERIOD^LEXU(PXCODE,PXCODESYS,.PXLEXARY)
. . ;
. . I $P(PXLEX,U,1)=-1 D Q
. . . I PXCODESYS?1(1"CPT",1"10D") Q
. . . S PXCNT=PXCNT+1
. . . S PXRSLT(PXCNT)="CS^"_PXCODESYS_U_PXCODE
. . ;
. . S PXLEXADATE=$O(PXLEXARY((PXDATE+.00001)),-1)
. . I PXLEXADATE="" Q
. . S PXLEXNODE=$G(PXLEXARY(PXLEXADATE))
. . S PXLEXIDATE=$P(PXLEXNODE,U,1)
. . I PXLEXIDATE,PXDATE>PXLEXIDATE Q
. . S PXCNT=PXCNT+1
. . S PXRSLT(PXCNT)="CS^"_PXCODESYS_U_PXCODE_U_$P(PXLEXNODE,U,3)_U_$P(PXLEXNODE,U,4)
;
Q
;
GETSKCD(PXRSLT,PXSK,PXDATE) ;
;
N PXCNT,PXCODE,PXCODES,PXCODESYS,PXI,PXLEX,PXLEXADATE,PXLEXARY,PXLEXIDATE,PXLEXNODE
I '$G(PXDATE) S PXDATE=$$NOW^XLFDT()
S PXCNT=0
D GETCS(.PXCODES,.PXCNT,PXSK,PXDATE)
;
F PXI=1:1:PXCNT D
. S PXCODESYS=$P($G(PXCODES(PXI)),U,2)
. S PXRSLT(PXI)=$P($G(PXCODES(PXI)),U,2,5)_U_$S(PXCODESYS="CPT":"P",1:"B")
;
S PXCODE=$$GET^XPAR("ALL","PXV SKIN TEST READING CPT",1,"I")
I PXCODE="" Q
S PXCODESYS="CPT"
K PXLEXARY
S PXLEX=$$PERIOD^LEXU(PXCODE,PXCODESYS,.PXLEXARY)
I $P(PXLEX,U,1)=-1 Q
S PXLEXADATE=$O(PXLEXARY((PXDATE+.00001)),-1)
I PXLEXADATE="" Q
S PXLEXNODE=$G(PXLEXARY(PXLEXADATE))
S PXLEXIDATE=$P(PXLEXNODE,U,1)
I PXLEXIDATE,PXDATE>PXLEXIDATE Q
S PXCNT=PXCNT+1
S PXRSLT(PXCNT)=PXCODESYS_U_PXCODE_U_$P(PXLEXNODE,U,3)_U_$P(PXLEXNODE,U,4)_U_"R"
;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXVRPC8 9078 printed Nov 22, 2024@17:42:06 Page 2
PXVRPC8 ;ISP/LMT - PCE RPCs for Skin Tests ;Jan 18, 2023@14:49:16
+1 ;;1.0;PCE PATIENT CARE ENCOUNTER;**216,217,233**;Aug 12, 1996;Build 3
+2 ;
+3 ;
+4 ; Reference to ^DIA(9999999.28,"C") in ICR #2602
+5 ;
+6 ;
SKSHORT(PXRSLT,PXDATE,PXFLTR,PXOREXC,PXLOC) ;
+1 ;
+2 ; Returns list of skin tests
+3 ;
+4 ;Input:
+5 ; PXRSLT - Return value passed by reference (Required)
+6 ; PXDATE - Date (optional; defaults to TODAY)
+7 ; Used for determining skin test status
+8 ; PXFLTR - Filter (Optional; Defaults to "S:A")
+9 ; Possible values are:
+10 ; R:X - Return entry with IEN X.
+11 ; N:X - Return entry with #.01 field equal to X
+12 ; S:A - Return all active entries.
+13 ; S:I - Return all inactive entries.
+14 ; S:B - Return all entries (both active and inactive).
+15 ; PXOREXC - Should entries defined in ORWPCE EXCLUDE SKIN TESTS be excluded? (optional)
+16 ; Used when PXFLTR is set to S:x.
+17 ; PXLOC - Used when excluding entries listed in ORWPCE EXCLUDE SKIN TESTS. (Optional)
+18 ; This is the location used when getting the parameter value at the Location level.
+19 ;
+20 ;Returns:
+21 ; (0)=Count of elements returned (0 if nothing found)
+22 ; (n)=SK^IEN^NAME^PRINT NAME
+23 ; (n)=CS^Coding System^Code^Variable pointer^Short Description
+24 ;
+25 NEW PXAUDIT,PXCNT,PXFLTRTYP,PXFLTRVAL,PXGETCSTAT,PXIEN,PXLST,PXNODE,PXSTAT
+26 ;
+27 IF '$GET(PXDATE)
SET PXDATE=DT
+28 IF $PIECE($GET(PXFLTR),":",1)'?1(1"R",1"N",1"S")
SET PXFLTR="S:A"
+29 SET PXFLTRTYP=$PIECE(PXFLTR,":",1)
+30 SET PXFLTRVAL=$PIECE(PXFLTR,":",2)
+31 SET PXCNT=0
+32 ;
+33 SET PXAUDIT=0
+34 IF $$GET1^DID(9999999.28,.03,"","AUDIT")="YES, ALWAYS"
SET PXAUDIT=1
+35 SET PXGETCSTAT=$$GETCSTAT(PXDATE,PXAUDIT)
+36 ;
+37 IF PXFLTRTYP="R"
Begin DoDot:1
+38 SET PXIEN=PXFLTRVAL
+39 IF 'PXIEN
QUIT
+40 IF '$DATA(^AUTTSK(PXIEN,0))
QUIT
+41 DO ADDENTRY(.PXRSLT,.PXCNT,.PXIEN,.PXDATE)
End DoDot:1
+42 ;
+43 IF PXFLTRTYP="N"
Begin DoDot:1
+44 IF PXFLTRVAL=""
QUIT
+45 SET PXIEN=$ORDER(^AUTTSK("B",PXFLTRVAL,0))
+46 IF 'PXIEN
QUIT
+47 DO ADDENTRY(.PXRSLT,.PXCNT,.PXIEN,.PXDATE)
End DoDot:1
+48 ;
+49 IF PXFLTRTYP="S"
Begin DoDot:1
+50 IF PXFLTRVAL'?1(1"A",1"I",1"B")
SET PXFLTRVAL="A"
+51 SET PXIEN=0
+52 FOR
SET PXIEN=$ORDER(^AUTTSK(PXIEN))
if 'PXIEN
QUIT
Begin DoDot:2
+53 IF $GET(PXOREXC)
IF $$EXCLUDED^PXVRPC4(.PXLST,PXIEN,2,$GET(PXLOC))
QUIT
+54 SET PXSTAT=$$GETSTAT(PXIEN,PXDATE,PXGETCSTAT,PXAUDIT)
+55 IF PXFLTRVAL="A"
IF 'PXSTAT
QUIT
+56 IF PXFLTRVAL="I"
IF PXSTAT
QUIT
+57 DO ADDENTRY(.PXRSLT,.PXCNT,.PXIEN,.PXDATE)
End DoDot:2
End DoDot:1
+58 ;
+59 SET PXRSLT(0)=PXCNT
+60 ;
+61 QUIT
+62 ;
ADDENTRY(PXRSLT,PXCNT,PXIEN,PXDATE) ;
+1 ;
+2 NEW PXNODE
+3 ;
+4 SET PXCNT=$GET(PXCNT)+1
+5 SET PXNODE=$GET(^AUTTSK(PXIEN,0))
+6 SET PXRSLT(PXCNT)="SK^"_PXIEN_U_$PIECE(PXNODE,U,1)_U_$PIECE($GET(^AUTTSK(PXIEN,12)),U,1)
+7 DO GETCS(.PXRSLT,.PXCNT,.PXIEN,.PXDATE)
+8 ;
+9 QUIT
+10 ;
GETSTAT(PXSK,PXDATE,PXCURR,PXAUDIT) ;
+1 ;
+2 NEW PXLASTEDIT,PXSTAT
+3 ;
+4 IF PXCURR
QUIT '$PIECE($GET(^AUTTSK(PXSK,0)),U,3)
+5 ;
+6 IF PXAUDIT
Begin DoDot:1
+7 SET PXLASTEDIT=$PIECE($$LAST^DIAUTL(9999999.28,PXSK,".03"),U,1)
+8 IF PXDATE>PXLASTEDIT
SET PXCURR=1
End DoDot:1
+9 IF PXCURR
QUIT '$PIECE($GET(^AUTTSK(PXSK,0)),U,3)
+10 ;
+11 SET PXSTAT=$PIECE($$GETSTAT^XTID(9999999.28,"",PXSK_",",$GET(PXDATE)),U,1)
+12 IF PXSTAT=""
SET PXSTAT=1
+13 QUIT PXSTAT
+14 ;
GETCSTAT(PXDATE,PXAUDIT) ;
+1 ;
+2 ; Should we get current status of SK entries or should we call GETSTAT^XTID
+3 ; to get status as of a specific date?
+4 ; Since GETSTAT^XTID is slow, we try to avoid it when possible.
+5 ;
+6 ; Returns: 0 - Call GETSTAT^XTID
+7 ; 1 - Get current status
+8 ;
+9 NEW PXLASTEDITDT,PXRSLT
+10 ;
+11 SET PXRSLT=0
+12 ;
+13 IF '$GET(PXDATE)
Begin DoDot:1
+14 SET PXRSLT=1
End DoDot:1
QUIT PXRSLT
+15 ;
+16 IF $PIECE(PXDATE,".",1)=DT
Begin DoDot:1
+17 SET PXRSLT=1
End DoDot:1
QUIT PXRSLT
+18 ;
+19 ; If Inactive Flag is being audited (which should be the case)
+20 ; then get current status, if file has not been updated since PXDATE
+21 IF PXAUDIT
Begin DoDot:1
+22 ;ICR #2602
SET PXLASTEDITDT=$ORDER(^DIA(9999999.28,"C",""),-1)
+23 IF PXDATE>PXLASTEDITDT
SET PXRSLT=1
End DoDot:1
+24 ;
+25 QUIT PXRSLT
+26 ;
SKSITES(PXRSLT) ;
+1 ;
+2 ; Returns a list of default sites for skin tests.
+3 ;
+4 ;Input:
+5 ; PXRSLT - Return value passed by reference (Required)
+6 ;
+7 ;Returns:
+8 ; (0)=Count of elements returned (0 if nothing found)
+9 ; (n)=IEN^NAME
+10 ; (n)=IEN^NAME
+11 ;
+12 NEW PXCNT,PXIEN,PXSITE,PXSITES
+13 ;
+14 ; Try first to get list from parameter
+15 DO GETLST^XPAR(.PXRSLT,"ALL","PXV SKIN TEST ADMIN SITES","N")
+16 IF $GET(PXRSLT)>0
Begin DoDot:1
+17 SET PXRSLT(0)=PXRSLT
End DoDot:1
QUIT
+18 ;
+19 ; if parameter is not set, use these sites
+20 SET PXSITES("RA")=""
+21 SET PXSITES("LA")=""
+22 SET PXSITES("RLFA")=""
+23 SET PXSITES("LLFA")=""
+24 ;
+25 SET PXCNT=0
+26 ;
+27 SET PXSITE=""
+28 FOR
SET PXSITE=$ORDER(PXSITES(PXSITE))
if PXSITE=""
QUIT
Begin DoDot:1
+29 SET PXIEN=$ORDER(^PXV(920.3,"B",PXSITE,0))
+30 IF 'PXIEN
QUIT
+31 SET PXCNT=PXCNT+1
+32 SET PXRSLT(PXCNT)=PXIEN_U_$PIECE($GET(^PXV(920.3,PXIEN,0)),U,1)
End DoDot:1
+33 ;
+34 SET PXRSLT(0)=PXCNT
+35 ;
+36 QUIT
+37 ;
SKLIST(PXRSLT,DFN,PXSK,PXDATE,PXMAX) ;
+1 ;
+2 ; Returns a list of V Skin Test entries that have been placed within the last x days.
+3 ; The number of days to look back is defined in the PXV SK DAYS BACK parameter.
+4 ;
+5 ;Input:
+6 ; PXRSLT - Return value passed by reference (Required)
+7 ; DFN - Patient's DFN (Required)
+8 ; Only V Skin Test entries for this patient will be returned.
+9 ; PXSK - Skin Test IEN (Optional)
+10 ; If passed in, only V Skin Test entries for this Skin Test will be returned.
+11 ; If not passed in, all V Skin Tests entries will be returned.
+12 ; PXDATE - Date (Optional; defaults to Today)
+13 ; The system will search back x number of days from this date.
+14 ; PXMAX - The max number of entries to return per skin test (Optional)
+15 ;
+16 ;Returns:
+17 ; (0)=Count of elements returned (0 if nothing found)
+18 ; (1)=DATERANGE ^ Start Date ^ Stop Date
+19 ; (n)=PLACEMENT ^ V Skin Test IEN ^ Skin Test IEN ^ Skin Test Name ^ Date/Time of Placement
+20 ;
+21 NEW PXARR,PXCNT,PXDAYSBACK,PXEVENTDT,PXI,PXNUM,PXSKIEN,PXSTART,PXSTOP,PXVSK0,PXVISIT,PXVSK
+22 NEW PXPPDIEN,PXSKNM,PXSORT1
+23 ;
+24 SET PXCNT=0
+25 ;
+26 IF '$GET(DFN)
Begin DoDot:1
+27 SET PXRSLT(0)=PXCNT
End DoDot:1
QUIT
+28 IF '$GET(PXDATE)
SET PXDATE=DT
+29 SET PXSK=$GET(PXSK)
+30 ;
+31 SET PXPPDIEN=$ORDER(^AUTTSK("B","PPD TUBERCULIN",0))
+32 IF 'PXPPDIEN
SET PXPPDIEN=$ORDER(^AUTTSK("AVUID",5198083,0))
+33 ;
+34 SET PXSTOP=$PIECE(PXDATE,".",1)
+35 SET PXDAYSBACK=$$GET^XPAR("ALL","PXV SK DAYS BACK")
+36 IF PXDAYSBACK<1
SET PXDAYSBACK=7
+37 SET PXSTART=$PIECE($$FMADD^XLFDT(PXDATE,-PXDAYSBACK),".",1)
+38 ;
+39 SET PXVSK=0
+40 FOR
SET PXVSK=$ORDER(^AUPNVSK("C",DFN,PXVSK))
if 'PXVSK
QUIT
Begin DoDot:1
+41 SET PXVSK0=$GET(^AUPNVSK(PXVSK,0))
+42 SET PXSKIEN=$PIECE(PXVSK0,U,1)
+43 IF 'PXSKIEN
QUIT
+44 IF PXSK
IF PXSK'=PXSKIEN
QUIT
+45 ; if both Reading and Results are populated, quit
+46 IF $PIECE(PXVSK0,U,4)'=""
IF $PIECE(PXVSK0,U,5)'=""
QUIT
+47 IF $DATA(^AUPNVSK("APT",PXVSK))
QUIT
+48 SET PXEVENTDT=$PIECE($GET(^AUPNVSK(PXVSK,12)),U,1)
+49 IF 'PXEVENTDT
Begin DoDot:2
+50 SET PXVISIT=$PIECE(PXVSK0,U,3)
+51 SET PXEVENTDT=$PIECE($GET(^AUPNVSIT(+PXVISIT,0)),U,1)
End DoDot:2
+52 IF 'PXEVENTDT
QUIT
+53 IF PXEVENTDT<PXSTART
QUIT
+54 IF PXEVENTDT>(PXSTOP_".24")
QUIT
+55 SET PXSKNM=$PIECE($GET(^AUTTSK(PXSKIEN,0)),U,1)
+56 SET PXSORT1=PXSKNM
+57 ; Sort PPD first
+58 IF PXSKIEN=PXPPDIEN
SET PXSORT1="0"_PXSORT1
+59 SET PXARR(PXSORT1,PXEVENTDT)="PLACEMENT^"_PXVSK_U_PXSKIEN_U_PXSKNM_U_PXEVENTDT
End DoDot:1
+60 ;
+61 SET PXCNT=PXCNT+1
+62 SET PXRSLT(PXCNT)="DATERANGE"_U_PXSTART_U_PXSTOP
+63 ;
+64 SET PXSORT1=""
+65 FOR
SET PXSORT1=$ORDER(PXARR(PXSORT1))
if PXSORT1=""
QUIT
Begin DoDot:1
+66 SET PXNUM=0
+67 SET PXEVENTDT=""
+68 FOR
SET PXEVENTDT=$ORDER(PXARR(PXSORT1,PXEVENTDT),-1)
if 'PXEVENTDT
QUIT
Begin DoDot:2
+69 SET PXNUM=PXNUM+1
+70 IF $GET(PXMAX)
IF PXNUM>PXMAX
QUIT
+71 SET PXCNT=PXCNT+1
+72 SET PXRSLT(PXCNT)=$GET(PXARR(PXSORT1,PXEVENTDT))
End DoDot:2
End DoDot:1
+73 ;
+74 SET PXRSLT(0)=PXCNT
+75 ;
+76 QUIT
+77 ;
GETCS(PXRSLT,PXCNT,PXSK,PXDATE) ;
+1 ;
+2 NEW PXCODE,PXCODESYS,PXLEX,PXLEXADATE,PXLEXARY,PXLEXIDATE,PXLEXNODE,PXX,PXY
+3 ;
+4 SET PXDATE=$PIECE(PXDATE,".",1)
+5 ;
+6 SET PXX=0
+7 FOR
SET PXX=$ORDER(^AUTTSK(PXSK,3,PXX))
if 'PXX
QUIT
Begin DoDot:1
+8 SET PXCODESYS=$GET(^AUTTSK(PXSK,3,PXX,0))
+9 IF PXCODESYS=""
QUIT
+10 SET PXY=0
FOR
SET PXY=$ORDER(^AUTTSK(PXSK,3,PXX,1,PXY))
if 'PXY
QUIT
Begin DoDot:2
+11 SET PXCODE=$GET(^AUTTSK(PXSK,3,PXX,1,PXY,0))
+12 IF PXCODE=""
QUIT
+13 ;
+14 KILL PXLEXARY
+15 SET PXLEX=$$PERIOD^LEXU(PXCODE,PXCODESYS,.PXLEXARY)
+16 ;
+17 IF $PIECE(PXLEX,U,1)=-1
Begin DoDot:3
+18 IF PXCODESYS?1(1"CPT",1"10D")
QUIT
+19 SET PXCNT=PXCNT+1
+20 SET PXRSLT(PXCNT)="CS^"_PXCODESYS_U_PXCODE
End DoDot:3
QUIT
+21 ;
+22 SET PXLEXADATE=$ORDER(PXLEXARY((PXDATE+.00001)),-1)
+23 IF PXLEXADATE=""
QUIT
+24 SET PXLEXNODE=$GET(PXLEXARY(PXLEXADATE))
+25 SET PXLEXIDATE=$PIECE(PXLEXNODE,U,1)
+26 IF PXLEXIDATE
IF PXDATE>PXLEXIDATE
QUIT
+27 SET PXCNT=PXCNT+1
+28 SET PXRSLT(PXCNT)="CS^"_PXCODESYS_U_PXCODE_U_$PIECE(PXLEXNODE,U,3)_U_$PIECE(PXLEXNODE,U,4)
End DoDot:2
End DoDot:1
+29 ;
+30 QUIT
+31 ;
GETSKCD(PXRSLT,PXSK,PXDATE) ;
+1 ;
+2 NEW PXCNT,PXCODE,PXCODES,PXCODESYS,PXI,PXLEX,PXLEXADATE,PXLEXARY,PXLEXIDATE,PXLEXNODE
+3 IF '$GET(PXDATE)
SET PXDATE=$$NOW^XLFDT()
+4 SET PXCNT=0
+5 DO GETCS(.PXCODES,.PXCNT,PXSK,PXDATE)
+6 ;
+7 FOR PXI=1:1:PXCNT
Begin DoDot:1
+8 SET PXCODESYS=$PIECE($GET(PXCODES(PXI)),U,2)
+9 SET PXRSLT(PXI)=$PIECE($GET(PXCODES(PXI)),U,2,5)_U_$SELECT(PXCODESYS="CPT":"P",1:"B")
End DoDot:1
+10 ;
+11 SET PXCODE=$$GET^XPAR("ALL","PXV SKIN TEST READING CPT",1,"I")
+12 IF PXCODE=""
QUIT
+13 SET PXCODESYS="CPT"
+14 KILL PXLEXARY
+15 SET PXLEX=$$PERIOD^LEXU(PXCODE,PXCODESYS,.PXLEXARY)
+16 IF $PIECE(PXLEX,U,1)=-1
QUIT
+17 SET PXLEXADATE=$ORDER(PXLEXARY((PXDATE+.00001)),-1)
+18 IF PXLEXADATE=""
QUIT
+19 SET PXLEXNODE=$GET(PXLEXARY(PXLEXADATE))
+20 SET PXLEXIDATE=$PIECE(PXLEXNODE,U,1)
+21 IF PXLEXIDATE
IF PXDATE>PXLEXIDATE
QUIT
+22 SET PXCNT=PXCNT+1
+23 SET PXRSLT(PXCNT)=PXCODESYS_U_PXCODE_U_$PIECE(PXLEXNODE,U,3)_U_$PIECE(PXLEXNODE,U,4)_U_"R"
+24 ;
+25 QUIT
