IBCSC4.m

IBCSC4	;ALB/MJB - MCCR SCREEN 4 (INPT. EOC)  ;27 MAY 88 10:17

	;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94

	;;Per VHA Directive 10-93-142, this routine should not be modified.

	;

	;MAP TO DGCRSC4

	;

EN	I $P(^DGCR(399,IBIFN,0),"^",5)>2 G EN^IBCSC5

	I $D(IBASKCOD) K IBASKCOD D CODMUL^IBCU7

	I $D(DGRVRCAL) D ^IBCU6 K DGRVRCAL

	L ^DGCR(399,IBIFN):1

	D ^IBCSCU S IBSR=4,IBSR1="",IBV1="00000000",IBUC="UNSPECIFIED CODE"

	S:IBV IBV1="11111111"

	D H^IBCSCU F I=1:1:4 S Y="Q"_I_"^IBCVA" D @Y

	D INP

	S IBBT=$P(IB(0),"^",4)_$P(IB(0),"^",5)_$P(IB(0),"^",6)

	D:DGPT(0)]"" DX^IBCSC4A D OCC^IBCVA1

	I '$P(DGPT(0),U,6) W !?26,$S('DGPT(0):"No PTF record for this ADMISSION",1:"PTF record status: OPEN")

	S Z=1 X IBWW W " Admission  : " S Y=$S($P(DGPT(0),U,2)]"":$P(DGPT(0),U,2),1:$P(IBIP,U,2)) X ^DD("DD") W Y,?49,"Accident Hour: ",$S($P(IB("U"),U,10)'="":$P(IB("U"),U,10),1:IBU)

	W !?4,"Source     : " S I=$P(^DD(399,159,0),U,3),I=$P($P(I,";",($P(IB("U"),U,9))),":",2) W I

	W ?58,"Type: ",$S($P(IB("U"),U,8)=3:"ELECTIVE",$P(IB("U"),U,8)=1:"EMERGENCY",$P(IB("U"),U,8)=2:"URGENT",1:IBU)

	S Z=2 X IBWW

	W " Discharge  : " S Y=$S($P(IBIP,U,6)>0:$P(IBIP,U,6),1:"") X ^DD("DD") W $S(Y]"":Y,1:IBU)

	W !?4,"Status     : ",$S($P(IB("U"),U,12)]""&($D(^DGCR(399.1,(+$P(IB("U"),"^",12)),0))):$P(^(0),"^",1),1:IBU)

	N IBPOARR D SET^IBCSC4D(IBIFN,"",.IBPOARR)

	S Z=3,IBW=1 X IBWW W " Prin. Diag.: " S Y=$$DX(0) W $S(Y'="":$P(Y,U,4)_" - "_$P(Y,U,2),1:IBUN)

	F I=1:1:4 S Y=$$DX(+Y) Q:Y=""  W !?4,"Other Diag.: ",$P(Y,U,4)_" - "_$P(Y,U,2)

	I +Y S Y=$$DX(+Y) I +Y W !?4,"***There are more diagnoses associated with this bill.***"

	;F I=15:1:18 I $P(IB("C"),U,I)]"" W !?4,"Other Diag.: ",$S($D(^ICD9($P(IB("C"),U,I),0)):$P(^(0),U,3)_" - "_$P(^(0),U,1),1:IBU)

	S Z=4,IBW=1,DGPCM=$P(IB(0),U,9) X IBWW W " Cod. Method: ",$S(DGPCM="":IBUN,DGPCM=9:"ICD-9-CM",DGPCM=4:"CPT-4",1:"HCPCS")

	D:$D(IBPROC) WRT^IBCSC5

	;I DGPCM="" W !?4,"Pro. Code  : ",IBUN G OCC

	;I $D(IBCPT),DGPCM=4 F I=1:1:3 I $D(IBCPT(I)) W !?4,"CPT Code   : ",$P(^ICPT(IBCPT(I),0),U,2)," - ",$P(^(0),U),?55,"Date: " S Y=$P(IB("C"),U,(I+10)) D DT^DIQ

	;I DGPCM=4 W:'$D(IBCPT) !?4,"Pro. Code  : ",IBUN G OCC

	;I $D(IBICD),DGPCM=9 F I=4:1:6 I $D(IBICD(I)) W !?4,"ICD Code   : ",$S($D(^ICD0(IBICD(I),0)):$E($P(^(0),U,4),1,20)_" - "_$P(^(0),U,1),1:IBUC),?55,"Date: " S Y=$P(IB("C"),U,(I+7)) D DT^DIQ

	;I DGPCM=9 W:'$D(IBICD) !?4,"Pro. Code  : ",IBUN G OCC

	;I $D(IBHC),DGPCM=5 F I=7:1:9 I $D(IBHC(I)) W !?4,"HCFA Code  : ",$P(^ICPT(IBHC(I),0),U,2)," - ",IBHCN(I),?55,"Date: " S Y=$P(IB("C"),U,(I+4)) D DT^DIQ

	;I DGPCM=5 W:'$D(IBHC) !?4,"Pro. Code  : ",IBUN

