source: Scheduling/trunk/m/BSDX28.m@ 1087

BSDX28  ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 7/18/10 2:30pm
        ;;1.5;BSDX;;Jan 25, 2011
        ; 
           ; Change Log:
        ; HMW 3050721 Added test for inactivated record
           ; V1.3 WV/SMH 3100714 
           ; - add PID search
           ; - return PID instead of SSN (change header and logic)
           ; - Change Error trap to new style.
        ;
PTLOOKRS(BSDXY,BSDXP,BSDXC)      ;EP Patient Lookup
        ;
        ;Find up to BSDXC patients matching BSDXP*
        ;Supports DOB Lookup, Primary Long ID lookup
        ;
        N $ET S $ET="G ERROR^BSDX28"
           ; rm ctrl chars
        S BSDXP=$TR(BSDXP,$C(13),"")
        S BSDXP=$TR(BSDXP,$C(10),"")
        S BSDXP=$TR(BSDXP,$C(9),"")
           ; num of pts to find
        S:BSDXC="" BSDXC=10
        N BSDXHRN,BSDXZ,BSDXDLIM,BSDXRET,BSDXDPT,BSDXRET,BSDXIEN,BSDXFILE
        N BSDXIENS,BSDXFIELDS,BSDXFLAGS,BSDXVALUE,BSDXNUMBER,BSDXINDEXES,BSDXSCREEN
        N BSDXTARG,BSDXMSG,BSDXRSLT
        S BSDXDLIM="^"
        S BSDXRET="T00030NAME^T00030HRN^T00030PID^D00030DOB^T00030IEN"_$C(30)
        I '+$G(DUZ) S BSDXY=BSDXRET_$C(31) Q
        I '$D(DUZ(2)) S BSDXY=BSDXRET_$C(31) Q
        
PID     ;PID Lookup
           ; If this ID exists, go get it. If "UJOPID" index doesn't exist,
           ; won't work anyways.
           I $D(^DPT("UJOPID",BSDXP)) DO  SET BSDXY=BSDXRET_$C(31) QUIT
           . S BSDXIEN=$O(^DPT("UJOPID",BSDXP,""))
           . Q:'$D(^DPT(BSDXIEN,0))
           . S BSDXDPT=$G(^DPT(BSDXIEN,0))
           . S BSDXZ=$P(BSDXDPT,U) ;NAME
           . S BSDXHRN=$P($G(^AUPNPAT(BSDXIEN,41,DUZ(2),0)),U,2) ;CHART
           . I BSDXHRN="" Q  ;NO CHART AT THIS DUZ2
           . ; Inactivated Chart get an *
           . I $P($G(^AUPNPAT(BSDXIEN,41,DUZ(2),0)),U,3) S BSDXHRN=BSDXHRN_"(*)" Q
           . S $P(BSDXZ,BSDXDLIM,2)=BSDXHRN
           . S $P(BSDXZ,BSDXDLIM,3)=$P(^DPT(BSDXIEN,.36),U,3) ;PID
           . S Y=$P(BSDXDPT,U,3) X ^DD("DD")
           . S $P(BSDXZ,BSDXDLIM,4)=Y ;DOB
           . S $P(BSDXZ,BSDXDLIM,5)=BSDXIEN
           . S BSDXRET=BSDXRET_BSDXZ_$C(30)
        ;
DOB     ;DOB Lookup
        I +DUZ(2),((BSDXP?1.2N1"/"1.2N1"/"1.4N)!(BSDXP?1.2N1" "1.2N1" "1.4N)!(BSDXP?1.2N1"-"1.2N1"-"1.4N)) D  S BSDXY=BSDXRET_$C(31) Q
        . S X=BSDXP S %DT="P" D ^%DT S BSDXP=Y Q:'+Y
        . Q:'$D(^DPT("ADOB",BSDXP))
        . S BSDXIEN=0 F  S BSDXIEN=$O(^DPT("ADOB",BSDXP,BSDXIEN)) Q:'+BSDXIEN  D
        . . Q:'$D(^DPT(BSDXIEN,0))
        . . S BSDXDPT=$G(^DPT(BSDXIEN,0))
        . . S BSDXZ=$P(BSDXDPT,U) ;NAME
        . . S BSDXHRN=$P($G(^AUPNPAT(BSDXIEN,41,DUZ(2),0)),U,2) ;CHART
        . . I BSDXHRN="" Q  ;NO CHART AT THIS DUZ2
        . . I $P($G(^AUPNPAT(BSDXIEN,41,DUZ(2),0)),U,3) S BSDXHRN=BSDXHRN_"(*)" Q  ;HMW 20050721 Record Inactivated
        . . S $P(BSDXZ,BSDXDLIM,2)=BSDXHRN
           . . S $P(BSDXZ,BSDXDLIM,3)=$P(^DPT(BSDXIEN,.36),U,3) ;PID
        . . S Y=$P(BSDXDPT,U,3) X ^DD("DD")
        . . S $P(BSDXZ,BSDXDLIM,4)=Y ;DOB
        . . S $P(BSDXZ,BSDXDLIM,5)=BSDXIEN
        . . S BSDXRET=BSDXRET_BSDXZ_$C(30)
        . . Q
        . Q
        ;
