- 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>")
