- 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 Feb 19, 2025@00:14:07 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