OCC	;I $O(^DGCR(399,IBIFN,"CP",0)) S I=0 F I1=1:1 S I=$O(^DGCR(399,IBIFN,"CP",I)) D:I1>9 MORE Q:'I  W !,?17 S Y=$P(^(I,0),"^",2) D:+Y D^DIQ D OCC1

	S Z=$S($P(IB(0),U,5)<3:5,1:6)

	S IBW=1 X IBWW W " Pros. Items: " S Y=$$PD^IBCSC5 I 'Y W IBUN

	S Z=$S($P(IB(0),U,5)<3:6,1:7) X IBWW

	W " Occ. Code  : " F I=1:1:5 I $D(IBO(I)) W:I>1 !?4,"Occ. Code  : ",$E(IBOCN(I),1,27) W:I=1 $E(IBOCN(I),1,27) S Y=IBOCD(I) X ^DD("DD") W ?55,Y S Y=IBOCD2(I) I +Y X ^DD("DD") W " - ",Y

	I '$D(IBO) W IBUN

	I $D(IBO)=1,IBO="" W IBUN

	S Z=$S($P(IB(0),U,5)<3:7,1:8) X IBWW

	W " Cond. Code : " F I=1:1:5 I $D(IBCC(I)) W:I>1 !?4,"Cond. Code : ",IBCCN(I) W:I=1 IBCCN(I)

	I '$D(IBCC) W IBUN

	I $D(IBCC)=1,IBCC="" W IBUN

	S Z=$S($P(IB(0),U,5)<3:8,1:9)

	X IBWW W " Value Code : " D VC^IBCVA1 I +IBVC S J=1,I=0 F  S I=$O(IBVC(I)) Q:'I  W:J>1 !,?3," Value Code : " W ?17,$E($P(IBVC(I),U,2),1,40),?58,$P(IBVC(I),U,3) S J=J+1

	W:'IBVC IBUN K IBVC

	D Q^IBCSC4B G ^IBCSCP

	Q

OCC1	W $P(^DGCR(399,IBIFN,"CP",I,0),"^",3)_" - "_$P(@(U_$P($P(^(0),"^"),";",2)_$P($P(^(0),"^"),";")_",0)"),"^"),?55,"Date: ",Y

	Q

	;IBIP= PTF ptr (399,.08) ^ PTF admiss dt (45,2) or Event dt (399,.03)^ accident hour (399,160) 

	; ^ source of addmis (399,159) ^ typ of addmiss (399,158)

	; ^ PTF disch dt (45,70) or Non-VA disch dt (399,.16) ^ disch status (399,162)

	; ^ dxls (45,79) ^ disch bedsection (399,161)

INP	F I="C","U",0 S IB(I)=$S($D(^DGCR(399,IBIFN,I)):^(I),1:"")

	S IBPTF=$P(IB(0),U,8) F I=0,70 S DGPT(I)=$S(IBPTF="":"",$D(^DGPT(IBPTF,I)):^(I),1:"")

	F I="C","U",0 S IB(I)=$S($D(^DGCR(399,IBIFN,I)):^(I),1:"")

	S IBIP=IBPTF_"^"_$S($P(DGPT(0),"^",2)]"":$P(DGPT(0),"^",2),1:$P(IB(0),"^",3))_"^"_$P(IB("U"),"^",10)_"^"_$P(IB("U"),"^",9)_"^"_$P(IB("U"),"^",8)_"^"_$S(+DGPT(70)>0:+DGPT(70),1:$P(IB(0),"^",16))_"^"

	S IBIP=IBIP_$P(IB("U"),"^",12)_"^"_$S($D(DGPT(70)):$P(DGPT(70),"^",10),1:"")_"^"_$P(IB("U"),"^",11)

	Q

	;IBCSC4

