IBCSC9 ;ALB/BI - MCCR SCREEN 9 (AMBULANCE INFO) ;11 MAY 2011 10:20
;;2.0;INTEGRATED BILLING;**52,51,447,473,577,592**;11-MAY-2011;Build 58
;;Per VA Directive 6402, this routine should not be modified.
;
EN ; Main Entry Point
;JWS;IB*2.0*592;skip screen 9 for Dental
I $$FT^IBCEF(IBIFN)=7 G EN^IBCSC10
N IBACI,IBACIX,IB,IBT
D ^IBCSCU
S IBT=$P($G(^DGCR(399,IBIFN,0)),U,19)
S IBSR=9,IBSR1="",IBV1=$S(IBT=3:"11",IBV:"11",1:"00")
S IB("U")=$G(^DGCR(399,IBIFN,"U"))
S IB("U1")=$G(^DGCR(399,IBIFN,"U1"))
S IB("U4")=$G(^DGCR(399,IBIFN,"U4"))
S IB("U5")=$G(^DGCR(399,IBIFN,"U5"))
S IB("U6")=$G(^DGCR(399,IBIFN,"U6"))
S IB("U7")=$G(^DGCR(399,IBIFN,"U7"))
S IB("U8")=$G(^DGCR(399,IBIFN,"U8"))
M IB("U9")=^DGCR(399,IBIFN,"U9")
D H^IBCSCU
S Z=1,IBW=1 X IBWW W " Ambulance Transport Data"
;JRA IB*2.0*577 Rearrange Field order so that expanded 55 char PU/DO Address1 & PU/DO Address2 can be displayed
;W !,?41,"D/O Location: ",$P(IB("U6"),U) ;JRA ';' IB*2.0*577
;W !,?4,"P/U Address1: ",$P(IB("U5"),U,2),?41,"D/O Address1: ",$P(IB("U6"),U,2) ;JRA IB*2.0*577 ';'
;W !,?4,"P/U Address2: ",$P(IB("U5"),U,3),?41,"D/O Address2: ",$P(IB("U6"),U,3) ;JRA IB*2.0*577 ';'
;W !,?4,"P/U City: ",$P(IB("U5"),U,4),?41,"D/O City: ",$P(IB("U6"),U,4) ;JRA IB*2.0*577 ';'
;W !,?4,"P/U State/Zip: " W:$P(IB("U5"),U,5)'="" $P($G(^DIC(5,$P(IB("U5"),U,5),0)),U,2) ;JRA IB*2.0*577 ';'
;W:$P(IB("U5"),U,6)]"" "/"_$P(IB("U5"),U,6) ;JRA IB*2.0*577 ';'
;W ?41,"D/O State/Zip: " W:$P(IB("U6"),U,5)'="" $P($G(^DIC(5,$P(IB("U6"),U,5),0)),U,2) ;JRA IB*2.0*577 ';'
W !,?4,"P/U Address1: ",$P(IB("U5"),U,2) ;JRA IB*2.0*577
W !,?4,"P/U Address2: ",$P(IB("U5"),U,3) ;JRA IB*2.0*577
W !,?4,"P/U City: ",$P(IB("U5"),U,4) ;JRA IB*2.0*577
W ?41,"P/U State/Zip: " W:$P(IB("U5"),U,5)'="" $P($G(^DIC(5,$P(IB("U5"),U,5),0)),U,2) ;JRA IB*2.0*577
W:$P(IB("U5"),U,6)]"" "/"_$P(IB("U5"),U,6) ;JRA IB*2.0*577
W !,?4,"D/O Location: ",$P(IB("U6"),U) ;JRA IB*2.0*577
W !,?4,"D/O Address1: ",$P(IB("U6"),U,2) ;JRA IB*2.0*577
W !,?4,"D/O Address2: ",$P(IB("U6"),U,3) ;JRA IB*2.0*577
W !,?4,"D/O City: ",$P(IB("U6"),U,4) ;JRA IB*2.0*577
W ?41,"D/O State/Zip: " W:$P(IB("U6"),U,5)'="" $P($G(^DIC(5,$P(IB("U6"),U,5),0)),U,2) ;JRA IB*2.0*577
W:$P(IB("U6"),U,6)]"" "/"_$P(IB("U6"),U,6)
W !,?4,"Patient Weight: ",$P(IB("U7"),U,1),?41,"Transport Distance: ",$P(IB("U7"),U,3)
W !,?4,"Transport Reason: " I $P(IB("U7"),U,2)'="" D IBWP($$GET1^DIQ(353.4,$P(IB("U7"),U,2)_",",.02),22,55)
W !,?4,"R/T Purpose: " D IBWP($P(IB("U7"),U,4),17,60)
W !,?4,"Stretcher Purpose: " D IBWP($P(IB("U7"),U,5),23,54)
S Z=2,IBW=2 X IBWW W " Ambulance Certification Data"
W !,?4,"Condition Indicator:"
S IBACIX=0
F S IBACIX=$O(IB("U9",IBACIX)) Q:+IBACIX=0 D
. S IBACI=IB("U9",IBACIX,0)
. W ?25,$$GET1^DIQ(353.5,IBACI_",",.01)," - ",$$GET1^DIQ(353.5,IBACI_",",.02),!
K IB("U9")
W !
G ^IBCSCP
Q
;
IBWP(IBX,IBLM,IBRM) ;
K ^UTILITY($J,"W")
N X,Y,DIWF,DIWL,DIWR S X=IBX
S DIWL=1,DIWR=IBRM,DIWF="" D ^DIWP
I $D(^UTILITY($J,"W")) S Y=0 F S Y=$O(^UTILITY($J,"W",1,Y)) Q:'Y W:Y>1 !,?(IBLM) W $G(^UTILITY($J,"W",1,Y,0))
K ^UTILITY($J,"W")
Q
;
SCREEN1(DA1) ;
N A,RESPONSE S RESPONSE=0
I +$P($G(^DGCR(399,DA1,"U9",0)),U,4)<5 S RESPONSE=1 Q RESPONSE
S A(1,"F")="!?35",A(1)="Maximum of 5 Condition Indicators allowed"
D EN^DDIOL(.A)
Q RESPONSE
;IBCSC9
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCSC9 3400 printed Nov 22, 2024@17:30:31 Page 2
IBCSC9 ;ALB/BI - MCCR SCREEN 9 (AMBULANCE INFO) ;11 MAY 2011 10:20
+1 ;;2.0;INTEGRATED BILLING;**52,51,447,473,577,592**;11-MAY-2011;Build 58
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
EN ; Main Entry Point
+1 ;JWS;IB*2.0*592;skip screen 9 for Dental
+2 IF $$FT^IBCEF(IBIFN)=7
GOTO EN^IBCSC10
+3 NEW IBACI,IBACIX,IB,IBT
+4 DO ^IBCSCU
+5 SET IBT=$PIECE($GET(^DGCR(399,IBIFN,0)),U,19)
+6 SET IBSR=9
SET IBSR1=""
SET IBV1=$SELECT(IBT=3:"11",IBV:"11",1:"00")
+7 SET IB("U")=$GET(^DGCR(399,IBIFN,"U"))
+8 SET IB("U1")=$GET(^DGCR(399,IBIFN,"U1"))
+9 SET IB("U4")=$GET(^DGCR(399,IBIFN,"U4"))
+10 SET IB("U5")=$GET(^DGCR(399,IBIFN,"U5"))
+11 SET IB("U6")=$GET(^DGCR(399,IBIFN,"U6"))
+12 SET IB("U7")=$GET(^DGCR(399,IBIFN,"U7"))
+13 SET IB("U8")=$GET(^DGCR(399,IBIFN,"U8"))
+14 MERGE IB("U9")=^DGCR(399,IBIFN,"U9")
+15 DO H^IBCSCU
+16 SET Z=1
SET IBW=1
XECUTE IBWW
WRITE " Ambulance Transport Data"
+17 ;JRA IB*2.0*577 Rearrange Field order so that expanded 55 char PU/DO Address1 & PU/DO Address2 can be displayed
+18 ;W !,?41,"D/O Location: ",$P(IB("U6"),U) ;JRA ';' IB*2.0*577
+19 ;W !,?4,"P/U Address1: ",$P(IB("U5"),U,2),?41,"D/O Address1: ",$P(IB("U6"),U,2) ;JRA IB*2.0*577 ';'
+20 ;W !,?4,"P/U Address2: ",$P(IB("U5"),U,3),?41,"D/O Address2: ",$P(IB("U6"),U,3) ;JRA IB*2.0*577 ';'
+21 ;W !,?4,"P/U City: ",$P(IB("U5"),U,4),?41,"D/O City: ",$P(IB("U6"),U,4) ;JRA IB*2.0*577 ';'
+22 ;W !,?4,"P/U State/Zip: " W:$P(IB("U5"),U,5)'="" $P($G(^DIC(5,$P(IB("U5"),U,5),0)),U,2) ;JRA IB*2.0*577 ';'
+23 ;W:$P(IB("U5"),U,6)]"" "/"_$P(IB("U5"),U,6) ;JRA IB*2.0*577 ';'
+24 ;W ?41,"D/O State/Zip: " W:$P(IB("U6"),U,5)'="" $P($G(^DIC(5,$P(IB("U6"),U,5),0)),U,2) ;JRA IB*2.0*577 ';'
+25 ;JRA IB*2.0*577
WRITE !,?4,"P/U Address1: ",$PIECE(IB("U5"),U,2)
+26 ;JRA IB*2.0*577
WRITE !,?4,"P/U Address2: ",$PIECE(IB("U5"),U,3)
+27 ;JRA IB*2.0*577
WRITE !,?4,"P/U City: ",$PIECE(IB("U5"),U,4)
+28 ;JRA IB*2.0*577
WRITE ?41,"P/U State/Zip: "
if $PIECE(IB("U5"),U,5)'=""
WRITE $PIECE($GET(^DIC(5,$PIECE(IB("U5"),U,5),0)),U,2)
+29 ;JRA IB*2.0*577
if $PIECE(IB("U5"),U,6)]""
WRITE "/"_$PIECE(IB("U5"),U,6)
+30 ;JRA IB*2.0*577
WRITE !,?4,"D/O Location: ",$PIECE(IB("U6"),U)
+31 ;JRA IB*2.0*577
WRITE !,?4,"D/O Address1: ",$PIECE(IB("U6"),U,2)
+32 ;JRA IB*2.0*577
WRITE !,?4,"D/O Address2: ",$PIECE(IB("U6"),U,3)
+33 ;JRA IB*2.0*577
WRITE !,?4,"D/O City: ",$PIECE(IB("U6"),U,4)
+34 ;JRA IB*2.0*577
WRITE ?41,"D/O State/Zip: "
if $PIECE(IB("U6"),U,5)'=""
WRITE $PIECE($GET(^DIC(5,$PIECE(IB("U6"),U,5),0)),U,2)
+35 if $PIECE(IB("U6"),U,6)]""
WRITE "/"_$PIECE(IB("U6"),U,6)
+36 WRITE !,?4,"Patient Weight: ",$PIECE(IB("U7"),U,1),?41,"Transport Distance: ",$PIECE(IB("U7"),U,3)
+37 WRITE !,?4,"Transport Reason: "
IF $PIECE(IB("U7"),U,2)'=""
DO IBWP($$GET1^DIQ(353.4,$PIECE(IB("U7"),U,2)_",",.02),22,55)
+38 WRITE !,?4,"R/T Purpose: "
DO IBWP($PIECE(IB("U7"),U,4),17,60)
+39 WRITE !,?4,"Stretcher Purpose: "
DO IBWP($PIECE(IB("U7"),U,5),23,54)
+40 SET Z=2
SET IBW=2
XECUTE IBWW
WRITE " Ambulance Certification Data"
+41 WRITE !,?4,"Condition Indicator:"
+42 SET IBACIX=0
+43 FOR
SET IBACIX=$ORDER(IB("U9",IBACIX))
if +IBACIX=0
QUIT
Begin DoDot:1
+44 SET IBACI=IB("U9",IBACIX,0)
+45 WRITE ?25,$$GET1^DIQ(353.5,IBACI_",",.01)," - ",$$GET1^DIQ(353.5,IBACI_",",.02),!
End DoDot:1
+46 KILL IB("U9")
+47 WRITE !
+48 GOTO ^IBCSCP
+49 QUIT
+50 ;
IBWP(IBX,IBLM,IBRM) ;
+1 KILL ^UTILITY($JOB,"W")
+2 NEW X,Y,DIWF,DIWL,DIWR
SET X=IBX
+3 SET DIWL=1
SET DIWR=IBRM
SET DIWF=""
DO ^DIWP
+4 IF $DATA(^UTILITY($JOB,"W"))
SET Y=0
FOR
SET Y=$ORDER(^UTILITY($JOB,"W",1,Y))
if 'Y
QUIT
if Y>1
WRITE !,?(IBLM)
WRITE $GET(^UTILITY($JOB,"W",1,Y,0))
+5 KILL ^UTILITY($JOB,"W")
+6 QUIT
+7 ;
SCREEN1(DA1) ;
+1 NEW A,RESPONSE
SET RESPONSE=0
+2 IF +$PIECE($GET(^DGCR(399,DA1,"U9",0)),U,4)<5
SET RESPONSE=1
QUIT RESPONSE
+3 SET A(1,"F")="!?35"
SET A(1)="Maximum of 5 Condition Indicators allowed"
+4 DO EN^DDIOL(.A)
+5 QUIT RESPONSE
+6 ;IBCSC9
