WVRPCPR ;HIOFO/FT-WV PROCEDURE file (790.1) RPCs (cont.) ;07/06/2020
;;1.0;WOMEN'S HEALTH;**16,26**;Sep 30, 1998;Build 624
;
; This routine uses the following IAs:
; #10103 - ^XLFDT calls (supported)
;
; This routine supports the following IAs:
; LATEST - 4105
;
TYPEIEN(WVNAME) ; This function returns the IEN of an entry in the
; WV PROCEDURE TYPE file (#790.2)
; Input: WVNAME is the procedure name (i.e., .01 value)
; Output: IEN of the procedure type. Returns -1 if not found.
N WVIEN
I WVNAME="" Q -1 ;can't be null
S WVIEN=$O(^WV(790.2,"B",WVNAME,0))
S:WVIEN'>0 WVIEN=-1
Q WVIEN
;
TYPENAME(WVIEN) ; This function returns the NAME of an entry in the
; WV PROCEDURE TYPE file (#790.2)
; Input: IEN (FILE 790.2)
; Output: Name of the procedure type. Returns -1 if not found.
N WVNAME
I WVIEN="" Q -1 ;can't be null
S WVNAME=$P($G(^WV(790.2,+WVIEN,0)),U,1)
Q WVNAME
;
BUIEN() ; This function returns the IEN for a BREAST ULTRASOUND procedure
; type from FILE 790.2
Q $$TYPEIEN("BREAST ULTRASOUND")
;
PAPIEN() ; This function returns the IEN for a screening PAP SMEAR
; procedure type from FILE 790.2
Q $$TYPEIEN("PAP SMEAR")
;
MAMIENS() ; This function returns the IENs for diagnostic MAMMOGRAM
; procedure types from FILE 790.2
; returns a string delimited by caret with the IENS (e.g., "25^26"
N WVARRAY,WVCNT,WVDIAG,WVIEN,WVNAME
S (WVDIAG,WVNAME)="",WVCNT=0
S WVARRAY("MAMMOGRAM DX UNILAT")=""
S WVARRAY("MAMMOGRAM DX BILAT")=""
S WVARRAY("MAMMOGRAM SCREENING")=""
F S WVNAME=$O(WVARRAY(WVNAME)) Q:WVNAME="" D
.S WVIEN=$$TYPEIEN(WVNAME)
.I WVIEN>0 S WVCNT=WVCNT+1,$P(WVDIAG,U,WVCNT)=WVIEN
.Q
Q WVDIAG
;
LATEST(RESULT,WVDFN,WVPTYPE,WVDATES,WVMAX,WVDX) ; Returns the Pap Smear or
; Mammogram entries in reverse chronological order.
; Input: RESULT - Array name for return values [required]
; WVDFN - patient DFN [required]
; WVPTYPE - "P" for Pap Smear or "M" for Mammogram or
; "U" for Breast Ultrasound [required]
; WVDATES - date range in FileMan internal format
; (e.g., 3020101^3021231) [optional]
; WVMAX - max number of entries to return (e.g., 20)
; (optional - default is 10) [optional]
; WVDX - "N", "A", "P" or "*" to return records with a
; dx/result of normal, abnormal, pending or any
; [optional]
;
; Output: RESULT(0)=# of matches^
; or=-1^error message
; RESULT(n)=IEN^DFN^DATE^TYPE^DX CATEGORY^DX Result^Rad/Lab
; Link^FILE 790.1 STATUS
; where IEN = FILE 790.1 internal entry number
; DFN = FILE 2 internal entry number
; DATE = Procedure date in FileMan format
; TYPE = Procedure name (from FILE 790.2)
; DX Category = Normal, Abnormal or Pending
; DX Result = FILE 790.31, Field .01
;RAD/LAB LINK = 0=no link to rad/lab entry, 1=link to rad/lab entry
; Status = File 790.1 procedure status ('OPEN' or 'CLOSED')
;
I '$G(WVDFN) D Q
.S RESULT(0)="-1^Patient DFN is not numeric or undefined."
.Q
I $G(WVPTYPE)="" D Q
.S RESULT(0)="-1^Procedure type not identified."
.Q
I '$D(^WV(790.1,"C",WVDFN)) D Q
.S RESULT(0)="-1^No procedures found for this patient"
.Q
N WVCOUNT,WVEND,WVIEN,WVLOOP,WVMANUAL,WVNODE,WVNODE1,WVNORM,WVOUT,WVRD
N WVRESULT,WVSTART,WVSTATUS,WVTYPE,WVYES
S (WVCOUNT,WVLOOP,WVOUT)=0
S:'$D(WVDATES) WVDATES="^"
S WVSTART=$P(WVDATES,U,1) ;search start date
S:WVSTART="" WVSTART=$$FMADD^XLFDT(DT,-1095)
S WVEND=$P(WVDATES,U,2) ;search end date
S:WVEND="" WVEND=DT
S:+$G(WVMAX)'>0 WVMAX=10
S:$G(WVDX)="" WVDX="*"
S WVLOOP=WVEND+.000001
F S WVLOOP=$O(^WV(790.1,"AC",WVDFN,WVLOOP),-1) Q:'WVLOOP!(WVSTART>WVLOOP)!(WVOUT=1) D
.S WVIEN=0
.F S WVIEN=$O(^WV(790.1,"AC",WVDFN,WVLOOP,WVIEN)) Q:'WVIEN!(WVOUT=1) D
..S WVNODE=$G(^WV(790.1,+WVIEN,0))
..Q:WVNODE=""
..I $P(WVNODE,U,5)=$$ERROR^WVRPCPR1() Q ;error/disregard diagnosis
..;check procedure types
..S WVYES=0
..I WVPTYPE="P",$E($P(WVNODE,U,1),1,2)="PS" S WVYES=1
..I WVPTYPE="M",$E($P(WVNODE,U,1),1,2)="MB" S WVYES=1
..I WVPTYPE="M",$E($P(WVNODE,U,1),1,2)="MU" S WVYES=1
..I WVPTYPE="M",$E($P(WVNODE,U,1),1,2)="MS" S WVYES=1
..I WVPTYPE="U",$E($P(WVNODE,U,1),1,2)="BU" S WVYES=1
..Q:'WVYES
..;check result/dx value
..S WVYES=0
..S WVNORM=$$NORMAL^WVRPCPR1($P(WVNODE,U,5)) ;is dx normal/abnormal?
..I WVDX="N",WVNORM=0 S WVYES=1
..I WVDX="A",WVNORM=1 S WVYES=1
..I WVDX="P",WVNORM=2 S WVYES=1
..I WVDX="P",$P(WVNODE,U,5)="" S WVYES=1 ;treat 'NO RESULT' & null alike
..I WVDX="*" S WVYES=1
..Q:'WVYES
..I WVCOUNT=WVMAX S WVOUT=1 Q ;max # reached, stop looking
..S WVCOUNT=WVCOUNT+1
..S WVSTATUS=$P(WVNODE,U,14)
..S WVSTATUS=$S(WVSTATUS="o":"OPEN",WVSTATUS="c":"CLOSED",WVSTATUS="e":"ENTER IN ERROR",1:"OPEN")
..S WVTYPE=$$TYPENAME(+$P(WVNODE,U,4))
..S WVRESULT=$$DXNAME^WVRPCPR1($P(WVNODE,U,5))
..S WVNORM=$S(WVNORM=0:"Normal",WVNORM=1:"Abnormal",WVNORM=2:"Unsatisfactory",1:"Pending")
..S WVMANUAL=0 ;0=no link to rad/lab entry, 1=link to rad/lab entry
..I $P($G(^WV(790.1,WVIEN,2)),U,17)]""!($P(WVNODE,U,15)]"") S WVMANUAL=1
..;WVNODE1=IEN^DFN^DATE^TYPE^Dx Category^DX Result^Manual
..S WVNODE1=WVIEN_U_$P(WVNODE,U,2)_U_$P(WVNODE,U,12)_U_WVTYPE_U_WVNORM_U_WVRESULT_U_WVMANUAL_U_WVSTATUS
..S RESULT(WVCOUNT)=WVNODE1
..Q
.Q
I WVCOUNT=0 S RESULT(0)="-1^No records matched."
I WVCOUNT>0 S RESULT(0)=WVCOUNT_U
Q
SETRESLT(WVIEN,WVRESULT) ; Update the RESULTS/DIAGNOSIS field (.05)
; for the WV PROCEDURE file (#790.1) record identified by WVIEN.
; Input: WVIEN - FILE 790.1 IEN
; WVRESULT - FILE 790.31 IEN
;
; Output: <none>
;
N WVERR,WVDXFLAG,WVFAC,WVFDA
I $G(WVIEN)'>0 Q
D UPDATE^WVALERTS(WVIEN) ;mark procedure as processed by CR
I $G(WVRESULT)'>0 Q
; Check 'update results/dx?' parameter
S WVFAC=+$P($G(^WV(790.1,+WVIEN,0)),U,10)
S WVDXFLAG=$P($G(^WV(790.02,+WVFAC,0)),U,11)
Q:'WVDXFLAG
S WVFDA(790.1,WVIEN_",",.05)=WVRESULT
S WVFDA(790.1,WVIEN_",",.14)="c"
D FILE^DIE("","WVFDA","WVERR")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HWVRPCPR 6226 printed Dec 13, 2024@02:47:46 Page 2
WVRPCPR ;HIOFO/FT-WV PROCEDURE file (790.1) RPCs (cont.) ;07/06/2020
+1 ;;1.0;WOMEN'S HEALTH;**16,26**;Sep 30, 1998;Build 624
+2 ;
+3 ; This routine uses the following IAs:
+4 ; #10103 - ^XLFDT calls (supported)
+5 ;
+6 ; This routine supports the following IAs:
+7 ; LATEST - 4105
+8 ;
TYPEIEN(WVNAME) ; This function returns the IEN of an entry in the
+1 ; WV PROCEDURE TYPE file (#790.2)
+2 ; Input: WVNAME is the procedure name (i.e., .01 value)
+3 ; Output: IEN of the procedure type. Returns -1 if not found.
+4 NEW WVIEN
+5 ;can't be null
IF WVNAME=""
QUIT -1
+6 SET WVIEN=$ORDER(^WV(790.2,"B",WVNAME,0))
+7 if WVIEN'>0
SET WVIEN=-1
+8 QUIT WVIEN
+9 ;
TYPENAME(WVIEN) ; This function returns the NAME of an entry in the
+1 ; WV PROCEDURE TYPE file (#790.2)
+2 ; Input: IEN (FILE 790.2)
+3 ; Output: Name of the procedure type. Returns -1 if not found.
+4 NEW WVNAME
+5 ;can't be null
IF WVIEN=""
QUIT -1
+6 SET WVNAME=$PIECE($GET(^WV(790.2,+WVIEN,0)),U,1)
+7 QUIT WVNAME
+8 ;
BUIEN() ; This function returns the IEN for a BREAST ULTRASOUND procedure
+1 ; type from FILE 790.2
+2 QUIT $$TYPEIEN("BREAST ULTRASOUND")
+3 ;
PAPIEN() ; This function returns the IEN for a screening PAP SMEAR
+1 ; procedure type from FILE 790.2
+2 QUIT $$TYPEIEN("PAP SMEAR")
+3 ;
MAMIENS() ; This function returns the IENs for diagnostic MAMMOGRAM
+1 ; procedure types from FILE 790.2
+2 ; returns a string delimited by caret with the IENS (e.g., "25^26"
+3 NEW WVARRAY,WVCNT,WVDIAG,WVIEN,WVNAME
+4 SET (WVDIAG,WVNAME)=""
SET WVCNT=0
+5 SET WVARRAY("MAMMOGRAM DX UNILAT")=""
+6 SET WVARRAY("MAMMOGRAM DX BILAT")=""
+7 SET WVARRAY("MAMMOGRAM SCREENING")=""
+8 FOR
SET WVNAME=$ORDER(WVARRAY(WVNAME))
if WVNAME=""
QUIT
Begin DoDot:1
+9 SET WVIEN=$$TYPEIEN(WVNAME)
+10 IF WVIEN>0
SET WVCNT=WVCNT+1
SET $PIECE(WVDIAG,U,WVCNT)=WVIEN
+11 QUIT
End DoDot:1
+12 QUIT WVDIAG
+13 ;
LATEST(RESULT,WVDFN,WVPTYPE,WVDATES,WVMAX,WVDX) ; Returns the Pap Smear or
+1 ; Mammogram entries in reverse chronological order.
+2 ; Input: RESULT - Array name for return values [required]
+3 ; WVDFN - patient DFN [required]
+4 ; WVPTYPE - "P" for Pap Smear or "M" for Mammogram or
+5 ; "U" for Breast Ultrasound [required]
+6 ; WVDATES - date range in FileMan internal format
+7 ; (e.g., 3020101^3021231) [optional]
+8 ; WVMAX - max number of entries to return (e.g., 20)
+9 ; (optional - default is 10) [optional]
+10 ; WVDX - "N", "A", "P" or "*" to return records with a
+11 ; dx/result of normal, abnormal, pending or any
+12 ; [optional]
+13 ;
+14 ; Output: RESULT(0)=# of matches^
+15 ; or=-1^error message
+16 ; RESULT(n)=IEN^DFN^DATE^TYPE^DX CATEGORY^DX Result^Rad/Lab
+17 ; Link^FILE 790.1 STATUS
+18 ; where IEN = FILE 790.1 internal entry number
+19 ; DFN = FILE 2 internal entry number
+20 ; DATE = Procedure date in FileMan format
+21 ; TYPE = Procedure name (from FILE 790.2)
+22 ; DX Category = Normal, Abnormal or Pending
+23 ; DX Result = FILE 790.31, Field .01
+24 ;RAD/LAB LINK = 0=no link to rad/lab entry, 1=link to rad/lab entry
+25 ; Status = File 790.1 procedure status ('OPEN' or 'CLOSED')
+26 ;
+27 IF '$GET(WVDFN)
Begin DoDot:1
+28 SET RESULT(0)="-1^Patient DFN is not numeric or undefined."
+29 QUIT
End DoDot:1
QUIT
+30 IF $GET(WVPTYPE)=""
Begin DoDot:1
+31 SET RESULT(0)="-1^Procedure type not identified."
+32 QUIT
End DoDot:1
QUIT
+33 IF '$DATA(^WV(790.1,"C",WVDFN))
Begin DoDot:1
+34 SET RESULT(0)="-1^No procedures found for this patient"
+35 QUIT
End DoDot:1
QUIT
+36 NEW WVCOUNT,WVEND,WVIEN,WVLOOP,WVMANUAL,WVNODE,WVNODE1,WVNORM,WVOUT,WVRD
+37 NEW WVRESULT,WVSTART,WVSTATUS,WVTYPE,WVYES
+38 SET (WVCOUNT,WVLOOP,WVOUT)=0
+39 if '$DATA(WVDATES)
SET WVDATES="^"
+40 ;search start date
SET WVSTART=$PIECE(WVDATES,U,1)
+41 if WVSTART=""
SET WVSTART=$$FMADD^XLFDT(DT,-1095)
+42 ;search end date
SET WVEND=$PIECE(WVDATES,U,2)
+43 if WVEND=""
SET WVEND=DT
+44 if +$GET(WVMAX)'>0
SET WVMAX=10
+45 if $GET(WVDX)=""
SET WVDX="*"
+46 SET WVLOOP=WVEND+.000001
+47 FOR
SET WVLOOP=$ORDER(^WV(790.1,"AC",WVDFN,WVLOOP),-1)
if 'WVLOOP!(WVSTART>WVLOOP)!(WVOUT=1)
QUIT
Begin DoDot:1
+48 SET WVIEN=0
+49 FOR
SET WVIEN=$ORDER(^WV(790.1,"AC",WVDFN,WVLOOP,WVIEN))
if 'WVIEN!(WVOUT=1)
QUIT
Begin DoDot:2
+50 SET WVNODE=$GET(^WV(790.1,+WVIEN,0))
+51 if WVNODE=""
QUIT
+52 ;error/disregard diagnosis
IF $PIECE(WVNODE,U,5)=$$ERROR^WVRPCPR1()
QUIT
+53 ;check procedure types
+54 SET WVYES=0
+55 IF WVPTYPE="P"
IF $EXTRACT($PIECE(WVNODE,U,1),1,2)="PS"
SET WVYES=1
+56 IF WVPTYPE="M"
IF $EXTRACT($PIECE(WVNODE,U,1),1,2)="MB"
SET WVYES=1
+57 IF WVPTYPE="M"
IF $EXTRACT($PIECE(WVNODE,U,1),1,2)="MU"
SET WVYES=1
+58 IF WVPTYPE="M"
IF $EXTRACT($PIECE(WVNODE,U,1),1,2)="MS"
SET WVYES=1
+59 IF WVPTYPE="U"
IF $EXTRACT($PIECE(WVNODE,U,1),1,2)="BU"
SET WVYES=1
+60 if 'WVYES
QUIT
+61 ;check result/dx value
+62 SET WVYES=0
+63 ;is dx normal/abnormal?
SET WVNORM=$$NORMAL^WVRPCPR1($PIECE(WVNODE,U,5))
+64 IF WVDX="N"
IF WVNORM=0
SET WVYES=1
+65 IF WVDX="A"
IF WVNORM=1
SET WVYES=1
+66 IF WVDX="P"
IF WVNORM=2
SET WVYES=1
+67 ;treat 'NO RESULT' & null alike
IF WVDX="P"
IF $PIECE(WVNODE,U,5)=""
SET WVYES=1
+68 IF WVDX="*"
SET WVYES=1
+69 if 'WVYES
QUIT
+70 ;max # reached, stop looking
IF WVCOUNT=WVMAX
SET WVOUT=1
QUIT
+71 SET WVCOUNT=WVCOUNT+1
+72 SET WVSTATUS=$PIECE(WVNODE,U,14)
+73 SET WVSTATUS=$SELECT(WVSTATUS="o":"OPEN",WVSTATUS="c":"CLOSED",WVSTATUS="e":"ENTER IN ERROR",1:"OPEN")
+74 SET WVTYPE=$$TYPENAME(+$PIECE(WVNODE,U,4))
+75 SET WVRESULT=$$DXNAME^WVRPCPR1($PIECE(WVNODE,U,5))
+76 SET WVNORM=$SELECT(WVNORM=0:"Normal",WVNORM=1:"Abnormal",WVNORM=2:"Unsatisfactory",1:"Pending")
+77 ;0=no link to rad/lab entry, 1=link to rad/lab entry
SET WVMANUAL=0
+78 IF $PIECE($GET(^WV(790.1,WVIEN,2)),U,17)]""!($PIECE(WVNODE,U,15)]"")
SET WVMANUAL=1
+79 ;WVNODE1=IEN^DFN^DATE^TYPE^Dx Category^DX Result^Manual
+80 SET WVNODE1=WVIEN_U_$PIECE(WVNODE,U,2)_U_$PIECE(WVNODE,U,12)_U_WVTYPE_U_WVNORM_U_WVRESULT_U_WVMANUAL_U_WVSTATUS
+81 SET RESULT(WVCOUNT)=WVNODE1
+82 QUIT
End DoDot:2
+83 QUIT
End DoDot:1
+84 IF WVCOUNT=0
SET RESULT(0)="-1^No records matched."
+85 IF WVCOUNT>0
SET RESULT(0)=WVCOUNT_U
+86 QUIT
SETRESLT(WVIEN,WVRESULT) ; Update the RESULTS/DIAGNOSIS field (.05)
+1 ; for the WV PROCEDURE file (#790.1) record identified by WVIEN.
+2 ; Input: WVIEN - FILE 790.1 IEN
+3 ; WVRESULT - FILE 790.31 IEN
+4 ;
+5 ; Output: <none>
+6 ;
+7 NEW WVERR,WVDXFLAG,WVFAC,WVFDA
+8 IF $GET(WVIEN)'>0
QUIT
+9 ;mark procedure as processed by CR
DO UPDATE^WVALERTS(WVIEN)
+10 IF $GET(WVRESULT)'>0
QUIT
+11 ; Check 'update results/dx?' parameter
+12 SET WVFAC=+$PIECE($GET(^WV(790.1,+WVIEN,0)),U,10)
+13 SET WVDXFLAG=$PIECE($GET(^WV(790.02,+WVFAC,0)),U,11)
+14 if 'WVDXFLAG
QUIT
+15 SET WVFDA(790.1,WVIEN_",",.05)=WVRESULT
+16 SET WVFDA(790.1,WVIEN_",",.14)="c"
+17 DO FILE^DIE("","WVFDA","WVERR")
+18 QUIT
