- IBCSC4B ;ALB/MJB - MCCR PTF SCREEN (CONT.) ;24 FEB 89 9:52
- ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
- ;;Per VHA Directive 10-93-142, this routine should not be modified.
- ;
- ;MAP TO DGCRSC4B
- ;
- DX Q:$S(IBPTF="":1,'$D(^DGPT(IBPTF,0)):1,1:0) S IBUC="UNSPECIFIED CODE",IBNC="NO DX CODES ENTERED FOR THIS DATE",IBDXC=0,X="DIAGNOSIS SCREEN" K IBWE,IBWO
- W @IOF,?(40-($L(X)\2)),X,! F I=1:1:79 W "="
- S IBDIA="" I '$D(^UTILITY($J,"IBDX")) W !!," * No DIAGNOSIS CODES in PTF record for this episode of care." D SELD^IBCSC4C G Q
- F I=1:1:13 S IBDIA=$O(^UTILITY($J,"IBDX",IBDIA)) Q:IBDIA="" D ODD^IBCSC4A S IBDIA=$O(^UTILITY($J,"IBDX",IBDIA)) D:IBDIA]"" EVEN^IBCSC4A D WR D:$Y+6>IOSL ASK Q:IBDIA=""
- S IBDIA="" ; D SELD^IBCSC4C
- G Q
- ;
- WR I '$D(IBWE(0)) F B=0:1:5 S IBWE(B)=""
- W !!,"Move: " S Y=$P(IBWO(0),U,2) X ^DD("DD") W $S($P(IBWO(0),U,4)]"":$P(IBWO(0),U,4)_" ",1:""),Y," " W:$P(IBWO(0),"^",3)]"" $E($P(^DIC(42.4,$P(IBWO(0),U,3),0),U),1,12) W " ",$P(IBWO(0),"^",5)
- I IBDIA]"",IBWE(0)]"" W ?43,"Move: " S Y=$P(IBWE(0),U,2) X ^DD("DD") W $S($P(IBWE(0),U,4)]"":$P(IBWE(0),U,4)_" ",1:""),Y," " W:$P(IBWE(0),"^",3)]"" $E($P(^DIC(42.4,$P(IBWE(0),U,3),0),U),1,12) W " ",$P(IBWE(0),"^",5)
- S IBAO=$P(IBWO(0),U,1) I IBAO']"" W:'$D(IBDXY) !,"* ",IBNC S IBDXY=1 F K=1:1:5 S IBWO(K)="" I IBDIA]"" W:K>1 ! D WE Q:IBWO(K)']""&(IBWE(K)']"")
- I IBAO]"" F K=1:1:5 Q:IBWO(K)']""&(IBWE(K)']"") S X=$S($D(^ICD9((+IBWO(K)),0)):^(0),1:"") W:IBWO(K)]"" !,IBAO,K," - ",$S(X]"":$J($P(X,U,1),6)_" "_$E($P(X,U,3),1,24),1:IBUC) W:IBWO(K)']"" !,"" D:IBDIA]"" WE
- Q
- WE S IBAE=$P(IBWE(0),U,1) I IBAE']"",'$D(IBDXX),IBWE(0)]"" W ?43,"* ",IBNC S (IBWE(1),IBWE(2),IBWE(3),IBWE(4),IBWE(5))="",IBDXX=1
- I IBAE]"",IBWE(K)]"" S X=$S($D(^ICD9((+IBWE(K)),0)):^(0),1:"") W ?43,IBAE,K," - ",$S(X]"":$J($P(X,U,1),6)_" "_$E($P(X,U,3),1,24),1:IBUC)
- Q
- ASK W !!,"<RETURN> to see more ",$S($D(IBP):"procedure",1:"diagnosis")," codes or '^' to QUIT: " R A:DTIME I '$T!(A["^") S:$D(IBDIA) IBDIA="" S:$D(IBP) IBP="" Q
- I A["?" W !!?4,"Enter <RETURN> to view more ",$S($D(IBP):"operation/procedure",1:"movement dates and diagnosis")," codes",!?4,"or '^' to stop the display." G ASK
- S A=$S($D(IBP):"OPERATION/PROCEDURE",1:"DIAGNOSIS")_" SCREEN (CONT.)" W !,@IOF,?(40-($L(A)\2)),A,! F S=1:1:79 W "="
- Q
- PRO Q:'$D(IBPTF) S IBUC="UNSPECIFIED CODE",IBNC="NO PRO CODES ENTERED FOR THIS DATE",IBOPC=0,X="OPERATION/PROCEDURE SCREEN",IBNOR="Non-O/R Procedure Date: ",IBSD="Surgery Date: "
- K IBWE,IBWO
- W @IOF,?(40-($L(X)\2)),X,! S X="",$P(X,"=",1,79)="" W X
- S IBP="" I '$D(^UTILITY($J,"IB")) W !!," * No PROCEDURE CODES in PTF record for this episode of care." G Q
- F I=1:1:13 S IBP=$O(^UTILITY($J,"IB",IBP)) Q:IBP="" D ODDP^IBCSC4A S IBP=$O(^UTILITY($J,"IB",IBP)) D:IBP]"" EVENP^IBCSC4A D WRP D:$Y+6>IOSL ASK Q:IBP=""
- S IBP=""
- Q K IB3,IB4,IB5,IB6,IB7,IB8,IB9,IBAE,IBAO,IBCT,IBDIA,IBDP,IBDX,IBDXC,IBDXX,IBDXY,IBI,IBNC,IBNOR,IBP,IBPY,IBOP,IBOPC,IBOPX,IBOPY,IBPP,IBPX,IBSD,IBSP,IBWE,IBWO
- K %DT,A,B,DIC,F,I,J,K,M,S,X,Y Q
- WRP I '$D(IBWE(0)) F B=0:1:5 S IBWE(B)=""
- W !!,$S($P(IBWO(0),U,3)["*":IBNOR,1:IBSD) S Y=$P(IBWO(0),U,2) X ^DD("DD") W Y I IBP]"" W ?43,$S($P(IBWE(0),U,3)["*":IBNOR,1:IBSD) S Y=$P(IBWE(0),U,2) X ^DD("DD") W Y
- S IBAO=$P(IBWO(0),U,1) I IBAO']"" W:'$D(IBOPY) !,"* ",IBNC S IBOPY=1 F K=1:1:5 S IBWO(K)="" I IBP]"" W:K>1 ! D WEP
- I IBAO]"" F K=1:1:5 Q:IBWO(K)']""&(IBWE(K)']"") S X=$S($D(^ICD0((+IBWO(K)),0)):^(0),1:"") W:IBWO(K)]"" !,IBAO,K," - ",$S(X]"":$J($P(X,U,1),6)_" "_$E($P(X,U,4),1,24),1:IBUC) W:IBWO(K)']"" !,"" D:IBP]"" WEP
- Q
- WEP S IBAE=$P(IBWE(0),U,1) I IBAE']"",'$D(IBOPX) W ?43,"* ",IBNC S (IBWE(1),IBWE(2),IBWE(3),IBWE(4),IBWE(5))="",IBOPX=1
- I IBAE]"",IBWE(K)]"" S X=$S($D(^ICD0((+IBWE(K)),0)):^(0),1:"") W ?43,IBAE,K," - ",$S(X]"":$J($P(X,U,1),6)_" "_$E($P(X,U,4),1,24),1:IBUC)
- Q
- IBCSC4B ;ALB/MJB - MCCR PTF SCREEN (CONT.) ;24 FEB 89 9:52
- +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 DGCRSC4B
- +5 ;
- DX IF $SELECT(IBPTF=""
- QUIT
- SET IBUC="UNSPECIFIED CODE"
- SET IBNC="NO DX CODES ENTERED FOR THIS DATE"
- SET IBDXC=0
- SET X="DIAGNOSIS SCREEN"
- KILL IBWE,IBWO
- +1 WRITE @IOF,?(40-($LENGTH(X)\2)),X,!
- FOR I=1:1:79
- WRITE "="
- +2 SET IBDIA=""
- IF '$DATA(^UTILITY($JOB,"IBDX"))
- WRITE !!," * No DIAGNOSIS CODES in PTF record for this episode of care."
- DO SELD^IBCSC4C
- GOTO Q
- +3 FOR I=1:1:13
- SET IBDIA=$ORDER(^UTILITY($JOB,"IBDX",IBDIA))
- IF IBDIA=""
- QUIT
- DO ODD^IBCSC4A
- SET IBDIA=$ORDER(^UTILITY($JOB,"IBDX",IBDIA))
- IF IBDIA]""
- DO EVEN^IBCSC4A
- DO WR
- IF $Y+6>IOSL
- DO ASK
- IF IBDIA=""
- QUIT
- +4 ; D SELD^IBCSC4C
- SET IBDIA=""
- +5 GOTO Q
- +6 ;
- WR IF '$DATA(IBWE(0))
- FOR B=0:1:5
- SET IBWE(B)=""
- +1 WRITE !!,"Move: "
- SET Y=$PIECE(IBWO(0),U,2)
- XECUTE ^DD("DD")
- WRITE $SELECT($PIECE(IBWO(0),U,4)]"":$PIECE(IBWO(0),U,4)_" ",1:""),Y," "
- IF $PIECE(IBWO(0),"^",3)]""
- WRITE $EXTRACT($PIECE(^DIC(42.4,$PIECE(IBWO(0),U,3),0),U),1,12)
- WRITE " ",$PIECE(IBWO(0),"^",5)
- +2 IF IBDIA]""
- IF IBWE(0)]""
- WRITE ?43,"Move: "
- SET Y=$PIECE(IBWE(0),U,2)
- XECUTE ^DD("DD")
- WRITE $SELECT($PIECE(IBWE(0),U,4)]"":$PIECE(IBWE(0),U,4)_" ",1:""),Y," "
- IF $PIECE(IBWE(0),"^",3)]""
- WRITE $EXTRACT($PIECE(^DIC(42.4,$PIECE(IBWE(0),U,3),0),U),1,12)
- WRITE " ",$PIECE(IBWE(0),"^",5)
- +3 SET IBAO=$PIECE(IBWO(0),U,1)
- IF IBAO']""
- IF '$DATA(IBDXY)
- WRITE !,"* ",IBNC
- SET IBDXY=1
- FOR K=1:1:5
- SET IBWO(K)=""
- IF IBDIA]""
- IF K>1
- WRITE !
- DO WE
- IF IBWO(K)']""&(IBWE(K)']"")
- QUIT
- +4 IF IBAO]""
- FOR K=1:1:5
- IF IBWO(K)']""&(IBWE(K)']"")
- QUIT
- SET X=$SELECT($DATA(^ICD9((+IBWO(K)),0)):^(0),1:"")
- IF IBWO(K)]""
- WRITE !,IBAO,K," - ",$SELECT(X]"":$JUSTIFY($PIECE(X,U,1),6)_" "_$EXTRACT($PIECE(X,U,3),1,24),1:IBUC)
- IF IBWO(K)']""
- WRITE !,""
- IF IBDIA]""
- DO WE
- +5 QUIT
- WE SET IBAE=$PIECE(IBWE(0),U,1)
- IF IBAE']""
- IF '$DATA(IBDXX)
- IF IBWE(0)]""
- WRITE ?43,"* ",IBNC
- SET (IBWE(1),IBWE(2),IBWE(3),IBWE(4),IBWE(5))=""
- SET IBDXX=1
- +1 IF IBAE]""
- IF IBWE(K)]""
- SET X=$SELECT($DATA(^ICD9((+IBWE(K)),0)):^(0),1:"")
- WRITE ?43,IBAE,K," - ",$SELECT(X]"":$JUSTIFY($PIECE(X,U,1),6)_" "_$EXTRACT($PIECE(X,U,3),1,24),1:IBUC)
- +2 QUIT
- ASK WRITE !!,"<RETURN> to see more ",$SELECT($DATA(IBP):"procedure",1:"diagnosis")," codes or '^' to QUIT: "
- READ A:DTIME
- IF '$TEST!(A["^")
- IF $DATA(IBDIA)
- SET IBDIA=""
- IF $DATA(IBP)
- SET IBP=""
- QUIT
- +1 IF A["?"
- WRITE !!?4,"Enter <RETURN> to view more ",$SELECT($DATA(IBP):"operation/procedure",1:"movement dates and diagnosis")," codes",!?4,"or '^' to stop the display."
- GOTO ASK
- +2 SET A=$SELECT($DATA(IBP):"OPERATION/PROCEDURE",1:"DIAGNOSIS")_" SCREEN (CONT.)"
- WRITE !,@IOF,?(40-($LENGTH(A)\2)),A,!
- FOR S=1:1:79
- WRITE "="
- +3 QUIT
- PRO IF '$DATA(IBPTF)
- QUIT
- SET IBUC="UNSPECIFIED CODE"
- SET IBNC="NO PRO CODES ENTERED FOR THIS DATE"
- SET IBOPC=0
- SET X="OPERATION/PROCEDURE SCREEN"
- SET IBNOR="Non-O/R Procedure Date: "
- SET IBSD="Surgery Date: "
- +1 KILL IBWE,IBWO
- +2 WRITE @IOF,?(40-($LENGTH(X)\2)),X,!
- SET X=""
- SET $PIECE(X,"=",1,79)=""
- WRITE X
- +3 SET IBP=""
- IF '$DATA(^UTILITY($JOB,"IB"))
- WRITE !!," * No PROCEDURE CODES in PTF record for this episode of care."
- GOTO Q
- +4 FOR I=1:1:13
- SET IBP=$ORDER(^UTILITY($JOB,"IB",IBP))
- IF IBP=""
- QUIT
- DO ODDP^IBCSC4A
- SET IBP=$ORDER(^UTILITY($JOB,"IB",IBP))
- IF IBP]""
- DO EVENP^IBCSC4A
- DO WRP
- IF $Y+6>IOSL
- DO ASK
- IF IBP=""
- QUIT
- +5 SET IBP=""
- Q KILL IB3,IB4,IB5,IB6,IB7,IB8,IB9,IBAE,IBAO,IBCT,IBDIA,IBDP,IBDX,IBDXC,IBDXX,IBDXY,IBI,IBNC,IBNOR,IBP,IBPY,IBOP,IBOPC,IBOPX,IBOPY,IBPP,IBPX,IBSD,IBSP,IBWE,IBWO
- +1 KILL %DT,A,B,DIC,F,I,J,K,M,S,X,Y
- QUIT
- WRP IF '$DATA(IBWE(0))
- FOR B=0:1:5
- SET IBWE(B)=""
- +1 WRITE !!,$SELECT($PIECE(IBWO(0),U,3)["*":IBNOR,1:IBSD)
- SET Y=$PIECE(IBWO(0),U,2)
- XECUTE ^DD("DD")
- WRITE Y
- IF IBP]""
- WRITE ?43,$SELECT($PIECE(IBWE(0),U,3)["*":IBNOR,1:IBSD)
- SET Y=$PIECE(IBWE(0),U,2)
- XECUTE ^DD("DD")
- WRITE Y
- +2 SET IBAO=$PIECE(IBWO(0),U,1)
- IF IBAO']""
- IF '$DATA(IBOPY)
- WRITE !,"* ",IBNC
- SET IBOPY=1
- FOR K=1:1:5
- SET IBWO(K)=""
- IF IBP]""
- IF K>1
- WRITE !
- DO WEP
- +3 IF IBAO]""
- FOR K=1:1:5
- IF IBWO(K)']""&(IBWE(K)']"")
- QUIT
- SET X=$SELECT($DATA(^ICD0((+IBWO(K)),0)):^(0),1:"")
- IF IBWO(K)]""
- WRITE !,IBAO,K," - ",$SELECT(X]"":$JUSTIFY($PIECE(X,U,1),6)_" "_$EXTRACT($PIECE(X,U,4),1,24),1:IBUC)
- IF IBWO(K)']""
- WRITE !,""
- IF IBP]""
- DO WEP
- +4 QUIT
- WEP SET IBAE=$PIECE(IBWE(0),U,1)
- IF IBAE']""
- IF '$DATA(IBOPX)
- WRITE ?43,"* ",IBNC
- SET (IBWE(1),IBWE(2),IBWE(3),IBWE(4),IBWE(5))=""
- SET IBOPX=1
- +1 IF IBAE]""
- IF IBWE(K)]""
- SET X=$SELECT($DATA(^ICD0((+IBWE(K)),0)):^(0),1:"")
- WRITE ?43,IBAE,K," - ",$SELECT(X]"":$JUSTIFY($PIECE(X,U,1),6)_" "_$EXTRACT($PIECE(X,U,4),1,24),1:IBUC)
- +2 QUIT