SET	;S ^DD(399.0304,0,"ID","WRITE")="N X S X=^(0) W ""   "",$E($P($G(@(U_$P($P(X,U),"";"",2)_+X_"",0)"")),U,$S($P(X,U,1)[""CPT"":2,1:4)),1,30)"

DX(ORDER)	;

	N IBX,IBY S IBX="" I $D(IBPOARR)>2 S ORDER=$O(IBPOARR(ORDER)) I +ORDER  S IBY=$G(^ICD9(+IBPOARR(ORDER),0)) I IBY'="" S IBX=ORDER_"^"_IBY

	Q IBX

IBCSC4    ;ALB/MJB - MCCR SCREEN 4 (INPT. EOC)  ;27 MAY 88 10:17

 +1       ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94

 +2       ;;Per VHA Directive 10-93-142, this routine should not be modified.

 +3       ;

 +4       ;MAP TO DGCRSC4

 +5       ;

EN         IF $PIECE(^DGCR(399,IBIFN,0),"^",5)>2

               GOTO EN^IBCSC5

 +1        IF $DATA(IBASKCOD)

               KILL IBASKCOD

               DO CODMUL^IBCU7

 +2        IF $DATA(DGRVRCAL)

               DO ^IBCU6

               KILL DGRVRCAL

 +3        LOCK ^DGCR(399,IBIFN):1

 +4        DO ^IBCSCU

           SET IBSR=4

           SET IBSR1=""

           SET IBV1="00000000"

           SET IBUC="UNSPECIFIED CODE"

 +5        IF IBV

               SET IBV1="11111111"

 +6        DO H^IBCSCU

           FOR I=1:1:4

               SET Y="Q"_I_"^IBCVA"

               DO @Y

 +7        DO INP

 +8        SET IBBT=$PIECE(IB(0),"^",4)_$PIECE(IB(0),"^",5)_$PIECE(IB(0),"^",6)

 +9        IF DGPT(0)]""

               DO DX^IBCSC4A

           DO OCC^IBCVA1

 +10       IF '$PIECE(DGPT(0),U,6)

               WRITE !?26,$SELECT('DGPT(0):"No PTF record for this ADMISSION",1:"PTF record status: OPEN")

 +11       SET Z=1

           XECUTE IBWW

           WRITE " Admission  : "

           SET Y=$SELECT($PIECE(DGPT(0),U,2)]"":$PIECE(DGPT(0),U,2),1:$PIECE(IBIP,U,2))

           XECUTE ^DD("DD")

           WRITE Y,?49,"Accident Hour: ",$SELECT($PIECE(IB("U"),U,10)'="":$PIECE(IB("U"),U,10),1:IBU)

 +12       WRITE !?4,"Source     : "

           SET I=$PIECE(^DD(399,159,0),U,3)

           SET I=$PIECE($PIECE(I,";",($PIECE(IB("U"),U,9))),":",2)

           WRITE I

 +13       WRITE ?58,"Type: ",$SELECT($PIECE(IB("U"),U,8)=3:"ELECTIVE",$PIECE(IB("U"),U,8)=1:"EMERGENCY",$PIECE(IB("U"),U,8)=2:"URGENT",1:IBU)

 +14       SET Z=2

           XECUTE IBWW

 +15       WRITE " Discharge  : "

           SET Y=$SELECT($PIECE(IBIP,U,6)>0:$PIECE(IBIP,U,6),1:"")

           XECUTE ^DD("DD")

           WRITE $SELECT(Y]"":Y,1:IBU)

 +16       WRITE !?4,"Status     : ",$SELECT($PIECE(IB("U"),U,12)]""&($DATA(^DGCR(399.1,(+$PIECE(IB("U"),"^",12)),0))):$PIECE(^(0),"^",1),1:IBU)

 +17       NEW IBPOARR

           DO SET^IBCSC4D(IBIFN,"",.IBPOARR)

 +18       SET Z=3

           SET IBW=1

           XECUTE IBWW

           WRITE " Prin. Diag.: "

           SET Y=$$DX(0)

           WRITE $SELECT(Y'="":$PIECE(Y,U,4)_" - "_$PIECE(Y,U,2),1:IBUN)

 +19       FOR I=1:1:4

               SET Y=$$DX(+Y)

               IF Y=""

                   QUIT 

               WRITE !?4,"Other Diag.: ",$PIECE(Y,U,4)_" - "_$PIECE(Y,U,2)

 +20       IF +Y

               SET Y=$$DX(+Y)

               IF +Y

                   WRITE !?4,"***There are more diagnoses associated with this bill.***"

 +21      ;F I=15:1:18 I $P(IB("C"),U,I)]"" W !?4,"Other Diag.: ",$S($D(^ICD9($P(IB("C"),U,I),0)):$P(^(0),U,3)_" - "_$P(^(0),U,1),1:IBU)

 +22       SET Z=4

           SET IBW=1

           SET DGPCM=$PIECE(IB(0),U,9)

           XECUTE IBWW

           WRITE " Cod. Method: ",$SELECT(DGPCM="":IBUN,DGPCM=9:"ICD-9-CM",DGPCM=4:"CPT-4",1:"HCPCS")

 +23       IF $DATA(IBPROC)

               DO WRT^IBCSC5

 +24      ;I DGPCM="" W !?4,"Pro. Code  : ",IBUN G OCC

 +25      ;I $D(IBCPT),DGPCM=4 F I=1:1:3 I $D(IBCPT(I)) W !?4,"CPT Code   : ",$P(^ICPT(IBCPT(I),0),U,2)," - ",$P(^(0),U),?55,"Date: " S Y=$P(IB("C"),U,(I+10)) D DT^DIQ

 +26      ;I DGPCM=4 W:'$D(IBCPT) !?4,"Pro. Code  : ",IBUN G OCC

 +27      ;I $D(IBICD),DGPCM=9 F I=4:1:6 I $D(IBICD(I)) W !?4,"ICD Code   : ",$S($D(^ICD0(IBICD(I),0)):$E($P(^(0),U,4),1,20)_" - "_$P(^(0),U,1),1:IBUC),?55,"Date: " S Y=$P(IB("C"),U,(I+7)) D DT^DIQ

 +28      ;I DGPCM=9 W:'$D(IBICD) !?4,"Pro. Code  : ",IBUN G OCC

 +29      ;I $D(IBHC),DGPCM=5 F I=7:1:9 I $D(IBHC(I)) W !?4,"HCFA Code  : ",$P(^ICPT(IBHC(I),0),U,2)," - ",IBHCN(I),?55,"Date: " S Y=$P(IB("C"),U,(I+4)) D DT^DIQ

 +30      ;I DGPCM=5 W:'$D(IBHC) !?4,"Pro. Code  : ",IBUN

