BHLP03I ; cmi/anchorage/maw - BHL File Inbound PO3 Segment ;
;;3.01;BHL IHS Interfaces with GIS;**1,15**;JUN 01, 2002
;
;this routine will file the P03 event especially for the GIS/Pyxis
;interface
;
MAIN ;EP;-- this is the main routine driver
D M1
EOJ ;-- clean up the variables
K BHLDA,BHLTDT,BHLTPDT,BHLTYP,BHLTCD,BHLDES,BHLQTY,BHLPBY
K DD,DO,DIC,Y,BHLPT,BHLAMT
Q
M1 D PTLK
Q:'$G(BHLPT)
D PROCESS
Q
PTLK ;-- lookup the patient
S BHLR="PID"
S BHLLOC=$E($G(@BHLTMP@(1,3)),1,6)
S BHLPTCHT=+$G(@BHLTMP@(1,2))
N X,Y
S X=$G(@BHLTMP@(1,5))
S X=$P(X,U)_","_$P(X,U,2)_$S($P(X,U,3)]"":" "_$P(X,U,3),1:"")
X ^%ZOSF("UPPERCASE")
S BHLPTNAM=$P(Y,",")_","_$E($P(Y,",",2))
S BHLPTN2=Y
S BHLPT=""
I BHLPTCHT D
.S BHLPTDA=0
.F S BHLPTDA=$O(^AUPNPAT("D",BHLPTCHT,BHLPTDA)) Q:'BHLPTDA!$D(BHLQUIT) D
..I $G(^DPT(+BHLPTDA,0))[BHLPTNAM S BHLQUIT="",BHLPT=BHLPTDA Q
.K BHLQUIT
Q:$G(BHLPT)
S BHLPT=$O(^DPT("B",BHLPTN2,0))
I $O(^DPT("B",BHLPTN2,BHLPT)) S BHLPT=""
Q
;
PROCESS ;-- get the variables and file the data
N BHLDA,BHLTDT,BHLTPDT,BHLTYP,BHLDES,BHLQTY,BHLTAMT,BHLAMT,BHLTCD,BHLHCPC,BHLFSN,BHLHCPCX,BHLNDC
S BHLR="FT1"
S BHLTDT=$G(@BHLTMP@(1,4))
S BHLTPDT=$G(@BHLTMP@(1,5))
S BHLTYP=$G(@BHLTMP@(1,6))
S BHLDES=$G(@BHLTMP@(1,8))
S BHLQTY=+$G(@BHLTMP@(1,10))
S BHLTAMT=+$G(@BHLTMP@(1,11))/100
S BHLAMT=+$G(@BHLTMP@(1,12))/100
S BHLTCD=$P($G(@BHLTMP@(1,7)),U)
S BHLHCPC=""
S BHLDES=$P($G(@BHLTMP@(1,7)),U,2)
S BHLNDC=$TR(BHLTCD,"-","")
S:BHLNDC]"" BHLNDC=$O(^PSDRUG("NDC",BHLNDC,0))
S:BHLNDC BHLAMT=$P($G(^PSDRUG(+BHLNDC,660)),U,6)
S BHLFSN=$S(BHLTCD]"":$O(^PSDRUG("FSN",BHLTCD,0)),1:"")
S:BHLFSN BHLAMT=$P($G(^PSDRUG(+BHLFSN,660)),U,6)
D HCPC
K DD,DO,DR,DIC
S BHLDES=$S(BHLDES]"":BHLDES,1:"NO DESCRIPTION")
Q:BHLDES=""!'BHLPT
D NOW^%DTC
S DIC="^AUPNSUP("
S DIC(0)="L"
S X=$S(BHLDES]"":BHLDES,1:"NO DESCRIPTION")
S DIC("DR")=".02////"_$G(BHLPT)_";.03////"_$G(BHLTDT)_";.05////"_%_";1.01////"_$G(BHLTCD)_";1.03////"_$S($G(BHLNDC):BHLNDC,$G(BHLFSN):BHLFSN,1:"")_";.08////0"
S DIC("DR")=DIC("DR")_";2.01////"_$G(BHLDES)_";2.02////"_$G(BHLTPDT)
S DIC("DR")=DIC("DR")_";2.03////"_$G(BHLQTY)_";2.04////"_$G(BHLAMT)
S DIC("DR")=DIC("DR")_";2.05////"_$G(BHLHCPCX)_";2.06////270"
S DIC("DR")=DIC("DR")_";2.09////"_$G(BHLHCPC)
D FILE^DICN
K DIC
Q
;
HCPC ;PROCESS HCPC INFO
I $G(BHLHCPC)]"",$D(^ICPT("B",BHLHCPC)) D Q:BHLHCPCX
.S BHLHCPCX=$O(^ICPT("B",BHLHCPC,0))
Q:'$G(BHLTCD)
N X
S X=$O(^BCMTCA("B",BHLTCD,0))
S X=$P($G(^BCMTCA(+X,11)),U,2)
Q:'X
;S BHLHCPC=$P($$G(ICPT(X,0)),U) ;cmi/anch/maw 8/27/2007 orig line
S BHLHCPC=$P($$CPT^ICPTCOD(X),U,2) ;cmi/anch/maw 8/27/2007 code set versioning patch 15
S BHLHCPCX=X
Q
BHLP03I ; cmi/anchorage/maw - BHL File Inbound PO3 Segment ;
+1 ;;3.01;BHL IHS Interfaces with GIS;**1,15**;JUN 01, 2002
+2 ;
+3 ;this routine will file the P03 event especially for the GIS/Pyxis
+4 ;interface
+5 ;
MAIN ;EP;-- this is the main routine driver
+1 DO M1
EOJ ;-- clean up the variables
+1 KILL BHLDA,BHLTDT,BHLTPDT,BHLTYP,BHLTCD,BHLDES,BHLQTY,BHLPBY
+2 KILL DD,DO,DIC,Y,BHLPT,BHLAMT
+3 QUIT
M1 DO PTLK
+1 IF '$GET(BHLPT)
QUIT
+2 DO PROCESS
+3 QUIT
PTLK ;-- lookup the patient
+1 SET BHLR="PID"
+2 SET BHLLOC=$EXTRACT($GET(@BHLTMP@(1,3)),1,6)
+3 SET BHLPTCHT=+$GET(@BHLTMP@(1,2))
+4 NEW X,Y
+5 SET X=$GET(@BHLTMP@(1,5))
+6 SET X=$PIECE(X,U)_","_$PIECE(X,U,2)_$SELECT($PIECE(X,U,3)]"":" "_$PIECE(X,U,3),1:"")
+7 XECUTE ^%ZOSF("UPPERCASE")
+8 SET BHLPTNAM=$PIECE(Y,",")_","_$EXTRACT($PIECE(Y,",",2))
+9 SET BHLPTN2=Y
+10 SET BHLPT=""
+11 IF BHLPTCHT
Begin DoDot:1
+12 SET BHLPTDA=0
+13 FOR
SET BHLPTDA=$ORDER(^AUPNPAT("D",BHLPTCHT,BHLPTDA))
IF 'BHLPTDA!$DATA(BHLQUIT)
QUIT
Begin DoDot:2
+14 IF $GET(^DPT(+BHLPTDA,0))[BHLPTNAM
SET BHLQUIT=""
SET BHLPT=BHLPTDA
QUIT
End DoDot:2
+15 KILL BHLQUIT
End DoDot:1
+16 IF $GET(BHLPT)
QUIT
+17 SET BHLPT=$ORDER(^DPT("B",BHLPTN2,0))
+18 IF $ORDER(^DPT("B",BHLPTN2,BHLPT))
SET BHLPT=""
+19 QUIT
+20 ;
PROCESS ;-- get the variables and file the data
+1 NEW BHLDA,BHLTDT,BHLTPDT,BHLTYP,BHLDES,BHLQTY,BHLTAMT,BHLAMT,BHLTCD,BHLHCPC,BHLFSN,BHLHCPCX,BHLNDC
+2 SET BHLR="FT1"
+3 SET BHLTDT=$GET(@BHLTMP@(1,4))
+4 SET BHLTPDT=$GET(@BHLTMP@(1,5))
+5 SET BHLTYP=$GET(@BHLTMP@(1,6))
+6 SET BHLDES=$GET(@BHLTMP@(1,8))
+7 SET BHLQTY=+$GET(@BHLTMP@(1,10))
+8 SET BHLTAMT=+$GET(@BHLTMP@(1,11))/100
+9 SET BHLAMT=+$GET(@BHLTMP@(1,12))/100
+10 SET BHLTCD=$PIECE($GET(@BHLTMP@(1,7)),U)
+11 SET BHLHCPC=""
+12 SET BHLDES=$PIECE($GET(@BHLTMP@(1,7)),U,2)
+13 SET BHLNDC=$TRANSLATE(BHLTCD,"-","")
+14 IF BHLNDC]""
SET BHLNDC=$ORDER(^PSDRUG("NDC",BHLNDC,0))
+15 IF BHLNDC
SET BHLAMT=$PIECE($GET(^PSDRUG(+BHLNDC,660)),U,6)
+16 SET BHLFSN=$SELECT(BHLTCD]"":$ORDER(^PSDRUG("FSN",BHLTCD,0)),1:"")
+17 IF BHLFSN
SET BHLAMT=$PIECE($GET(^PSDRUG(+BHLFSN,660)),U,6)
+18 DO HCPC
+19 KILL DD,DO,DR,DIC
+20 SET BHLDES=$SELECT(BHLDES]"":BHLDES,1:"NO DESCRIPTION")
+21 IF BHLDES=""!'BHLPT
QUIT
+22 DO NOW^%DTC
+23 SET DIC="^AUPNSUP("
+24 SET DIC(0)="L"
+25 SET X=$SELECT(BHLDES]"":BHLDES,1:"NO DESCRIPTION")
+26 SET DIC("DR")=".02////"_$GET(BHLPT)_";.03////"_$GET(BHLTDT)_";.05////"_%_";1.01////"_$GET(BHLTCD)_";1.03////"_$SELECT($GET(BHLNDC):BHLNDC,$GET(BHLFSN):BHLFSN,1:"")_";.08////0"
+27 SET DIC("DR")=DIC("DR")_";2.01////"_$GET(BHLDES)_";2.02////"_$GET(BHLTPDT)
+28 SET DIC("DR")=DIC("DR")_";2.03////"_$GET(BHLQTY)_";2.04////"_$GET(BHLAMT)
+29 SET DIC("DR")=DIC("DR")_";2.05////"_$GET(BHLHCPCX)_";2.06////270"
+30 SET DIC("DR")=DIC("DR")_";2.09////"_$GET(BHLHCPC)
+31 DO FILE^DICN
+32 KILL DIC
+33 QUIT
+34 ;
HCPC ;PROCESS HCPC INFO
+1 IF $GET(BHLHCPC)]""
IF $DATA(^ICPT("B",BHLHCPC))
Begin DoDot:1
+2 SET BHLHCPCX=$ORDER(^ICPT("B",BHLHCPC,0))
End DoDot:1
IF BHLHCPCX
QUIT
+3 IF '$GET(BHLTCD)
QUIT
+4 NEW X
+5 SET X=$ORDER(^BCMTCA("B",BHLTCD,0))
+6 SET X=$PIECE($GET(^BCMTCA(+X,11)),U,2)
+7 IF 'X
QUIT
+8 ;S BHLHCPC=$P($$G(ICPT(X,0)),U) ;cmi/anch/maw 8/27/2007 orig line
+9 ;cmi/anch/maw 8/27/2007 code set versioning patch 15
SET BHLHCPC=$PIECE($$CPT^ICPTCOD(X),U,2)
+10 SET BHLHCPCX=X
+11 QUIT
