- 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 Feb 18, 2025@23:58:29 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 ;