OCC       ;I $O(^DGCR(399,IBIFN,"CP",0)) S I=0 F I1=1:1 S I=$O(^DGCR(399,IBIFN,"CP",I)) D:I1>9 MORE Q:'I  W !,?17 S Y=$P(^(I,0),"^",2) D:+Y D^DIQ D OCC1

 +1        SET Z=$SELECT($PIECE(IB(0),U,5)<3:5,1:6)

 +2        SET IBW=1

           XECUTE IBWW

           WRITE " Pros. Items: "

           SET Y=$$PD^IBCSC5

           IF 'Y

               WRITE IBUN

 +3        SET Z=$SELECT($PIECE(IB(0),U,5)<3:6,1:7)

           XECUTE IBWW

 +4        WRITE " Occ. Code  : "

           FOR I=1:1:5

               IF $DATA(IBO(I))

                   IF I>1

                       WRITE !?4,"Occ. Code  : ",$EXTRACT(IBOCN(I),1,27)

                   IF I=1

                       WRITE $EXTRACT(IBOCN(I),1,27)

                   SET Y=IBOCD(I)

                   XECUTE ^DD("DD")

                   WRITE ?55,Y

                   SET Y=IBOCD2(I)

                   IF +Y

                       XECUTE ^DD("DD")

                       WRITE " - ",Y

 +5        IF '$DATA(IBO)

               WRITE IBUN

 +6        IF $DATA(IBO)=1

               IF IBO=""

                   WRITE IBUN

 +7        SET Z=$SELECT($PIECE(IB(0),U,5)<3:7,1:8)

           XECUTE IBWW

 +8        WRITE " Cond. Code : "

           FOR I=1:1:5

               IF $DATA(IBCC(I))

                   IF I>1

                       WRITE !?4,"Cond. Code : ",IBCCN(I)

                   IF I=1

                       WRITE IBCCN(I)

 +9        IF '$DATA(IBCC)

               WRITE IBUN

 +10       IF $DATA(IBCC)=1

               IF IBCC=""

                   WRITE IBUN

 +11       SET Z=$SELECT($PIECE(IB(0),U,5)<3:8,1:9)

 +12       XECUTE IBWW

           WRITE " Value Code : "

           DO VC^IBCVA1

           IF +IBVC

               SET J=1

               SET I=0

               FOR 

                   SET I=$ORDER(IBVC(I))

                   IF 'I

                       QUIT 

                   IF J>1

                       WRITE !,?3," Value Code : "

                   WRITE ?17,$EXTRACT($PIECE(IBVC(I),U,2),1,40),?58,$PIECE(IBVC(I),U,3)

                   SET J=J+1

 +13       IF 'IBVC

               WRITE IBUN

           KILL IBVC

 +14       DO Q^IBCSC4B

           GOTO ^IBCSCP

 +15       QUIT 

