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

WVRPCNO.m

Go to the documentation of this file.
  1. WVRPCNO ;HIOFO/FT-WV NOTIFICATIONS file (790.4) RPCs ;1/7/05 15:03
  1. ;;1.0;WOMEN'S HEALTH;**16**;Sep 30, 1998
  1. ;
  1. ; This routine uses the following IAs:
  1. ; #10035 - FILE 2 (supported)
  1. ;
  1. ; This routine supports the following IAs:
  1. ; NEW - 4104
  1. ;
  1. ACCESION(WVIEN) ; Returns the external value of FILE 790.4, Field .06
  1. ; Input: record ien
  1. ; Output: external value of the .01 field
  1. Q $P($G(^WV(790.1,+WVIEN,0)),U,1)
  1. ;
  1. OUTCOME(WVIEN) ; Returns the external value of FILE 790.405
  1. ; Input: record ien
  1. ; Output: external value of the .01 field
  1. Q $P($G(^WV(790.405,+WVIEN,0)),U,1)
  1. ;
  1. PURPOSE(WVIEN) ; Returns the external value of FILE 790.404
  1. ; Input: record ien
  1. ; Output: external value of the .01 field
  1. Q $P($G(^WV(790.404,+WVIEN,0)),U,1)
  1. ;
  1. TYPE(WVIEN) ; Returns the external value of FILE 790.403
  1. ; Input: record ien
  1. ; Output: external value of the .01 field
  1. Q $P($G(^WV(790.403,+WVIEN,0)),U,1)
  1. ;
  1. NEW(WVRESULT,WVNOTPUR) ; Update procedure result, create notification,
  1. ; print notification and update treatment needs.
  1. ; Input: WVRESULT(n)=FILE 790.1 IEN^"A", "N" or "U" (WVRESULT array is
  1. ; Optional)
  1. ; where A=Abnornal, N=No Evidence of Malignancy and
  1. ; U=Unsatisfactory for Dx.
  1. ; n is a number greater than zero.
  1. ;
  1. ; WVNOTPUR(FILE 790.404 IEN,n)=FILE 790.1 IEN^"I", "L" or "P"^
  1. ; FILE 3.5 NAME^DFN
  1. ; where I=In-person, L=letter and P=phone call (i.e.,
  1. ; notification type)
  1. ; Output: None
  1. ;
  1. N WVCNT,WVDX,WVNODE,WVPURP,WVTYPE
  1. I $O(WVRESULT(0)) D
  1. .S WVCNT=0
  1. .F S WVCNT=$O(WVRESULT(WVCNT)) Q:'WVCNT D
  1. ..S WVDX=$$GETDXIEN^WVRPCNO1($P(WVRESULT(WVCNT),U,2))
  1. ..D SETRESLT^WVRPCPR($P(WVRESULT(WVCNT),U,1),WVDX)
  1. ..Q
  1. .Q
  1. Q:'$O(WVNOTPUR(0))
  1. S WVPURP=0
  1. F S WVPURP=$O(WVNOTPUR(WVPURP)) Q:'WVPURP D
  1. .S WVCNT=0
  1. .F S WVCNT=$O(WVNOTPUR(WVPURP,WVCNT)) Q:'WVCNT D
  1. ..S WVNODE=$G(WVNOTPUR(WVPURP,WVCNT))
  1. ..Q:WVNODE=""
  1. ..;resolve type code to an IEN
  1. ..S WVTYPE=$P(WVNODE,U,2)
  1. ..I $P(WVNODE,U,2)'="CPRS" S WVTYPE=$$GETYPIEN^WVRPCNO1($P(WVNODE,U,2))
  1. ..;throw away printer value if not a letter
  1. ..I $P(WVNODE,U,2)'="L" S $P(WVNODE,U,3)=""
  1. ..D ADD($P(WVNODE,U,1),WVPURP,WVTYPE,$P(WVNODE,U,3),$P(WVNODE,U,4))
  1. ..Q
  1. .Q
  1. Q
  1. ADD(WVIEN,WVPURP,WVTYPE,WVPRINTR,WVDFN) ; Create a new notification entry
  1. ; in FILE 790.4.
  1. ; Input: WVIEN - FILE 790.1 IEN [Required]
  1. ; WVPURP - FILE 790.404 IEN [Required]
  1. ; WVTYPE - FILE 790.403 IEN [Required]
  1. ; WVPRINTR - FILE 3.5 NAME (device) [Optional]
  1. ; WVDFN - FILE 790 IEN [Optional]
  1. ; Output: <None>
  1. ;
  1. N BRDD,BRTX,CRDD,CRTX,DA,DFN,DLAYGO
  1. N WVDA7904,WVDXFLAG,WVERR,WVERRADD,WVFAC,WVFDA,WVFDAIEN
  1. N WVLDAT,WVLPRG,WVNODE,WVNPFLAG,WVOUTCUM,WVPDATE,WVTXFLAG
  1. I $G(WVIEN)>0 D
  1. .S WVNODE=$G(^WV(790.1,+$G(WVIEN),0))
  1. .Q:WVNODE=""
  1. .S WVDFN=$P(WVNODE,U,2)
  1. .S WVFAC=+$P(WVNODE,U,10)
  1. .S WVPDATE=$P(WVNODE,U,12) ;procedure date
  1. .Q
  1. Q:'$G(WVDFN)
  1. S WVNPFLAG=0 ;new patient flag
  1. I '$D(^WV(790,+$G(WVDFN),0)) D Q:'WVNPFLAG ;patient not in WH package
  1. .Q:$P($G(^DPT(WVDFN,0)),U,2)'="F" ;not female
  1. .Q:'$D(^WV(790.02,DUZ(2))) ;no site parameters
  1. .Q:'$P($G(^WV(790.02,+$G(DUZ(2)),0)),U,2) ;no default case mgr
  1. .S DFN=WVDFN
  1. .Q:'$$VNVEC^WVRALIN1() ;vet/non-vet/eligibility code check
  1. .S WVERRADD=1
  1. .D AUTOADD^WVPATE(WVDFN,DUZ(2),.WVERRADD) ;add patient to FILE 790
  1. .I WVERRADD>0 S WVNPFLAG=1 ;patient added
  1. .Q
  1. I '$D(^WV(790.404,+$G(WVPURP),0)) Q ;purpose
  1. I '$G(WVFAC) S WVFAC=DUZ(2) ;facility ien
  1. S WVDXFLAG=$P($G(^WV(790.02,+WVFAC,0)),U,11,12)
  1. S WVTXFLAG=$P(WVDXFLAG,U,2) ;update treatment needs?
  1. S WVDXFLAG=$P(WVDXFLAG,U,1) ;update results/dx?
  1. S:$G(WVPDATE)'>0 WVPDATE=DT ;use today if no procedure date
  1. I $G(WVTYPE)="CPRS" G TX
  1. I '$D(^WV(790.403,+$G(WVTYPE),0)) Q ;type
  1. S WVOUTCUM=""
  1. I $G(WVPRINTR)]"" S WVOUTCUM=$$GETOIEN^WVRPCNO1("Letter Sent")
  1. ; create File 790.4 entry
  1. S WVFDA(790.4,"+1,",.01)=WVDFN ;DFN
  1. S WVFDA(790.4,"+1,",.02)=DT ;date opened
  1. S WVFDA(790.4,"+1,",.03)=WVTYPE ;type
  1. S WVFDA(790.4,"+1,",.04)=WVPURP ;purpose
  1. S WVFDA(790.4,"+1,",.05)=WVOUTCUM ;outcome
  1. S WVFDA(790.4,"+1,",.06)=$G(WVIEN) ;wh accession #
  1. S WVFDA(790.4,"+1,",.07)=$S($G(WVFAC):$G(WVFAC),1:DUZ(2)) ;facility
  1. S WVFDA(790.4,"+1,",.08)=DT ;date closed
  1. I $P($G(^WV(790.403,+$G(WVTYPE),0)),U,2)=1 D
  1. .S WVFDA(790.4,"+1,",.11)=DT ;print date
  1. .Q
  1. S WVFDA(790.4,"+1,",.13)=DT ;complete by date
  1. S WVFDA(790.4,"+1,",.14)="c" ;status
  1. D UPDATE^DIE("","WVFDA","WVFDAIEN","WVERR")
  1. S WVDA7904=WVFDAIEN(1)
  1. ;
  1. TX ; update treatment needs
  1. I WVTXFLAG=1 D
  1. .S WVNODE=$G(^WV(790.404,WVPURP,0))
  1. .S BRTX=$S($P(WVNODE,U,7)]"":$P(WVNODE,U,7),1:"") ;breast tx need
  1. .S BRDD=$S($P(WVNODE,U,8)]"":$P(WVNODE,U,8),1:"") ;breast tx due date
  1. .S CRTX=$S($P(WVNODE,U,9)]"":$P(WVNODE,U,9),1:"") ;cervical tx need
  1. .S CRDD=$S($P(WVNODE,U,10)]"":$P(WVNODE,U,10),1:"") ;cervical tx due date
  1. .D BRTX^WVRPCPT(WVDFN,BRTX,BRDD,CRTX,CRDD,WVPDATE) ;update tx needs & due dates
  1. .Q
  1. ; print notification?
  1. Q:$G(WVPRINTR)="" ;no printer defined
  1. Q:$P($G(^WV(790.403,+$G(WVTYPE),0)),U,2)'=1 ;not printable
  1. S WVPRINTR=$P(WVPRINTR,";",2)
  1. Q:WVPRINTR=""
  1. D DEVICE^WVRPCNO1(WVDA7904,WVPRINTR) ;print letter
  1. Q