CHART   
           ;Chart# Lookup
        I +DUZ(2),BSDXP]"",$D(^AUPNPAT("D",BSDXP)) D  S BSDXY=BSDXRET_$C(31) Q
        . S BSDXIEN=0 F  S BSDXIEN=$O(^AUPNPAT("D",BSDXP,BSDXIEN)) Q:'+BSDXIEN  I $D(^AUPNPAT("D",BSDXP,BSDXIEN,DUZ(2))) D  Q
        . . Q:'$D(^DPT(BSDXIEN,0))
        . . S BSDXDPT=$G(^DPT(BSDXIEN,0))
        . . S BSDXZ=$P(BSDXDPT,U) ;NAME
        . . S BSDXHRN=BSDXP ;CHART
        . . I $D(^AUPNPAT(BSDXIEN,41,DUZ(2),0)),$P(^(0),U,3) S BSDXHRN=BSDXHRN_"(*)" Q  ;HMW 20050721 Record Inactivated
        . . S $P(BSDXZ,BSDXDLIM,2)=BSDXHRN
           . . S $P(BSDXZ,BSDXDLIM,3)=$P(^DPT(BSDXIEN,.36),U,3) ;PID
        . . S Y=$P(BSDXDPT,U,3) X ^DD("DD")
        . . S $P(BSDXZ,BSDXDLIM,4)=Y ;DOB
        . . S $P(BSDXZ,BSDXDLIM,5)=BSDXIEN
        . . S BSDXRET=BSDXRET_BSDXZ_$C(30)
        . . Q
        . Q
           ;
SSN     ;SSN Lookup
        I (BSDXP?9N)!(BSDXP?3N1"-"2N1"-"4N),$D(^DPT("SSN",BSDXP)) D  S BSDXY=BSDXRET_$C(31) Q
        . S BSDXIEN=0 F  S BSDXIEN=$O(^DPT("SSN",BSDXP,BSDXIEN)) Q:'+BSDXIEN  D  Q
        . . Q:'$D(^DPT(BSDXIEN,0))
        . . S BSDXDPT=$G(^DPT(BSDXIEN,0))
        . . S BSDXZ=$P(BSDXDPT,U) ;NAME
        . . S BSDXHRN=$P($G(^AUPNPAT(BSDXIEN,41,DUZ(2),0)),U,2) ;CHART
        . . I BSDXHRN="" Q  ;NO CHART AT THIS DUZ2
        . . I $P($G(^AUPNPAT(BSDXIEN,41,DUZ(2),0)),U,3) S BSDXHRN=BSDXHRN_"(*)" Q  ;HMW 20050721 Record Inactivated
        . . S $P(BSDXZ,BSDXDLIM,2)=BSDXHRN
           . . S $P(BSDXZ,BSDXDLIM,3)=$P(^DPT(BSDXIEN,.36),U,3) ;PID
        . . S Y=$P(BSDXDPT,U,3) X ^DD("DD")
        . . S $P(BSDXZ,BSDXDLIM,4)=Y ;DOB
        . . S $P(BSDXZ,BSDXDLIM,5)=BSDXIEN
        . . S BSDXRET=BSDXRET_BSDXZ_$C(30)
        . . Q
        . Q
        ;
        S BSDXFILE=9000001
        S BSDXIENS=""
        S BSDXFIELDS=".01"
        S BSDXFLAGS="M"
        S BSDXVALUE=BSDXP
        S BSDXNUMBER=BSDXC
        S BSDXINDEXES=""
        S BSDXSCREEN=$S(+DUZ(2):"I $D(^AUPNPAT(Y,41,DUZ(2),0))",1:"")
        S BSDXIDEN=""
        S BSDXTARG="BSDXRSLT"
        S BSDXMSG=""
        D FIND^DIC(BSDXFILE,BSDXIENS,BSDXFIELDS,BSDXFLAGS,BSDXVALUE,BSDXNUMBER,BSDXINDEXES,BSDXSCREEN,BSDXIDEN,BSDXTARG,BSDXMSG)
        I '+$G(BSDXRSLT("DILIST",0)) S BSDXY=BSDXRET_$C(31) Q
        N BSDXCNT S BSDXCNT=2
        F BSDXX=1:1:$P(BSDXRSLT("DILIST",0),U) D
        . S BSDXIEN=BSDXRSLT("DILIST",2,BSDXX)
        . S BSDXZ=BSDXRSLT("DILIST","ID",BSDXX,.01) ;NAME
        . S BSDXHRN=$P($G(^AUPNPAT(BSDXIEN,41,DUZ(2),0)),U,2) ;CHART
        . I BSDXHRN="" Q  ;NO CHART AT THIS DUZ2
        . I $P($G(^AUPNPAT(BSDXIEN,41,DUZ(2),0)),U,3) S BSDXHRN=BSDXHRN_"(*)" Q  ;HMW 20050721 Record Inactivated
        . S $P(BSDXZ,BSDXDLIM,2)=BSDXHRN
        . S BSDXDPT=$G(^DPT(BSDXIEN,0))
           . S $P(BSDXZ,BSDXDLIM,3)=$P(^DPT(BSDXIEN,.36),U,3) ;PID
        . S Y=$P(BSDXDPT,U,3) X ^DD("DD")
        . S $P(BSDXZ,BSDXDLIM,4)=Y ;DOB
        . S $P(BSDXZ,BSDXDLIM,5)=BSDXIEN
        . S $P(BSDXRET,$C(30),BSDXCNT)=BSDXZ
        . S BSDXCNT=BSDXCNT+1
        . Q
        S BSDXY=BSDXRET_$C(30)_$C(31)
        Q
        ;
ERROR   ;
        D ERR("RPMS Error")
        Q
        ;
ERR(ERRNO)      ;Error processing
        S BSDXRET="T00030NAME^T00030HRN^T00030SSN^D00030DOB^T00030IEN"_$C(30)_"^^^^"_$C(30)_$C(31)
        Q