BSDSCRPC ; IHS/ANMC/LJF - MODS TO PCMM RPC CALLS ;
;;5.3;PIMS;;APR 26, 2002
;
PTLOOKUP(BSDV,BSDC) ;EP; called by FINDP^SCUTBK11 for IHS patient lookup
; uses code that converts answer to what SCUTBK11 wants
;
; BSDV = input value sent
; BSDC = count of values to return
;
NEW BSDA,I,X,Y
D LOOKUP(.BSDA,.BSDV,.BSDC)
K ^TMP("DILIST",$J)
F I=2:1 S Y=$P(BSDA,$C(30),I) Q:Y=$C(31) D
. ; convert name^hrcn^ssn^dob^ien to ien^name^dob hrcn^pt id
. S X=$P(Y,U,5)_U_$P(Y,U)_U_$P(Y,U,4)_$J($P(Y,U,2),10)_U_$P(Y,U,2)
. S ^TMP("DILIST",$J,I-1,0)=X
Q
;
LOOKUP(BSDY,BSDP,BSDC) ; Patient Lookup
;code blatently stolen from Horace Whitt (PTLOOKRS^BMXRPC4)
;
;Find up to BSDC patients matching BSDP*
;Supports DOB Lookup, SSN Lookup
;
S BSDP=$TR(BSDP,$C(13),"")
S BSDP=$TR(BSDP,$C(10),"")
S BSDP=$TR(BSDP,$C(9),"")
S:BSDC="" BSDC=10
N BSDHRN,BSDZ,BSDDLIM,BSDRET
S BSDDLIM="^"
S BSDRET="T00030NAME^T00030HRN^T00030SSN^D00030DOB^T00030IEN"_$C(30)
I '+$G(DUZ) S BSDY=BSDRET_$C(31) Q
I '$D(DUZ(2)) S BSDY=BSDRET_$C(31) Q
;
DOB ;DOB Lookup
I +DUZ(2),((BSDP?1.2N1"/"1.2N1"/"1.4N)!(BSDP?1.2N1" "1.2N1" "1.4N)!(BSDP?1.2N1"-"1.2N1"-"1.4N)) D S BSDY=BSDRET_$C(31) Q
. S X=BSDP S %DT="P" D ^%DT S BSDP=Y Q:'+Y
. Q:'$D(^DPT("ADOB",BSDP))
. S BSDIEN=0,BSDXX=1 F S BSDIEN=$O(^DPT("ADOB",BSDP,BSDIEN)) Q:'+BSDIEN D
. . Q:'$D(^DPT(BSDIEN,0))
. . S BSDDPT=$G(^DPT(BSDIEN,0))
. . S BSDZ=$P(BSDDPT,U) ;NAME
. . S BSDHRN=$P($G(^AUPNPAT(BSDIEN,41,DUZ(2),0)),U,2) ;CHART
. . I BSDHRN="" Q ;NO CHART AT THIS DUZ2
. . I $P($G(^AUPNPAT(BSDIEN,41,DUZ(2),0)),U,3) S BSDHRN=BSDHRN_"(*)"
. . S $P(BSDZ,BSDDLIM,2)=BSDHRN
. . ;
. . S $P(BSDZ,BSDDLIM,3)=$P(BSDDPT,U,9) ;SSN
. . S Y=$P(BSDDPT,U,3) X ^DD("DD")
. . S $P(BSDZ,BSDDLIM,4)=Y ;DOB
. . S $P(BSDZ,BSDDLIM,5)=BSDIEN
. . S BSDXX=BSDXX+1
. . S BSDRET=BSDRET_BSDZ_$C(30)
. . Q
. Q
;
;Chart# Lookup
I +DUZ(2),BSDP]"",$D(^AUPNPAT("D",BSDP)) D S BSDY=BSDRET_$C(30)_$C(31) Q
. S BSDIEN=0 F S BSDIEN=$O(^AUPNPAT("D",BSDP,BSDIEN)) Q:'+BSDIEN I $D(^AUPNPAT("D",BSDP,BSDIEN,DUZ(2))) D Q
. . Q:'$D(^DPT(BSDIEN,0))
. . S BSDDPT=$G(^DPT(BSDIEN,0))
. . S BSDZ=$P(BSDDPT,U) ;NAME
. . S BSDHRN=BSDP ;CHART
. . I $D(^AUPNPAT(BSDIEN,41,DUZ(2),0)),$P(^(0),U,3) S BSDHRN=BSDHRN_"(*)"
. . S $P(BSDZ,BSDDLIM,2)=BSDHRN
. . S $P(BSDZ,BSDDLIM,3)=$P(BSDDPT,U,9) ;SSN
. . S Y=$P(BSDDPT,U,3) X ^DD("DD")
. . S $P(BSDZ,BSDDLIM,4)=Y ;DOB
. . S $P(BSDZ,BSDDLIM,5)=BSDIEN
. . S $P(BSDRET,$C(30),2)=BSDZ
. . Q
. Q
;
;SSN Lookup
I (BSDP?9N)!(BSDP?3N1"-"2N1"-"4N),$D(^DPT("SSN",BSDP)) D S BSDY=BSDRET_$C(30)_$C(31) Q
. S BSDIEN=0 F S BSDIEN=$O(^DPT("SSN",BSDP,BSDIEN)) Q:'+BSDIEN D Q
. . Q:'$D(^DPT(BSDIEN,0))
. . S BSDDPT=$G(^DPT(BSDIEN,0))
. . S BSDZ=$P(BSDDPT,U) ;NAME
. . S BSDHRN=$P($G(^AUPNPAT(BSDIEN,41,DUZ(2),0)),U,2) ;CHART
. . I BSDHRN="" Q ;NO CHART AT THIS DUZ2
. . I $P($G(^AUPNPAT(BSDIEN,41,DUZ(2),0)),U,3) S BSDHRN=BSDHRN_"(*)"
. . S $P(BSDZ,BSDDLIM,2)=BSDHRN
. . S $P(BSDZ,BSDDLIM,3)=$P(BSDDPT,U,9) ;SSN
. . S Y=$P(BSDDPT,U,3) X ^DD("DD")
. . S $P(BSDZ,BSDDLIM,4)=Y ;DOB
. . S $P(BSDZ,BSDDLIM,5)=BSDIEN
. . S $P(BSDRET,$C(30),2)=BSDZ
. . Q
. Q
;
S BSDFILE=9000001
S BSDIENS=""
S BSDFIELD=".01"
S BSDFLAGS="M"
S BSDVALUE=BSDP
S BSDNUMBR=BSDC
S BSDINDEX=""
S BSDSCREN=$S(+DUZ(2):"I $D(^AUPNPAT(Y,41,DUZ(2),0))",1:"")
S BSDIDEN=""
S BSDTARG="BSDRSLT"
S BSDMSG=""
D FIND^DIC(BSDFILE,BSDIENS,BSDFIELD,BSDFLAGS,BSDVALUE,BSDNUMBR,BSDINDEX,BSDSCREN,BSDIDEN,BSDTARG,BSDMSG)
I '+$G(BSDRSLT("DILIST",0)) S BSDY=BSDRET_$C(31) Q
F BSDX=1:1:$P(BSDRSLT("DILIST",0),U) D
. S BSDIEN=BSDRSLT("DILIST",2,BSDX)
. S BSDZ=BSDRSLT("DILIST","ID",BSDX,.01) ;NAME
. S BSDHRN=$P($G(^AUPNPAT(BSDIEN,41,DUZ(2),0)),U,2) ;CHART
. I BSDHRN="" Q ;NO CHART AT THIS DUZ2
. I $P($G(^AUPNPAT(BSDIEN,41,DUZ(2),0)),U,3) S BSDHRN=BSDHRN_"(*)"
. S $P(BSDZ,BSDDLIM,2)=BSDHRN
. S BSDDPT=$G(^DPT(BSDIEN,0))
. S $P(BSDZ,BSDDLIM,3)=$P(BSDDPT,U,9) ;SSN
. S Y=$P(BSDDPT,U,3) X ^DD("DD")
. S $P(BSDZ,BSDDLIM,4)=Y ;DOB
. S $P(BSDZ,BSDDLIM,5)=BSDIEN
. S $P(BSDRET,$C(30),BSDX+1)=BSDZ
. Q
S BSDY=BSDRET_$C(30)_$C(31)
Q
BSDSCRPC ; IHS/ANMC/LJF - MODS TO PCMM RPC CALLS ;
+1 ;;5.3;PIMS;;APR 26, 2002
+2 ;
PTLOOKUP(BSDV,BSDC) ;EP; called by FINDP^SCUTBK11 for IHS patient lookup
+1 ; uses code that converts answer to what SCUTBK11 wants
+2 ;
+3 ; BSDV = input value sent
+4 ; BSDC = count of values to return
+5 ;
+6 NEW BSDA,I,X,Y
+7 DO LOOKUP(.BSDA,.BSDV,.BSDC)
+8 KILL ^TMP("DILIST",$JOB)
+9 FOR I=2:1
SET Y=$PIECE(BSDA,$CHAR(30),I)
IF Y=$CHAR(31)
QUIT
Begin DoDot:1
+10 ; convert name^hrcn^ssn^dob^ien to ien^name^dob hrcn^pt id
+11 SET X=$PIECE(Y,U,5)_U_$PIECE(Y,U)_U_$PIECE(Y,U,4)_$JUSTIFY($PIECE(Y,U,2),10)_U_$PIECE(Y,U,2)
+12 SET ^TMP("DILIST",$JOB,I-1,0)=X
End DoDot:1
+13 QUIT
+14 ;
LOOKUP(BSDY,BSDP,BSDC) ; Patient Lookup
+1 ;code blatently stolen from Horace Whitt (PTLOOKRS^BMXRPC4)
+2 ;
+3 ;Find up to BSDC patients matching BSDP*
+4 ;Supports DOB Lookup, SSN Lookup
+5 ;
+6 SET BSDP=$TRANSLATE(BSDP,$CHAR(13),"")
+7 SET BSDP=$TRANSLATE(BSDP,$CHAR(10),"")
+8 SET BSDP=$TRANSLATE(BSDP,$CHAR(9),"")
+9 IF BSDC=""
SET BSDC=10
+10 NEW BSDHRN,BSDZ,BSDDLIM,BSDRET
+11 SET BSDDLIM="^"
+12 SET BSDRET="T00030NAME^T00030HRN^T00030SSN^D00030DOB^T00030IEN"_$CHAR(30)
+13 IF '+$GET(DUZ)
SET BSDY=BSDRET_$CHAR(31)
QUIT
+14 IF '$DATA(DUZ(2))
SET BSDY=BSDRET_$CHAR(31)
QUIT
+15 ;
DOB ;DOB Lookup
+1 IF +DUZ(2)
IF ((BSDP?1.2N1"/"1.2N1"/"1.4N)!(BSDP?1.2N1" "1.2N1" "1.4N)!(BSDP?1.2N1"-"1.2N1"-"1.4N))
Begin DoDot:1
+2 SET X=BSDP
SET %DT="P"
DO ^%DT
SET BSDP=Y
IF '+Y
QUIT
+3 IF '$DATA(^DPT("ADOB",BSDP))
QUIT
+4 SET BSDIEN=0
SET BSDXX=1
FOR
SET BSDIEN=$ORDER(^DPT("ADOB",BSDP,BSDIEN))
IF '+BSDIEN
QUIT
Begin DoDot:2
+5 IF '$DATA(^DPT(BSDIEN,0))
QUIT
+6 SET BSDDPT=$GET(^DPT(BSDIEN,0))
+7 ;NAME
SET BSDZ=$PIECE(BSDDPT,U)
+8 ;CHART
SET BSDHRN=$PIECE($GET(^AUPNPAT(BSDIEN,41,DUZ(2),0)),U,2)
+9 ;NO CHART AT THIS DUZ2
IF BSDHRN=""
QUIT
+10 IF $PIECE($GET(^AUPNPAT(BSDIEN,41,DUZ(2),0)),U,3)
SET BSDHRN=BSDHRN_"(*)"
+11 SET $PIECE(BSDZ,BSDDLIM,2)=BSDHRN
+12 ;
+13 ;SSN
SET $PIECE(BSDZ,BSDDLIM,3)=$PIECE(BSDDPT,U,9)
+14 SET Y=$PIECE(BSDDPT,U,3)
XECUTE ^DD("DD")
+15 ;DOB
SET $PIECE(BSDZ,BSDDLIM,4)=Y
+16 SET $PIECE(BSDZ,BSDDLIM,5)=BSDIEN
+17 SET BSDXX=BSDXX+1
+18 SET BSDRET=BSDRET_BSDZ_$CHAR(30)
+19 QUIT
End DoDot:2
+20 QUIT
End DoDot:1
SET BSDY=BSDRET_$CHAR(31)
QUIT
+21 ;
+22 ;Chart# Lookup
+23 IF +DUZ(2)
IF BSDP]""
IF $DATA(^AUPNPAT("D",BSDP))
Begin DoDot:1
+24 SET BSDIEN=0
FOR
SET BSDIEN=$ORDER(^AUPNPAT("D",BSDP,BSDIEN))
IF '+BSDIEN
QUIT
IF $DATA(^AUPNPAT("D",BSDP,BSDIEN,DUZ(2)))
Begin DoDot:2
+25 IF '$DATA(^DPT(BSDIEN,0))
QUIT
+26 SET BSDDPT=$GET(^DPT(BSDIEN,0))
+27 ;NAME
SET BSDZ=$PIECE(BSDDPT,U)
+28 ;CHART
SET BSDHRN=BSDP
+29 IF $DATA(^AUPNPAT(BSDIEN,41,DUZ(2),0))
IF $PIECE(^(0),U,3)
SET BSDHRN=BSDHRN_"(*)"
+30 SET $PIECE(BSDZ,BSDDLIM,2)=BSDHRN
+31 ;SSN
SET $PIECE(BSDZ,BSDDLIM,3)=$PIECE(BSDDPT,U,9)
+32 SET Y=$PIECE(BSDDPT,U,3)
XECUTE ^DD("DD")
+33 ;DOB
SET $PIECE(BSDZ,BSDDLIM,4)=Y
+34 SET $PIECE(BSDZ,BSDDLIM,5)=BSDIEN
+35 SET $PIECE(BSDRET,$CHAR(30),2)=BSDZ
+36 QUIT
End DoDot:2
QUIT
+37 QUIT
End DoDot:1
SET BSDY=BSDRET_$CHAR(30)_$CHAR(31)
QUIT
+38 ;
+39 ;SSN Lookup
+40 IF (BSDP?9N)!(BSDP?3N1"-"2N1"-"4N)
IF $DATA(^DPT("SSN",BSDP))
Begin DoDot:1
+41 SET BSDIEN=0
FOR
SET BSDIEN=$ORDER(^DPT("SSN",BSDP,BSDIEN))
IF '+BSDIEN
QUIT
Begin DoDot:2
+42 IF '$DATA(^DPT(BSDIEN,0))
QUIT
+43 SET BSDDPT=$GET(^DPT(BSDIEN,0))
+44 ;NAME
SET BSDZ=$PIECE(BSDDPT,U)
+45 ;CHART
SET BSDHRN=$PIECE($GET(^AUPNPAT(BSDIEN,41,DUZ(2),0)),U,2)
+46 ;NO CHART AT THIS DUZ2
IF BSDHRN=""
QUIT
+47 IF $PIECE($GET(^AUPNPAT(BSDIEN,41,DUZ(2),0)),U,3)
SET BSDHRN=BSDHRN_"(*)"
+48 SET $PIECE(BSDZ,BSDDLIM,2)=BSDHRN
+49 ;SSN
SET $PIECE(BSDZ,BSDDLIM,3)=$PIECE(BSDDPT,U,9)
+50 SET Y=$PIECE(BSDDPT,U,3)
XECUTE ^DD("DD")
+51 ;DOB
SET $PIECE(BSDZ,BSDDLIM,4)=Y
+52 SET $PIECE(BSDZ,BSDDLIM,5)=BSDIEN
+53 SET $PIECE(BSDRET,$CHAR(30),2)=BSDZ
+54 QUIT
End DoDot:2
QUIT
+55 QUIT
End DoDot:1
SET BSDY=BSDRET_$CHAR(30)_$CHAR(31)
QUIT
+56 ;
+57 SET BSDFILE=9000001
+58 SET BSDIENS=""
+59 SET BSDFIELD=".01"
+60 SET BSDFLAGS="M"
+61 SET BSDVALUE=BSDP
+62 SET BSDNUMBR=BSDC
+63 SET BSDINDEX=""
+64 SET BSDSCREN=$SELECT(+DUZ(2):"I $D(^AUPNPAT(Y,41,DUZ(2),0))",1:"")
+65 SET BSDIDEN=""
+66 SET BSDTARG="BSDRSLT"
+67 SET BSDMSG=""
+68 DO FIND^DIC(BSDFILE,BSDIENS,BSDFIELD,BSDFLAGS,BSDVALUE,BSDNUMBR,BSDINDEX,BSDSCREN,BSDIDEN,BSDTARG,BSDMSG)
+69 IF '+$GET(BSDRSLT("DILIST",0))
SET BSDY=BSDRET_$CHAR(31)
QUIT
+70 FOR BSDX=1:1:$PIECE(BSDRSLT("DILIST",0),U)
Begin DoDot:1
+71 SET BSDIEN=BSDRSLT("DILIST",2,BSDX)
+72 ;NAME
SET BSDZ=BSDRSLT("DILIST","ID",BSDX,.01)
+73 ;CHART
SET BSDHRN=$PIECE($GET(^AUPNPAT(BSDIEN,41,DUZ(2),0)),U,2)
+74 ;NO CHART AT THIS DUZ2
IF BSDHRN=""
QUIT
+75 IF $PIECE($GET(^AUPNPAT(BSDIEN,41,DUZ(2),0)),U,3)
SET BSDHRN=BSDHRN_"(*)"
+76 SET $PIECE(BSDZ,BSDDLIM,2)=BSDHRN
+77 SET BSDDPT=$GET(^DPT(BSDIEN,0))
+78 ;SSN
SET $PIECE(BSDZ,BSDDLIM,3)=$PIECE(BSDDPT,U,9)
+79 SET Y=$PIECE(BSDDPT,U,3)
XECUTE ^DD("DD")
+80 ;DOB
SET $PIECE(BSDZ,BSDDLIM,4)=Y
+81 SET $PIECE(BSDZ,BSDDLIM,5)=BSDIEN
+82 SET $PIECE(BSDRET,$CHAR(30),BSDX+1)=BSDZ
+83 QUIT
End DoDot:1
+84 SET BSDY=BSDRET_$CHAR(30)_$CHAR(31)
+85 QUIT