OCC1       WRITE $PIECE(^DGCR(399,IBIFN,"CP",I,0),"^",3)_" - "_$PIECE(@(U_$PIECE($PIECE(^(0),"^"),";",2)_$PIECE($PIECE(^(0),"^"),";")_",0)"),"^"),?55,"Date: ",Y

 +1        QUIT 

 +2       ;IBIP= PTF ptr (399,.08) ^ PTF admiss dt (45,2) or Event dt (399,.03)^ accident hour (399,160) 

 +3       ; ^ source of addmis (399,159) ^ typ of addmiss (399,158)

 +4       ; ^ PTF disch dt (45,70) or Non-VA disch dt (399,.16) ^ disch status (399,162)

 +5       ; ^ dxls (45,79) ^ disch bedsection (399,161)

INP        FOR I="C","U",0

               SET IB(I)=$SELECT($DATA(^DGCR(399,IBIFN,I)):^(I),1:"")

 +1        SET IBPTF=$PIECE(IB(0),U,8)

           FOR I=0,70

               SET DGPT(I)=$SELECT(IBPTF="":"",$DATA(^DGPT(IBPTF,I)):^(I),1:"")

 +2        FOR I="C","U",0

               SET IB(I)=$SELECT($DATA(^DGCR(399,IBIFN,I)):^(I),1:"")

 +3        SET IBIP=IBPTF_"^"_$SELECT($PIECE(DGPT(0),"^",2)]"":$PIECE(DGPT(0),"^",2),1:$PIECE(IB(0),"^",3))_"^"_$PIECE(IB("U"),"^",10)_"^"_$PIECE(IB("U"),"^",9)_"^"_$PIECE(IB("U"),"^",8)_"^"_$SELECT(+DGPT(70)>0:+DGPT(70),1:$PIECE(IB(0),"^",16))_"^"

 +4        SET IBIP=IBIP_$PIECE(IB("U"),"^",12)_"^"_$SELECT($DATA(DGPT(70)):$PIECE(DGPT(70),"^",10),1:"")_"^"_$PIECE(IB("U"),"^",11)

 +5        QUIT 

 +6       ;IBCSC4

SET       ;S ^DD(399.0304,0,"ID","WRITE")="N X S X=^(0) W ""   "",$E($P($G(@(U_$P($P(X,U),"";"",2)_+X_"",0)"")),U,$S($P(X,U,1)[""CPT"":2,1:4)),1,30)"

DX(ORDER) ;

 +1        NEW IBX,IBY

           SET IBX=""

           IF $DATA(IBPOARR)>2

               SET ORDER=$ORDER(IBPOARR(ORDER))

               IF +ORDER

                   SET IBY=$GET(^ICD9(+IBPOARR(ORDER),0))

                   IF IBY'=""

                       SET IBX=ORDER_"^"_IBY

 +2        QUIT IBX