IBCSC4A ;ALB/MJB - MCCR PTF SCREEN ;24 FEB 89 9:49
;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
;MAP TO DGCRSC4A
;
DX Q:'$D(^DGPT(+IBPTF,0)) S (IBDXC,IBOPC)=0,IBNC="NO DX CODES ENTERED FOR THIS DATE" K ^UTILITY($J,"IBDX")
F I=0:0 S I=$O(^DGPT(IBPTF,"M","AM",I)) Q:I'>0 S X=$O(^DGPT(IBPTF,"M","AM",I,0)),IBDX((9999999-$P(I,".",1)),X)=""
I '$D(^DGPT(IBPTF,"M","AM")) S IBDX(9999999-DT,1)=""
S IBDIA=0 F I=1:1:26 S IBDIA=$O(IBDX(IBDIA)) Q:IBDIA="" S X=$O(IBDX(IBDIA,0)),M=$S($D(^DGPT(IBPTF,"M",X,0)):^(0),1:"") I M]"" S IBCT=0 F J=5:1:9 S:$P(M,U,J)]"" IBCT=IBCT+1,^UTILITY($J,"IBDX",I,IBCT)=$P(M,U,J) D:J=5 T
S IBDIA="" F I=1:1:13 S IBDIA=$O(^UTILITY($J,"IBDX",IBDIA)) Q:IBDIA="" D ODD S IBDIA=$O(^UTILITY($J,"IBDX",IBDIA)) D:IBDIA]"" EVEN D SETD^IBCSC4C Q:IBDIA']""
;
PRO S IBNC="NO PRO CODES ENTERED FOR THIS DATE",IBOPC=0 K ^UTILITY($J,"IB")
F I=0:0 S I=$O(^DGPT(IBPTF,"S",I)) Q:I'>0 S J=$S($D(^DGPT(IBPTF,"S",I,0)):^(0),1:"") I J]"" S X=+J,X=$S(X[".":9999999-X,1:(9999999_"."_I)-X),IBOP(X)=$P(J,U)_U_$P(J,U,8,12)
F I=0:0 S I=$O(^DGPT(IBPTF,"P",I)) Q:I'>0 S J=$S($D(^DGPT(IBPTF,"P",I,0)):^(0),1:"") I J]"" S X=+J,X=$S(X[".":9999999-X,1:(9999999_"."_I)-X),IBSP(X)=$P(J,U)_U_$P(J,U,5,9)
S IBP=0 F I=1:1:26 S IBP=$O(IBOP(IBP)) Q:IBP="" S M=IBOP(IBP),IBCT=0 F J=2:1:6 Q:IBCT=3 S:$P(M,U,J)]"" IBCT=IBCT+1,^UTILITY($J,"IB",I,IBCT)=$P(M,U,J) D:J=2 TP
I I<26 S IBP="" F I=I:1:26 S IBP=$O(IBSP(IBP)) Q:IBP="" S M=IBSP(IBP),IBCT=0 F J=2:1:6 Q:IBCT=3 S:$P(M,U,J)]"" IBCT=IBCT+1 D:$P(M,U,J)]"" T1 D:J=2 T2
S IBP="" F I=1:1:13 S IBP=$O(^UTILITY($J,"IB",IBP)) Q:IBP="" D ODDP S IBP=$O(^UTILITY($J,"IB",IBP)) D:IBP]"" EVENP D SETP^IBCSC4C Q:IBP=""
Q
;
T I IBCT>0 S IBDXC=IBDXC+1,^UTILITY($J,"IBDX",I,IBCT)=^UTILITY($J,"IBDX",I,IBCT)_U_$P($P(M,U,10),".",1)_U_$C(64+IBDXC)_U_$P(M,U,2)_"^"_$S(X'=1:"",'$D(^DGPT(IBPTF,70)):"",1:"D/C")_"^"_$$SC(M) Q
S ^UTILITY($J,"IBDX",I,1)=IBNC_U_$P($P(M,U,10),".",1)_"^^"_$P(^DGPT(IBPTF,"M",X,0),U,2)_"^^"_$$SC(M) Q
;
ODD S X=^UTILITY($J,"IBDX",IBDIA,1),IBWO(0)=$P(X,U,3)_U_$P(X,U,2)_U_$P(X,U,4,6),IBWO(1)=$P(X,U,1) F M=2:1:5 S IBWO(M)=$S($D(^UTILITY($J,"IBDX",IBDIA,M)):^(M),1:"")
Q
;
EVEN S X=^UTILITY($J,"IBDX",IBDIA,1),IBWE(0)=$P(X,U,3)_U_$P(X,U,2)_U_$P(X,U,4,6),IBWE(1)=$P(X,U,1) F M=2:1:5 S IBWE(M)=$S($D(^UTILITY($J,"IBDX",IBDIA,M)):^(M),1:"")
I $P(IBWE(0),U,1)']"" F M=1:1:5 S IBWE(M)=""
Q
;
TP I IBCT>0 S IBOPC=IBOPC+1,^UTILITY($J,"IB",I,IBCT)=^UTILITY($J,"IB",I,IBCT)_U_$P(+M,".",1)_U_$C(64+IBOPC) Q
S ^UTILITY($J,"IB",I,1)=IBNC_U_$P(+M,".",1) Q
T1 S ^UTILITY($J,"IB",I,IBCT)=$P(M,U,J) Q
T2 I IBCT>0 S IBOPC=IBOPC+1,^UTILITY($J,"IB",I,IBCT)=^UTILITY($J,"IB",I,IBCT)_U_$P($P(M,U,1),".",1)_U_$C(64+IBOPC)_U_"*" Q
S ^UTILITY($J,"IB",I,1)=IBNC_U_$P($P(M,U,1),".",1)_"^^*" Q
;
ODDP S X=^UTILITY($J,"IB",IBP,1),IBWO(0)=$P(X,U,3)_U_$P(X,U,2)_U_$S($P(X,U,4)="*":"*",1:""),IBWO(1)=$P(X,U,1) F M=2:1:5 S IBWO(M)=$S($D(^UTILITY($J,"IB",IBP,M)):^(M),1:"")
Q
;
EVENP S X=^UTILITY($J,"IB",IBP,1),IBWE(0)=$P(X,U,3)_U_$P(X,U,2)_U_$S($P(X,U,4)="*":"*",1:""),IBWE(1)=$P(X,U,1) F M=2:1:5 S IBWE(M)=$S($D(^UTILITY($J,"IB",IBP,M)):^(M),1:"")
Q
;
NUL F I=1:1:13 S $P(^DGCR(399,IBIFN,"C"),U,I)=""
Q
;
P S M=($A($E(X,1))-64),S=$E(X,2),IB5=$S($D(^UTILITY($J,"IB",M,S)):^(S),1:"") I IB5]"" Q:$P(^UTILITY($J,"IB",M,1),U,3)=$E(X,1)
F J=M:1:26 Q:'$D(^UTILITY($J,"IB",J)) I $P(^UTILITY($J,"IB",J,1),U,3)=$E(X,1) S M=J,IBA=1 Q
S:'$D(IBA) M=0 K IBA Q
D S M=($A($E(X,1))-64),S=$E(X,2),IB4=$S($D(^UTILITY($J,"IBDX",M,S)):^(S),1:"") I IB4]"" Q:$P(^UTILITY($J,"IBDX",M,1),U,3)=$E(X,1)
F J=M:1:26 Q:'$D(^UTILITY($J,"IBDX",J)) I $P(^UTILITY($J,"IBDX",J,1),U,3)=$E(X,1) S M=J,IBA=1 Q
S:'$D(IBA) M=0 K IBA Q
;
SC(M) ; - check SC flag of movement
; input movement node
; output flag as to whether sc or not
I '$D(M) Q ""
I M="" Q ""
Q $S($P(M,"^",18)=1:"<SC>",1:"<NSC>")
IBCSC4A ;ALB/MJB - MCCR PTF SCREEN ;24 FEB 89 9:49
+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 DGCRSC4A
+5 ;
DX IF '$DATA(^DGPT(+IBPTF,0))
QUIT
SET (IBDXC,IBOPC)=0
SET IBNC="NO DX CODES ENTERED FOR THIS DATE"
KILL ^UTILITY($JOB,"IBDX")
+1 FOR I=0:0
SET I=$ORDER(^DGPT(IBPTF,"M","AM",I))
IF I'>0
QUIT
SET X=$ORDER(^DGPT(IBPTF,"M","AM",I,0))
SET IBDX((9999999-$PIECE(I,".",1)),X)=""
+2 IF '$DATA(^DGPT(IBPTF,"M","AM"))
SET IBDX(9999999-DT,1)=""
+3 SET IBDIA=0
FOR I=1:1:26
SET IBDIA=$ORDER(IBDX(IBDIA))
IF IBDIA=""
QUIT
SET X=$ORDER(IBDX(IBDIA,0))
SET M=$SELECT($DATA(^DGPT(IBPTF,"M",X,0)):^(0),1:"")
IF M]""
SET IBCT=0
FOR J=5:1:9
IF $PIECE(M,U,J)]""
SET IBCT=IBCT+1
SET ^UTILITY($JOB,"IBDX",I,IBCT)=$PIECE(M,U,J)
IF J=5
DO T
+4 SET IBDIA=""
FOR I=1:1:13
SET IBDIA=$ORDER(^UTILITY($JOB,"IBDX",IBDIA))
IF IBDIA=""
QUIT
DO ODD
SET IBDIA=$ORDER(^UTILITY($JOB,"IBDX",IBDIA))
IF IBDIA]""
DO EVEN
DO SETD^IBCSC4C
IF IBDIA']""
QUIT
+5 ;
PRO SET IBNC="NO PRO CODES ENTERED FOR THIS DATE"
SET IBOPC=0
KILL ^UTILITY($JOB,"IB")
+1 FOR I=0:0
SET I=$ORDER(^DGPT(IBPTF,"S",I))
IF I'>0
QUIT
SET J=$SELECT($DATA(^DGPT(IBPTF,"S",I,0)):^(0),1:"")
IF J]""
SET X=+J
SET X=$SELECT(X[".":9999999-X,1:(9999999_"."_I)-X)
SET IBOP(X)=$PIECE(J,U)_U_$PIECE(J,U,8,12)
+2 FOR I=0:0
SET I=$ORDER(^DGPT(IBPTF,"P",I))
IF I'>0
QUIT
SET J=$SELECT($DATA(^DGPT(IBPTF,"P",I,0)):^(0),1:"")
IF J]""
SET X=+J
SET X=$SELECT(X[".":9999999-X,1:(9999999_"."_I)-X)
SET IBSP(X)=$PIECE(J,U)_U_$PIECE(J,U,5,9)
+3 SET IBP=0
FOR I=1:1:26
SET IBP=$ORDER(IBOP(IBP))
IF IBP=""
QUIT
SET M=IBOP(IBP)
SET IBCT=0
FOR J=2:1:6
IF IBCT=3
QUIT
IF $PIECE(M,U,J)]""
SET IBCT=IBCT+1
SET ^UTILITY($JOB,"IB",I,IBCT)=$PIECE(M,U,J)
IF J=2
DO TP
+4 IF I<26
SET IBP=""
FOR I=I:1:26
SET IBP=$ORDER(IBSP(IBP))
IF IBP=""
QUIT
SET M=IBSP(IBP)
SET IBCT=0
FOR J=2:1:6
IF IBCT=3
QUIT
IF $PIECE(M,U,J)]""
SET IBCT=IBCT+1
IF $PIECE(M,U,J)]""
DO T1
IF J=2
DO T2
+5 SET IBP=""
FOR I=1:1:13
SET IBP=$ORDER(^UTILITY($JOB,"IB",IBP))
IF IBP=""
QUIT
DO ODDP
SET IBP=$ORDER(^UTILITY($JOB,"IB",IBP))
IF IBP]""
DO EVENP
DO SETP^IBCSC4C
IF IBP=""
QUIT
+6 QUIT
+7 ;
T IF IBCT>0
SET IBDXC=IBDXC+1
SET ^UTILITY($JOB,"IBDX",I,IBCT)=^UTILITY($JOB,"IBDX",I,IBCT)_U_$PIECE($PIECE(M,U,10),".",1)_U_$CHAR(64+IBDXC)_U_$PIECE(M,U,2)_"^"_$SELECT(X'=1:"",'$DATA(^DGPT(IBPTF,70)):"",1:"D/C")_"^"_$$SC(M)
QUIT
+1 SET ^UTILITY($JOB,"IBDX",I,1)=IBNC_U_$PIECE($PIECE(M,U,10),".",1)_"^^"_$PIECE(^DGPT(IBPTF,"M",X,0),U,2)_"^^"_$$SC(M)
QUIT
+2 ;
ODD SET X=^UTILITY($JOB,"IBDX",IBDIA,1)
SET IBWO(0)=$PIECE(X,U,3)_U_$PIECE(X,U,2)_U_$PIECE(X,U,4,6)
SET IBWO(1)=$PIECE(X,U,1)
FOR M=2:1:5
SET IBWO(M)=$SELECT($DATA(^UTILITY($JOB,"IBDX",IBDIA,M)):^(M),1:"")
+1 QUIT
+2 ;
EVEN SET X=^UTILITY($JOB,"IBDX",IBDIA,1)
SET IBWE(0)=$PIECE(X,U,3)_U_$PIECE(X,U,2)_U_$PIECE(X,U,4,6)
SET IBWE(1)=$PIECE(X,U,1)
FOR M=2:1:5
SET IBWE(M)=$SELECT($DATA(^UTILITY($JOB,"IBDX",IBDIA,M)):^(M),1:"")
+1 IF $PIECE(IBWE(0),U,1)']""
FOR M=1:1:5
SET IBWE(M)=""
+2 QUIT
+3 ;
TP IF IBCT>0
SET IBOPC=IBOPC+1
SET ^UTILITY($JOB,"IB",I,IBCT)=^UTILITY($JOB,"IB",I,IBCT)_U_$PIECE(+M,".",1)_U_$CHAR(64+IBOPC)
QUIT
+1 SET ^UTILITY($JOB,"IB",I,1)=IBNC_U_$PIECE(+M,".",1)
QUIT
T1 SET ^UTILITY($JOB,"IB",I,IBCT)=$PIECE(M,U,J)
QUIT
T2 IF IBCT>0
SET IBOPC=IBOPC+1
SET ^UTILITY($JOB,"IB",I,IBCT)=^UTILITY($JOB,"IB",I,IBCT)_U_$PIECE($PIECE(M,U,1),".",1)_U_$CHAR(64+IBOPC)_U_"*"
QUIT
+1 SET ^UTILITY($JOB,"IB",I,1)=IBNC_U_$PIECE($PIECE(M,U,1),".",1)_"^^*"
QUIT
+2 ;
ODDP SET X=^UTILITY($JOB,"IB",IBP,1)
SET IBWO(0)=$PIECE(X,U,3)_U_$PIECE(X,U,2)_U_$SELECT($PIECE(X,U,4)="*":"*",1:"")
SET IBWO(1)=$PIECE(X,U,1)
FOR M=2:1:5
SET IBWO(M)=$SELECT($DATA(^UTILITY($JOB,"IB",IBP,M)):^(M),1:"")
+1 QUIT
+2 ;
EVENP SET X=^UTILITY($JOB,"IB",IBP,1)
SET IBWE(0)=$PIECE(X,U,3)_U_$PIECE(X,U,2)_U_$SELECT($PIECE(X,U,4)="*":"*",1:"")
SET IBWE(1)=$PIECE(X,U,1)
FOR M=2:1:5
SET IBWE(M)=$SELECT($DATA(^UTILITY($JOB,"IB",IBP,M)):^(M),1:"")
+1 QUIT
+2 ;
NUL FOR I=1:1:13
SET $PIECE(^DGCR(399,IBIFN,"C"),U,I)=""
+1 QUIT
+2 ;
P SET M=($ASCII($EXTRACT(X,1))-64)
SET S=$EXTRACT(X,2)
SET IB5=$SELECT($DATA(^UTILITY($JOB,"IB",M,S)):^(S),1:"")
IF IB5]""
IF $PIECE(^UTILITY($JOB,"IB",M,1),U,3)=$EXTRACT(X,1)
QUIT
+1 FOR J=M:1:26
IF '$DATA(^UTILITY($JOB,"IB",J))
QUIT
IF $PIECE(^UTILITY($JOB,"IB",J,1),U,3)=$EXTRACT(X,1)
SET M=J
SET IBA=1
QUIT
+2 IF '$DATA(IBA)
SET M=0
KILL IBA
QUIT
D SET M=($ASCII($EXTRACT(X,1))-64)
SET S=$EXTRACT(X,2)
SET IB4=$SELECT($DATA(^UTILITY($JOB,"IBDX",M,S)):^(S),1:"")
IF IB4]""
IF $PIECE(^UTILITY($JOB,"IBDX",M,1),U,3)=$EXTRACT(X,1)
QUIT
+1 FOR J=M:1:26
IF '$DATA(^UTILITY($JOB,"IBDX",J))
QUIT
IF $PIECE(^UTILITY($JOB,"IBDX",J,1),U,3)=$EXTRACT(X,1)
SET M=J
SET IBA=1
QUIT
+2 IF '$DATA(IBA)
SET M=0
KILL IBA
QUIT
+3 ;
SC(M) ; - check SC flag of movement
+1 ; input movement node
+2 ; output flag as to whether sc or not
+3 IF '$DATA(M)
QUIT ""
+4 IF M=""
QUIT ""
+5 QUIT $SELECT($PIECE(M,"^",18)=1:"<SC>",1:"<NSC>")
