Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PXVUTL

PXVUTL.m

Go to the documentation of this file.
  1. 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
  1. ;
  1. ; Reference to OVERDL^ORWU in ICR #7388
  1. ;
  1. HR ; called by AH new style x-ref in V SKIN TEST file
  1. ; set number of hours between placement and reading of test
  1. N PXVPLACE,PXVREAD,PXVX,X1,X2,X3
  1. S X1=$P($G(^AUPNVSK(DA,0)),"^",6) ; DATE READ
  1. S PXVREAD=$O(^AUPNVSK("APT",DA,0))
  1. I PXVREAD S X1=$P($G(^AUPNVSK(PXVREAD,0)),"^",6)
  1. S X2=$P($G(^AUPNVSK(DA,12)),"^") ; EVENT DATE AND TIME
  1. I X2="" S X2=$P($G(^AUPNVSIT(+$P($G(^AUPNVSK(DA,0)),"^",3),0)),U,1)
  1. S PXVPLACE=$P($G(^AUPNVSK(DA,12)),"^",8) ; PLACEMENT SKIN TEST
  1. I PXVPLACE D
  1. . S X2=$P($G(^AUPNVSK(PXVPLACE,12)),"^")
  1. . I X2="" S X2=$P($G(^AUPNVSIT(+$P($G(^AUPNVSK(PXVPLACE,0)),"^",3),0)),U,1)
  1. I X1=""!(X2="") Q
  1. S X3=2 ; return difference in seconds
  1. S PXVX=""
  1. I $G(X1),$L(X1)>7,$G(X2),$L(X2)>7,$G(X2)'>$G(X1) S PXVX=$$FMDIFF^XLFDT(X1,X2,X3)\3600
  1. I PXVREAD S $P(^AUPNVSK(PXVREAD,12),"^",14)=PXVX Q
  1. S $P(^AUPNVSK(DA,12),"^",14)=PXVX
  1. Q
  1. CODSYS ; set logic for AC x-ref on SKIN TEST field to populate CODE SYSTEM multiple
  1. N PXVCODE,PXVSK,PXVTN
  1. S PXVCODE=$$CODX(X,DA)
  1. Q
  1. CODX(PXVSK,PXVTN) ; populate CODE SYSTEM multiple
  1. N DA,DD,DO,DIC,DR,PXVC,PXVCOD,PXVIEN,PXVM,PXVSYS,X S PXVCODE=0
  1. S PXVM=0 F S PXVM=$O(^AUTTSK(PXVSK,3,PXVM)) Q:'PXVM D
  1. .S PXVSYS=$P(^AUTTSK(PXVSK,3,PXVM,0),"^") Q:PXVSYS="" S PXVCODE=1
  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
  1. .S PXVC=0 F S PXVC=$O(^AUTTSK(PXVSK,3,PXVM,1,PXVC)) Q:'PXVC D
  1. ..S PXVCOD=$P(^AUTTSK(PXVSK,3,PXVM,1,PXVC,0),"^")
  1. ..S PXVY(9000010.1231,"+1,"_PXVIEN_","_PXVTN_",",.01)=PXVCOD D UPDATE^DIE("","PXVY") K PXVY
  1. Q PXVCODE
  1. KCODSYS ; kill logic for AC x-ref
  1. N PXVCODE,PXVTN
  1. S PXVCODE=$$KCODX(DA)
  1. Q
  1. KCODX(PXVTN) ;
  1. N DA,DD,DO,DIC,DR,PXVJ S PXVCODE=0
  1. S PXVJ=0 F S PXVJ=$O(^AUPNVSK(PXVTN,3,PXVJ)) Q:'PXVJ D S PXVCODE=1
  1. .S PXVY(9000010.123,PXVJ_","_PXVTN_",",.01)="@" D FILE^DIE("","PXVY")
  1. Q PXVCODE
  1. ;
  1. TIME() ; determine if future time
  1. N PXMAX,PXOVERDL,PXCHECKDT
  1. S PXCHECKDT=X
  1. ;
  1. D
  1. . N X,Y
  1. . S PXOVERDL=0
  1. . D OVERDL^ORWU(.PXOVERDL) ; get value of ORPARAM OVER DATELINE. ICR #7388
  1. . S PXMAX=$$FMADD^XLFDT($$NOW^XLFDT,0,0,1)
  1. . I PXOVERDL S PXMAX=$$FMADD^XLFDT($$DT^XLFDT,2)
  1. ;
  1. Q $S(PXCHECKDT>PXMAX:1,1:0)
  1. ;