source: WorldVistAEHR/trunk/r/FEE_BASIS-FB/FBUCDD1.m@ 1093

Last change on this file since 1093 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 3.3 KB
Line 
1FBUCDD1 ;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.
4DEL(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
8DEV(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 ;
14SUBTYPE(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 ;
20DEVICE(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 ;
26XHELP ;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)
33XHELPQ W ! K DIR,DTOUT,DUOUT Q
34ID(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 ;
40DELA(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!"
60DELAQ Q $S('+$P($G(M),U,2):0,$P(M,U,2):1,1:0)
Note: See TracBrowser for help on using the repository browser.