- 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
