| 1 | FBUCDD1 ;ALBISC/TET - DD UTILITY (cont'd.) ;5/27/93
|
|---|
| 2 | ;;3.5;FEE BASIS;**60,72**;JAN 30, 1995
|
|---|
| 3 | ;;Per VHA Directive 10-93-142, this routine should not be modified.
|
|---|
| 4 | DEL(DA) ;del node on .01 field of 162.7, unauthorized claim file
|
|---|
| 5 | ;INPUT: DA = ien of 162.7
|
|---|
| 6 | I 1 N FBORDER,FBZ S FBZ=$$FBZ^FBUCUTL(DA) S FBORDER=$$ORDER^FBUCUTL(+$P(FBZ,U,24)) W ! W:FBORDER'<40 "Disposition to Cancel/Withdrawn." W:FBORDER<40 "Use the Delete Unauthorized Claim option." W !
|
|---|
| 7 | Q
|
|---|
| 8 | DEV(X) ;input transform on field 33, UNAUTHORIZED CLAIM PRINTER, file 161.4
|
|---|
| 9 | ;check x, and if x is a device, with subtype beginning with p(rinter)
|
|---|
| 10 | ;INPUT: X - FM variable, input
|
|---|
| 11 | ;OUTPUT: 1 to kill x (invalid entry), otherwise 0
|
|---|
| 12 | Q $S('$D(X):1,'$$DEVICE(X):1,1:0)
|
|---|
| 13 | ;
|
|---|
| 14 | SUBTYPE(X) ;extrinsic call for subtype check
|
|---|
| 15 | ;INPUT: X = internal entry of device
|
|---|
| 16 | ;OUTPUT: 1 if subtype is a printer
|
|---|
| 17 | N Z1,Z2 S Z1=$S('$D(X):0,'+X:0,1:X),Z2=0 S Z2=+$G(^%ZIS(1,X,"SUBTYPE")),Z2=$P($G(^%ZIS(2,Z2,0)),U)
|
|---|
| 18 | Q $S(Z2']"":0,$E(Z2,1)="P":1,1:0)
|
|---|
| 19 | ;
|
|---|
| 20 | DEVICE(X) ;extrinsic call for device ien
|
|---|
| 21 | ;INPUT: X = name
|
|---|
| 22 | ;OUTPUT: 1 if device with printer subtype
|
|---|
| 23 | N Z1 S Z1=0,Z1=+$O(^%ZIS(1,"B",X,0))
|
|---|
| 24 | Q $S('Z1:0,'$$SUBTYPE(Z1):0,1:1)
|
|---|
| 25 | ;
|
|---|
| 26 | XHELP ;executable help from field 33, UNAUTHORIZED CLAIM PRINTER, file 161.4
|
|---|
| 27 | ;displays printer selection
|
|---|
| 28 | D HOME^%ZIS H 1 W @IOF,!,"Select a printer device name.",!,"NOTE: This is not a pointer field, the exact name must be entered."
|
|---|
| 29 | W !!,?5,"Printer name:",?40,"Location:",!,?5,"-------------",?40,"---------"
|
|---|
| 30 | N FBX,FBXZ,FBX1 S FBX=0 F S FBX=$O(^%ZIS(1,FBX)) Q:'FBX I $$SUBTYPE(FBX) S FBXZ=$G(^%ZIS(1,FBX,0)),FBX1=$G(^(1)) D G:$D(DTOUT)!($D(DUOUT)) XHELPQ
|
|---|
| 31 | .I ($Y+5)>IOSL S DIR(0)="E" D ^DIR K DIR Q:$D(DTOUT)!($D(DUOUT)) W @IOF,!!,?5,"Printer name:",?40,"Location:",!,?5,"-------------",?40,"---------"
|
|---|
| 32 | .W !?5,$P(FBXZ,U),?40,$P(FBX1,U)
|
|---|
| 33 | XHELPQ W ! K DIR,DTOUT,DUOUT Q
|
|---|
| 34 | ID(Y) ;display identifiers
|
|---|
| 35 | N FBZ S FBZ=$$FBZ^FBUCUTL(+Y) Q:Y']"" W ?15,$E($$VET^FBUCUTL(+$P(FBZ,U,4)),1,20),?38,$E($$VEN^FBUCUTL(+$P(FBZ,U,3)),1,20)
|
|---|
| 36 | W ?61,$E($$PROG^FBUCUTL(+$P(FBZ,U,2)),1,14),!,$E($P($$PTR^FBUCUTL("^FB(162.92,",+$P(FBZ,U,24)),U),1,16)
|
|---|
| 37 | W ?19,"TREATMENT FROM: ",$$DATX^FBAAUTL(+$P(FBZ,U,5)),?44,"TREATMENT TO: ",$$DATX^FBAAUTL(+$P(FBZ,U,6))
|
|---|
| 38 | W ! Q
|
|---|
| 39 | ;
|
|---|
| 40 | DELA(DA,M) ;delete authorization node
|
|---|
| 41 | ;INPUT: DA = ien of authorization (161.01)
|
|---|
| 42 | ; DA(1)= ien of patient (161)
|
|---|
| 43 | ; M=message (optional) 1 to print;0 to not print
|
|---|
| 44 | ;VAR: M, 2nd piece = message to print: 1 for payments, 2 for 7078/583
|
|---|
| 45 | ;OUTPUT: 1 if ok to delete; 0 if should not delete
|
|---|
| 46 | ; message may write explaining why cannot delete
|
|---|
| 47 | I $S('$G(DA):1,'$G(DA(1)):1,1:0) G DELAQ
|
|---|
| 48 | S:'$G(M) M=0
|
|---|
| 49 | N FBI,FBV,FBVAR
|
|---|
| 50 | S FBVAR=$P($G(^FBAAA(DA(1),1,DA,0)),U,9),FBV=+$P($G(^FBAAA(DA(1),1,DA,0)),U,4)
|
|---|
| 51 | I 'FBV="0" S FBV=FBV-1
|
|---|
| 52 | F S FBV=$O(^FBAAC(DA(1),1,FBV)) Q:'FBV!($P(M,U,2)) D
|
|---|
| 53 | .S FBI=0
|
|---|
| 54 | .F S FBI=$O(^FBAAC(DA(1),1,FBV,1,FBI)) Q:'FBI!($P(M,U,2)) S FBI(0)=$G(^FBAAC(DA(1),1,FBV,1,FBI,0)) I $P(FBI(0),U,4)=DA,$O(^FBAAC(DA(1),1,FBV,1,FBI,1,1,0)) S $P(M,U,2)=1
|
|---|
| 55 | I FBVAR]"",$$PAY^FBUCUTL($P(FBVAR,";"),$P(FBVAR,";",2)) S $P(M,U,2)=1
|
|---|
| 56 | I '$P(M,U,2),FBVAR]"" S $P(M,U,2)=2
|
|---|
| 57 | I +M,$P(M,U,2) W !! D W !
|
|---|
| 58 | .W:$P(M,U,2)=1 "Cannot delete Authorization because payments already exist!"
|
|---|
| 59 | .W:$P(M,U,2)=2 "Cannot delete Authorization because a 7078/583 entry has already been established!"
|
|---|
| 60 | DELAQ Q $S('+$P($G(M),U,2):0,$P(M,U,2):1,1:0)
|
|---|
