PXVUTL ;BIR/ADM - SKIN TEST UTILITY ROUTINE ;Dec 20, 2022@13:11:53
;;1.0;PCE PATIENT CARE ENCOUNTER;**210,217,233**;Aug 12, 1996;Build 3
;
; Reference to OVERDL^ORWU in ICR #7388
;
HR ; called by AH new style x-ref in V SKIN TEST file
; set number of hours between placement and reading of test
N PXVPLACE,PXVREAD,PXVX,X1,X2,X3
S X1=$P($G(^AUPNVSK(DA,0)),"^",6) ; DATE READ
S PXVREAD=$O(^AUPNVSK("APT",DA,0))
I PXVREAD S X1=$P($G(^AUPNVSK(PXVREAD,0)),"^",6)
S X2=$P($G(^AUPNVSK(DA,12)),"^") ; EVENT DATE AND TIME
I X2="" S X2=$P($G(^AUPNVSIT(+$P($G(^AUPNVSK(DA,0)),"^",3),0)),U,1)
S PXVPLACE=$P($G(^AUPNVSK(DA,12)),"^",8) ; PLACEMENT SKIN TEST
I PXVPLACE D
. S X2=$P($G(^AUPNVSK(PXVPLACE,12)),"^")
. I X2="" S X2=$P($G(^AUPNVSIT(+$P($G(^AUPNVSK(PXVPLACE,0)),"^",3),0)),U,1)
I X1=""!(X2="") Q
S X3=2 ; return difference in seconds
S PXVX=""
I $G(X1),$L(X1)>7,$G(X2),$L(X2)>7,$G(X2)'>$G(X1) S PXVX=$$FMDIFF^XLFDT(X1,X2,X3)\3600
I PXVREAD S $P(^AUPNVSK(PXVREAD,12),"^",14)=PXVX Q
S $P(^AUPNVSK(DA,12),"^",14)=PXVX
Q
CODSYS ; set logic for AC x-ref on SKIN TEST field to populate CODE SYSTEM multiple
N PXVCODE,PXVSK,PXVTN
S PXVCODE=$$CODX(X,DA)
Q
CODX(PXVSK,PXVTN) ; populate CODE SYSTEM multiple
N DA,DD,DO,DIC,DR,PXVC,PXVCOD,PXVIEN,PXVM,PXVSYS,X S PXVCODE=0
S PXVM=0 F S PXVM=$O(^AUTTSK(PXVSK,3,PXVM)) Q:'PXVM D
.S PXVSYS=$P(^AUTTSK(PXVSK,3,PXVM,0),"^") Q:PXVSYS="" S PXVCODE=1
.K DA,DD,DO,DIC S DA(1)=PXVTN,DIC="^AUPNVSK(PXVTN,3,",DIC(0)="L",X=PXVSYS D FILE^DICN K DA,DD,DIC,DO,DR S PXVIEN=+Y I PXVIEN'>0 S PXVCODE=0 Q
.S PXVC=0 F S PXVC=$O(^AUTTSK(PXVSK,3,PXVM,1,PXVC)) Q:'PXVC D
..S PXVCOD=$P(^AUTTSK(PXVSK,3,PXVM,1,PXVC,0),"^")
..S PXVY(9000010.1231,"+1,"_PXVIEN_","_PXVTN_",",.01)=PXVCOD D UPDATE^DIE("","PXVY") K PXVY
Q PXVCODE
KCODSYS ; kill logic for AC x-ref
N PXVCODE,PXVTN
S PXVCODE=$$KCODX(DA)
Q
KCODX(PXVTN) ;
N DA,DD,DO,DIC,DR,PXVJ S PXVCODE=0
S PXVJ=0 F S PXVJ=$O(^AUPNVSK(PXVTN,3,PXVJ)) Q:'PXVJ D S PXVCODE=1
.S PXVY(9000010.123,PXVJ_","_PXVTN_",",.01)="@" D FILE^DIE("","PXVY")
Q PXVCODE
;
TIME() ; determine if future time
N PXMAX,PXOVERDL,PXCHECKDT
S PXCHECKDT=X
;
D
. N X,Y
. S PXOVERDL=0
. D OVERDL^ORWU(.PXOVERDL) ; get value of ORPARAM OVER DATELINE. ICR #7388
. S PXMAX=$$FMADD^XLFDT($$NOW^XLFDT,0,0,1)
. I PXOVERDL S PXMAX=$$FMADD^XLFDT($$DT^XLFDT,2)
;
Q $S(PXCHECKDT>PXMAX:1,1:0)
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXVUTL 2430 printed Dec 13, 2024@02:32:12 Page 2
PXVUTL ;BIR/ADM - SKIN TEST UTILITY ROUTINE ;Dec 20, 2022@13:11:53
+1 ;;1.0;PCE PATIENT CARE ENCOUNTER;**210,217,233**;Aug 12, 1996;Build 3
+2 ;
+3 ; Reference to OVERDL^ORWU in ICR #7388
+4 ;
HR ; called by AH new style x-ref in V SKIN TEST file
+1 ; set number of hours between placement and reading of test
+2 NEW PXVPLACE,PXVREAD,PXVX,X1,X2,X3
+3 ; DATE READ
SET X1=$PIECE($GET(^AUPNVSK(DA,0)),"^",6)
+4 SET PXVREAD=$ORDER(^AUPNVSK("APT",DA,0))
+5 IF PXVREAD
SET X1=$PIECE($GET(^AUPNVSK(PXVREAD,0)),"^",6)
+6 ; EVENT DATE AND TIME
SET X2=$PIECE($GET(^AUPNVSK(DA,12)),"^")
+7 IF X2=""
SET X2=$PIECE($GET(^AUPNVSIT(+$PIECE($GET(^AUPNVSK(DA,0)),"^",3),0)),U,1)
+8 ; PLACEMENT SKIN TEST
SET PXVPLACE=$PIECE($GET(^AUPNVSK(DA,12)),"^",8)
+9 IF PXVPLACE
Begin DoDot:1
+10 SET X2=$PIECE($GET(^AUPNVSK(PXVPLACE,12)),"^")
+11 IF X2=""
SET X2=$PIECE($GET(^AUPNVSIT(+$PIECE($GET(^AUPNVSK(PXVPLACE,0)),"^",3),0)),U,1)
End DoDot:1
+12 IF X1=""!(X2="")
QUIT
+13 ; return difference in seconds
SET X3=2
+14 SET PXVX=""
+15 IF $GET(X1)
IF $LENGTH(X1)>7
IF $GET(X2)
IF $LENGTH(X2)>7
IF $GET(X2)'>$GET(X1)
SET PXVX=$$FMDIFF^XLFDT(X1,X2,X3)\3600
+16 IF PXVREAD
SET $PIECE(^AUPNVSK(PXVREAD,12),"^",14)=PXVX
QUIT
+17 SET $PIECE(^AUPNVSK(DA,12),"^",14)=PXVX
+18 QUIT
CODSYS ; set logic for AC x-ref on SKIN TEST field to populate CODE SYSTEM multiple
+1 NEW PXVCODE,PXVSK,PXVTN
+2 SET PXVCODE=$$CODX(X,DA)
+3 QUIT
CODX(PXVSK,PXVTN) ; populate CODE SYSTEM multiple
+1 NEW DA,DD,DO,DIC,DR,PXVC,PXVCOD,PXVIEN,PXVM,PXVSYS,X
SET PXVCODE=0
+2 SET PXVM=0
FOR
SET PXVM=$ORDER(^AUTTSK(PXVSK,3,PXVM))
if 'PXVM
QUIT
Begin DoDot:1
+3 SET PXVSYS=$PIECE(^AUTTSK(PXVSK,3,PXVM,0),"^")
if PXVSYS=""
QUIT
SET PXVCODE=1
+4 KILL DA,DD,DO,DIC
SET DA(1)=PXVTN
SET DIC="^AUPNVSK(PXVTN,3,"
SET DIC(0)="L"
SET X=PXVSYS
DO FILE^DICN
KILL DA,DD,DIC,DO,DR
SET PXVIEN=+Y
IF PXVIEN'>0
SET PXVCODE=0
QUIT
+5 SET PXVC=0
FOR
SET PXVC=$ORDER(^AUTTSK(PXVSK,3,PXVM,1,PXVC))
if 'PXVC
QUIT
Begin DoDot:2
+6 SET PXVCOD=$PIECE(^AUTTSK(PXVSK,3,PXVM,1,PXVC,0),"^")
+7 SET PXVY(9000010.1231,"+1,"_PXVIEN_","_PXVTN_",",.01)=PXVCOD
DO UPDATE^DIE("","PXVY")
KILL PXVY
End DoDot:2
End DoDot:1
+8 QUIT PXVCODE
KCODSYS ; kill logic for AC x-ref
+1 NEW PXVCODE,PXVTN
+2 SET PXVCODE=$$KCODX(DA)
+3 QUIT
KCODX(PXVTN) ;
+1 NEW DA,DD,DO,DIC,DR,PXVJ
SET PXVCODE=0
+2 SET PXVJ=0
FOR
SET PXVJ=$ORDER(^AUPNVSK(PXVTN,3,PXVJ))
if 'PXVJ
QUIT
Begin DoDot:1
+3 SET PXVY(9000010.123,PXVJ_","_PXVTN_",",.01)="@"
DO FILE^DIE("","PXVY")
End DoDot:1
SET PXVCODE=1
+4 QUIT PXVCODE
+5 ;
TIME() ; determine if future time
+1 NEW PXMAX,PXOVERDL,PXCHECKDT
+2 SET PXCHECKDT=X
+3 ;
+4 Begin DoDot:1
+5 NEW X,Y
+6 SET PXOVERDL=0
+7 ; get value of ORPARAM OVER DATELINE. ICR #7388
DO OVERDL^ORWU(.PXOVERDL)
+8 SET PXMAX=$$FMADD^XLFDT($$NOW^XLFDT,0,0,1)
+9 IF PXOVERDL
SET PXMAX=$$FMADD^XLFDT($$DT^XLFDT,2)
End DoDot:1
+10 ;
+11 QUIT $SELECT(PXCHECKDT>PXMAX:1,1:0)
+12 ;
