WVRPCNO ;HIOFO/FT-WV NOTIFICATIONS file (790.4) RPCs ;1/7/05 15:03
;;1.0;WOMEN'S HEALTH;**16**;Sep 30, 1998
;
; This routine uses the following IAs:
; #10035 - FILE 2 (supported)
;
; This routine supports the following IAs:
; NEW - 4104
;
ACCESION(WVIEN) ; Returns the external value of FILE 790.4, Field .06
; Input: record ien
; Output: external value of the .01 field
Q $P($G(^WV(790.1,+WVIEN,0)),U,1)
;
OUTCOME(WVIEN) ; Returns the external value of FILE 790.405
; Input: record ien
; Output: external value of the .01 field
Q $P($G(^WV(790.405,+WVIEN,0)),U,1)
;
PURPOSE(WVIEN) ; Returns the external value of FILE 790.404
; Input: record ien
; Output: external value of the .01 field
Q $P($G(^WV(790.404,+WVIEN,0)),U,1)
;
TYPE(WVIEN) ; Returns the external value of FILE 790.403
; Input: record ien
; Output: external value of the .01 field
Q $P($G(^WV(790.403,+WVIEN,0)),U,1)
;
NEW(WVRESULT,WVNOTPUR) ; Update procedure result, create notification,
; print notification and update treatment needs.
; Input: WVRESULT(n)=FILE 790.1 IEN^"A", "N" or "U" (WVRESULT array is
; Optional)
; where A=Abnornal, N=No Evidence of Malignancy and
; U=Unsatisfactory for Dx.
; n is a number greater than zero.
;
; WVNOTPUR(FILE 790.404 IEN,n)=FILE 790.1 IEN^"I", "L" or "P"^
; FILE 3.5 NAME^DFN
; where I=In-person, L=letter and P=phone call (i.e.,
; notification type)
; Output: None
;
N WVCNT,WVDX,WVNODE,WVPURP,WVTYPE
I $O(WVRESULT(0)) D
.S WVCNT=0
.F S WVCNT=$O(WVRESULT(WVCNT)) Q:'WVCNT D
..S WVDX=$$GETDXIEN^WVRPCNO1($P(WVRESULT(WVCNT),U,2))
..D SETRESLT^WVRPCPR($P(WVRESULT(WVCNT),U,1),WVDX)
..Q
.Q
Q:'$O(WVNOTPUR(0))
S WVPURP=0
F S WVPURP=$O(WVNOTPUR(WVPURP)) Q:'WVPURP D
.S WVCNT=0
.F S WVCNT=$O(WVNOTPUR(WVPURP,WVCNT)) Q:'WVCNT D
..S WVNODE=$G(WVNOTPUR(WVPURP,WVCNT))
..Q:WVNODE=""
..;resolve type code to an IEN
..S WVTYPE=$P(WVNODE,U,2)
..I $P(WVNODE,U,2)'="CPRS" S WVTYPE=$$GETYPIEN^WVRPCNO1($P(WVNODE,U,2))
..;throw away printer value if not a letter
..I $P(WVNODE,U,2)'="L" S $P(WVNODE,U,3)=""
..D ADD($P(WVNODE,U,1),WVPURP,WVTYPE,$P(WVNODE,U,3),$P(WVNODE,U,4))
..Q
.Q
Q
ADD(WVIEN,WVPURP,WVTYPE,WVPRINTR,WVDFN) ; Create a new notification entry
; in FILE 790.4.
; Input: WVIEN - FILE 790.1 IEN [Required]
; WVPURP - FILE 790.404 IEN [Required]
; WVTYPE - FILE 790.403 IEN [Required]
; WVPRINTR - FILE 3.5 NAME (device) [Optional]
; WVDFN - FILE 790 IEN [Optional]
; Output: <None>
;
N BRDD,BRTX,CRDD,CRTX,DA,DFN,DLAYGO
N WVDA7904,WVDXFLAG,WVERR,WVERRADD,WVFAC,WVFDA,WVFDAIEN
N WVLDAT,WVLPRG,WVNODE,WVNPFLAG,WVOUTCUM,WVPDATE,WVTXFLAG
I $G(WVIEN)>0 D
.S WVNODE=$G(^WV(790.1,+$G(WVIEN),0))
.Q:WVNODE=""
.S WVDFN=$P(WVNODE,U,2)
.S WVFAC=+$P(WVNODE,U,10)
.S WVPDATE=$P(WVNODE,U,12) ;procedure date
.Q
Q:'$G(WVDFN)
S WVNPFLAG=0 ;new patient flag
I '$D(^WV(790,+$G(WVDFN),0)) D Q:'WVNPFLAG ;patient not in WH package
.Q:$P($G(^DPT(WVDFN,0)),U,2)'="F" ;not female
.Q:'$D(^WV(790.02,DUZ(2))) ;no site parameters
.Q:'$P($G(^WV(790.02,+$G(DUZ(2)),0)),U,2) ;no default case mgr
.S DFN=WVDFN
.Q:'$$VNVEC^WVRALIN1() ;vet/non-vet/eligibility code check
.S WVERRADD=1
.D AUTOADD^WVPATE(WVDFN,DUZ(2),.WVERRADD) ;add patient to FILE 790
.I WVERRADD>0 S WVNPFLAG=1 ;patient added
.Q
I '$D(^WV(790.404,+$G(WVPURP),0)) Q ;purpose
I '$G(WVFAC) S WVFAC=DUZ(2) ;facility ien
S WVDXFLAG=$P($G(^WV(790.02,+WVFAC,0)),U,11,12)
S WVTXFLAG=$P(WVDXFLAG,U,2) ;update treatment needs?
S WVDXFLAG=$P(WVDXFLAG,U,1) ;update results/dx?
S:$G(WVPDATE)'>0 WVPDATE=DT ;use today if no procedure date
I $G(WVTYPE)="CPRS" G TX
I '$D(^WV(790.403,+$G(WVTYPE),0)) Q ;type
S WVOUTCUM=""
I $G(WVPRINTR)]"" S WVOUTCUM=$$GETOIEN^WVRPCNO1("Letter Sent")
; create File 790.4 entry
S WVFDA(790.4,"+1,",.01)=WVDFN ;DFN
S WVFDA(790.4,"+1,",.02)=DT ;date opened
S WVFDA(790.4,"+1,",.03)=WVTYPE ;type
S WVFDA(790.4,"+1,",.04)=WVPURP ;purpose
S WVFDA(790.4,"+1,",.05)=WVOUTCUM ;outcome
S WVFDA(790.4,"+1,",.06)=$G(WVIEN) ;wh accession #
S WVFDA(790.4,"+1,",.07)=$S($G(WVFAC):$G(WVFAC),1:DUZ(2)) ;facility
S WVFDA(790.4,"+1,",.08)=DT ;date closed
I $P($G(^WV(790.403,+$G(WVTYPE),0)),U,2)=1 D
.S WVFDA(790.4,"+1,",.11)=DT ;print date
.Q
S WVFDA(790.4,"+1,",.13)=DT ;complete by date
S WVFDA(790.4,"+1,",.14)="c" ;status
D UPDATE^DIE("","WVFDA","WVFDAIEN","WVERR")
S WVDA7904=WVFDAIEN(1)
;
TX ; update treatment needs
I WVTXFLAG=1 D
.S WVNODE=$G(^WV(790.404,WVPURP,0))
.S BRTX=$S($P(WVNODE,U,7)]"":$P(WVNODE,U,7),1:"") ;breast tx need
.S BRDD=$S($P(WVNODE,U,8)]"":$P(WVNODE,U,8),1:"") ;breast tx due date
.S CRTX=$S($P(WVNODE,U,9)]"":$P(WVNODE,U,9),1:"") ;cervical tx need
.S CRDD=$S($P(WVNODE,U,10)]"":$P(WVNODE,U,10),1:"") ;cervical tx due date
.D BRTX^WVRPCPT(WVDFN,BRTX,BRDD,CRTX,CRDD,WVPDATE) ;update tx needs & due dates
.Q
; print notification?
Q:$G(WVPRINTR)="" ;no printer defined
Q:$P($G(^WV(790.403,+$G(WVTYPE),0)),U,2)'=1 ;not printable
S WVPRINTR=$P(WVPRINTR,";",2)
Q:WVPRINTR=""
D DEVICE^WVRPCNO1(WVDA7904,WVPRINTR) ;print letter
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HWVRPCNO 5383 printed Nov 22, 2024@17:57:31 Page 2
WVRPCNO ;HIOFO/FT-WV NOTIFICATIONS file (790.4) RPCs ;1/7/05 15:03
+1 ;;1.0;WOMEN'S HEALTH;**16**;Sep 30, 1998
+2 ;
+3 ; This routine uses the following IAs:
+4 ; #10035 - FILE 2 (supported)
+5 ;
+6 ; This routine supports the following IAs:
+7 ; NEW - 4104
+8 ;
ACCESION(WVIEN) ; Returns the external value of FILE 790.4, Field .06
+1 ; Input: record ien
+2 ; Output: external value of the .01 field
+3 QUIT $PIECE($GET(^WV(790.1,+WVIEN,0)),U,1)
+4 ;
OUTCOME(WVIEN) ; Returns the external value of FILE 790.405
+1 ; Input: record ien
+2 ; Output: external value of the .01 field
+3 QUIT $PIECE($GET(^WV(790.405,+WVIEN,0)),U,1)
+4 ;
PURPOSE(WVIEN) ; Returns the external value of FILE 790.404
+1 ; Input: record ien
+2 ; Output: external value of the .01 field
+3 QUIT $PIECE($GET(^WV(790.404,+WVIEN,0)),U,1)
+4 ;
TYPE(WVIEN) ; Returns the external value of FILE 790.403
+1 ; Input: record ien
+2 ; Output: external value of the .01 field
+3 QUIT $PIECE($GET(^WV(790.403,+WVIEN,0)),U,1)
+4 ;
NEW(WVRESULT,WVNOTPUR) ; Update procedure result, create notification,
+1 ; print notification and update treatment needs.
+2 ; Input: WVRESULT(n)=FILE 790.1 IEN^"A", "N" or "U" (WVRESULT array is
+3 ; Optional)
+4 ; where A=Abnornal, N=No Evidence of Malignancy and
+5 ; U=Unsatisfactory for Dx.
+6 ; n is a number greater than zero.
+7 ;
+8 ; WVNOTPUR(FILE 790.404 IEN,n)=FILE 790.1 IEN^"I", "L" or "P"^
+9 ; FILE 3.5 NAME^DFN
+10 ; where I=In-person, L=letter and P=phone call (i.e.,
+11 ; notification type)
+12 ; Output: None
+13 ;
+14 NEW WVCNT,WVDX,WVNODE,WVPURP,WVTYPE
+15 IF $ORDER(WVRESULT(0))
Begin DoDot:1
+16 SET WVCNT=0
+17 FOR
SET WVCNT=$ORDER(WVRESULT(WVCNT))
if 'WVCNT
QUIT
Begin DoDot:2
+18 SET WVDX=$$GETDXIEN^WVRPCNO1($PIECE(WVRESULT(WVCNT),U,2))
+19 DO SETRESLT^WVRPCPR($PIECE(WVRESULT(WVCNT),U,1),WVDX)
+20 QUIT
End DoDot:2
+21 QUIT
End DoDot:1
+22 if '$ORDER(WVNOTPUR(0))
QUIT
+23 SET WVPURP=0
+24 FOR
SET WVPURP=$ORDER(WVNOTPUR(WVPURP))
if 'WVPURP
QUIT
Begin DoDot:1
+25 SET WVCNT=0
+26 FOR
SET WVCNT=$ORDER(WVNOTPUR(WVPURP,WVCNT))
if 'WVCNT
QUIT
Begin DoDot:2
+27 SET WVNODE=$GET(WVNOTPUR(WVPURP,WVCNT))
+28 if WVNODE=""
QUIT
+29 ;resolve type code to an IEN
+30 SET WVTYPE=$PIECE(WVNODE,U,2)
+31 IF $PIECE(WVNODE,U,2)'="CPRS"
SET WVTYPE=$$GETYPIEN^WVRPCNO1($PIECE(WVNODE,U,2))
+32 ;throw away printer value if not a letter
+33 IF $PIECE(WVNODE,U,2)'="L"
SET $PIECE(WVNODE,U,3)=""
+34 DO ADD($PIECE(WVNODE,U,1),WVPURP,WVTYPE,$PIECE(WVNODE,U,3),$PIECE(WVNODE,U,4))
+35 QUIT
End DoDot:2
+36 QUIT
End DoDot:1
+37 QUIT
ADD(WVIEN,WVPURP,WVTYPE,WVPRINTR,WVDFN) ; Create a new notification entry
+1 ; in FILE 790.4.
+2 ; Input: WVIEN - FILE 790.1 IEN [Required]
+3 ; WVPURP - FILE 790.404 IEN [Required]
+4 ; WVTYPE - FILE 790.403 IEN [Required]
+5 ; WVPRINTR - FILE 3.5 NAME (device) [Optional]
+6 ; WVDFN - FILE 790 IEN [Optional]
+7 ; Output: <None>
+8 ;
+9 NEW BRDD,BRTX,CRDD,CRTX,DA,DFN,DLAYGO
+10 NEW WVDA7904,WVDXFLAG,WVERR,WVERRADD,WVFAC,WVFDA,WVFDAIEN
+11 NEW WVLDAT,WVLPRG,WVNODE,WVNPFLAG,WVOUTCUM,WVPDATE,WVTXFLAG
+12 IF $GET(WVIEN)>0
Begin DoDot:1
+13 SET WVNODE=$GET(^WV(790.1,+$GET(WVIEN),0))
+14 if WVNODE=""
QUIT
+15 SET WVDFN=$PIECE(WVNODE,U,2)
+16 SET WVFAC=+$PIECE(WVNODE,U,10)
+17 ;procedure date
SET WVPDATE=$PIECE(WVNODE,U,12)
+18 QUIT
End DoDot:1
+19 if '$GET(WVDFN)
QUIT
+20 ;new patient flag
SET WVNPFLAG=0
+21 ;patient not in WH package
IF '$DATA(^WV(790,+$GET(WVDFN),0))
Begin DoDot:1
+22 ;not female
if $PIECE($GET(^DPT(WVDFN,0)),U,2)'="F"
QUIT
+23 ;no site parameters
if '$DATA(^WV(790.02,DUZ(2)))
QUIT
+24 ;no default case mgr
if '$PIECE($GET(^WV(790.02,+$GET(DUZ(2)),0)),U,2)
QUIT
+25 SET DFN=WVDFN
+26 ;vet/non-vet/eligibility code check
if '$$VNVEC^WVRALIN1()
QUIT
+27 SET WVERRADD=1
+28 ;add patient to FILE 790
DO AUTOADD^WVPATE(WVDFN,DUZ(2),.WVERRADD)
+29 ;patient added
IF WVERRADD>0
SET WVNPFLAG=1
+30 QUIT
End DoDot:1
if 'WVNPFLAG
QUIT
+31 ;purpose
IF '$DATA(^WV(790.404,+$GET(WVPURP),0))
QUIT
+32 ;facility ien
IF '$GET(WVFAC)
SET WVFAC=DUZ(2)
+33 SET WVDXFLAG=$PIECE($GET(^WV(790.02,+WVFAC,0)),U,11,12)
+34 ;update treatment needs?
SET WVTXFLAG=$PIECE(WVDXFLAG,U,2)
+35 ;update results/dx?
SET WVDXFLAG=$PIECE(WVDXFLAG,U,1)
+36 ;use today if no procedure date
if $GET(WVPDATE)'>0
SET WVPDATE=DT
+37 IF $GET(WVTYPE)="CPRS"
GOTO TX
+38 ;type
IF '$DATA(^WV(790.403,+$GET(WVTYPE),0))
QUIT
+39 SET WVOUTCUM=""
+40 IF $GET(WVPRINTR)]""
SET WVOUTCUM=$$GETOIEN^WVRPCNO1("Letter Sent")
+41 ; create File 790.4 entry
+42 ;DFN
SET WVFDA(790.4,"+1,",.01)=WVDFN
+43 ;date opened
SET WVFDA(790.4,"+1,",.02)=DT
+44 ;type
SET WVFDA(790.4,"+1,",.03)=WVTYPE
+45 ;purpose
SET WVFDA(790.4,"+1,",.04)=WVPURP
+46 ;outcome
SET WVFDA(790.4,"+1,",.05)=WVOUTCUM
+47 ;wh accession #
SET WVFDA(790.4,"+1,",.06)=$GET(WVIEN)
+48 ;facility
SET WVFDA(790.4,"+1,",.07)=$SELECT($GET(WVFAC):$GET(WVFAC),1:DUZ(2))
+49 ;date closed
SET WVFDA(790.4,"+1,",.08)=DT
+50 IF $PIECE($GET(^WV(790.403,+$GET(WVTYPE),0)),U,2)=1
Begin DoDot:1
+51 ;print date
SET WVFDA(790.4,"+1,",.11)=DT
+52 QUIT
End DoDot:1
+53 ;complete by date
SET WVFDA(790.4,"+1,",.13)=DT
+54 ;status
SET WVFDA(790.4,"+1,",.14)="c"
+55 DO UPDATE^DIE("","WVFDA","WVFDAIEN","WVERR")
+56 SET WVDA7904=WVFDAIEN(1)
+57 ;
TX ; update treatment needs
+1 IF WVTXFLAG=1
Begin DoDot:1
+2 SET WVNODE=$GET(^WV(790.404,WVPURP,0))
+3 ;breast tx need
SET BRTX=$SELECT($PIECE(WVNODE,U,7)]"":$PIECE(WVNODE,U,7),1:"")
+4 ;breast tx due date
SET BRDD=$SELECT($PIECE(WVNODE,U,8)]"":$PIECE(WVNODE,U,8),1:"")
+5 ;cervical tx need
SET CRTX=$SELECT($PIECE(WVNODE,U,9)]"":$PIECE(WVNODE,U,9),1:"")
+6 ;cervical tx due date
SET CRDD=$SELECT($PIECE(WVNODE,U,10)]"":$PIECE(WVNODE,U,10),1:"")
+7 ;update tx needs & due dates
DO BRTX^WVRPCPT(WVDFN,BRTX,BRDD,CRTX,CRDD,WVPDATE)
+8 QUIT
End DoDot:1
+9 ; print notification?
+10 ;no printer defined
if $GET(WVPRINTR)=""
QUIT
+11 ;not printable
if $PIECE($GET(^WV(790.403,+$GET(WVTYPE),0)),U,2)'=1
QUIT
+12 SET WVPRINTR=$PIECE(WVPRINTR,";",2)
+13 if WVPRINTR=""
QUIT
+14 ;print letter
DO DEVICE^WVRPCNO1(WVDA7904,WVPRINTR)
+15 QUIT
