PXBMPOV ;ISL/JVS,ESW - MAIN ROUTINE DIAGNOSIS ;3/5/04 1:50pm
 ;;1.0;PCE PATIENT CARE ENCOUNTER;**11,14,108,124,174**;Aug 12, 1996
 ;
 W !,"This is not the entry into this routine" Q
 ;
 ;  VARABLE LIST
 ;
 ;
 ;
POV(PXBVST) ;---Real entry point
 Q:'$D(^AUPNVSIT(PXBVST))
 ; PXBVST  = Appointment-Encounter Visit IEN
 ; PXBDPRV = Default Provider for clinic appointment IEN
 ;--Set up
 N PXBCNT,I,J,IDATE,PRIP,PRIPOV,PRISEC,QUA,VISIT,PRI,POV,PRV,PXBENT,SAVE
 N PXBUT,FPRI,ENTRY,PXBSAVE,DATA,PXBPRBLM,PXBRES,PXBSPL,NAME,PATIENT
 N REQI,REQE,PROMPT,PROVIDER,PXDIGNS,CYCL,PXBNPOVL,FROM,NOREV,NOPLLIST
 N PXBNCPT,PXBNPRV,PXBNPOV,FIRST,PXBWIN,CLINIC,PXBPMT,LEAVE,VAR,%
 K ^TMP("PXBGPOVMATCH",$J)
 S CLINIC=$P(^AUPNVSIT(PXBVST,0),"^",22),PROMPT="POV",FIRST=1,PXBEXIT=1
 S (REQE,REQI)=""
 S ^TMP("PXBDPOV",$J,"START")=0
 ;
PPP ;--Obtain the POV (DIAGNOSIS)
 N PXBSKY,PXBKY,PXBSAM,PXBCNT,PRVDR,FPRI
 D PRV^PXBGPRV(PXBVST,.PXBSKY,.PXBKY,.PXBSAM,.PXBCNT,.PRVDR,.FPRI)
 K PXBSPL
 D TERM^PXBCC
 D HDR^PXBUTL(PXBVST,1)
 D REQ^PXBDREQ(6)
 N LNARR D POV^PXBGPOV(PXBVST)
 D EN0^PXBDPOV
R D WIN17^PXBCC(PXBCNT),LOC^PXBCC(15,1)
 K ERROR D POV^PXBPPOV G:$G(PXBEXIT)<1 POVXIT G:$G(ERROR) R W IOEDEOP
 K FIRST
 I DATA["^P" D RSET^PXBDREQ("POV") G PPP
 I $G(PXBUT)=1,$D(LEAVE) G POVXIT
 ;
 ;--Prompt for Primary or Secondary DIAGNOSIS
 D WIN17^PXBCC(PXBCNT)
 D PRI^PXBPPOV1
 I $D(DIRUT) D RSET^PXBDREQ("POV") G PPP
 D ORD^PXBPPOV1
 N PXCEVIEN,PXCEAFTR,PXD
 S PXCEVIEN=PXBVST,PXD=$P(REQI,U,5)
 D FULL0^PXBCC,GET800^PXCEC800 ;CI's PX*1.0*174
 S PXBREQ(PXD,"I")=$G(PXCEAFTR(800))
 ;
 ;--Display the Requested Diagnosis
 D PRINT^PXBDREQ(4),EN0^PXBSTOR(PXBVST,PATIENT,REQI),EN1^PXKMAIN
 ;
 ;--Request entry to problem list
 I $D(DIRUT)!('$G(PXBPRBLM)) K DIRUT,PXBPRBLM D EN0^PXBSTOR(PXBVST,PATIENT,REQI),EN1^PXKMAIN,RSET^PXBDREQ("POV") G PPP
 ;
 ;--Request the Associated Provider
 ;---I NOT PROVIDER GO PPP
 ;
 ;--RETURN TO THE BEGINNING
 D RSET^PXBDREQ("POV"),RSET^PXBDREQ("PRV")
 G PPP
 Q
 ;
POVXIT ;----EXIT AND CLEAN UP
 D WIN17^PXBCC(PXBCNT)
 ;
 ;--Send the data to the problem list
PL I '$G(PXBEXIT)<1 D
 .I '$G(PXBPRBON) Q
 .I PXBCNT>0 N LNARR D SET^PXBPL
 D PRIM^PXBUTL
 ;D PRIMD^PXBUTL
 D FULL0^PXBCC
 D CLEAR1^PXBCC
 K PXBKY,PXBSAM,PXBSKY,PXBVST
 ;----Do the EVENT to the Protocol
 ;D EVENT^PXKMAIN
 K ^TMP("PXBDPOV",$J),^TMP("PXBSTOR",$J),^TMP("PXK",$J),^TMP("PXBDPL",$J)
 K ^TMP("PXBTOTAL",$J),^TMP("PXBTANA",$J),^TMP("PXBGPOVMATCH",$J)
 Q
 ;