FBUCDD1 ;ALBISC/TET - DD UTILITY (cont'd.) ;4/23/2015
;;3.5;FEE BASIS;**60,72,127,154**;JAN 30, 1995;Build 12
;;Per VA Directive 6402, this routine should not be modified.
DEL(DA) ;del node on .01 field of 162.7, unauthorized claim file
;INPUT: DA = ien of 162.7
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 !
Q
DEV(X) ;input transform on field 33, UNAUTHORIZED CLAIM PRINTER, file 161.4
;check x, and if x is a device, with subtype beginning with p(rinter)
;INPUT: X - FM variable, input
;OUTPUT: 1 to kill x (invalid entry), otherwise 0
Q $S('$D(X):1,'$$DEVICE(X):1,1:0)
;
SUBTYPE(X) ;extrinsic call for subtype check
;INPUT: X = internal entry of device
;OUTPUT: 1 if subtype is a printer
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)
Q $S(Z2']"":0,$E(Z2,1)="P":1,1:0)
;
DEVICE(X) ;extrinsic call for device ien
;INPUT: X = name
;OUTPUT: 1 if device with printer subtype
N Z1 S Z1=0,Z1=+$O(^%ZIS(1,"B",X,0))
Q $S('Z1:0,'$$SUBTYPE(Z1):0,1:1)
;
XHELP ;executable help from field 33, UNAUTHORIZED CLAIM PRINTER, file 161.4
;displays printer selection
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."
W !!,?5,"Printer name:",?40,"Location:",!,?5,"-------------",?40,"---------"
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
.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,"---------"
.W !?5,$P(FBXZ,U),?40,$P(FBX1,U)
XHELPQ W ! K DIR,DTOUT,DUOUT Q
ID(Y) ;display identifiers
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)
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)
W ?19,"TREATMENT FROM: ",$$DATX^FBAAUTL(+$P(FBZ,U,5)),?44,"TREATMENT TO: ",$$DATX^FBAAUTL(+$P(FBZ,U,6))
W ! Q
;
DELA(DA,M) ;delete authorization node
;INPUT: DA = ien of authorization (161.01)
; DA(1)= ien of patient (161)
; M=message (optional) 1 to print;0 to not print
;VAR: M, 2nd piece = message to print: 1 for payments, 2 for 7078/583
;OUTPUT: 0 if ok to delete; 1 if should not delete
; message may write explaining why cannot delete
I $S('$G(DA):1,'$G(DA(1)):1,1:0) G DELAQ
S:'$G(M) M=0
N FBI,FBVAR
S FBVAR=$P($G(^FBAAA(DA(1),1,DA,0)),U,9)
I $D(^FBAAC("AFN",DA,DA(1))) S $P(M,U,2)=1 ; payments in file 162
I FBVAR]"",$$PAY^FBUCUTL($P(FBVAR,";"),$P(FBVAR,";",2)) S $P(M,U,2)=1
I $P(^FBAAA(DA(1),1,DA,0),U,13)=2!($P(^FBAAA(DA(1),1,DA,0),U,13)=3) S $P(M,U,2)=3
I '$P(M,U,2),FBVAR]"" S $P(M,U,2)=2
I +M,$P(M,U,2) D
.D:$P(M,U,2)=1 EN^DDIOL("Cannot delete Authorization because payments already exist!","","!!")
.D:$P(M,U,2)=2 EN^DDIOL("Cannot delete Authorization because a 7078/583 entry exists!","","!!")
.D:$P(M,U,2)=3 EN^DDIOL("Cannot delete Authorization, please create a Delete type Veteran MRA!","","!!")
.D EN^DDIOL(" ")
DELAQ Q $S('+$P($G(M),U,2):0,$P(M,U,2):1,1:0)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBUCDD1 3393 printed Dec 13, 2024@02:00:04 Page 2
FBUCDD1 ;ALBISC/TET - DD UTILITY (cont'd.) ;4/23/2015
+1 ;;3.5;FEE BASIS;**60,72,127,154**;JAN 30, 1995;Build 12
+2 ;;Per VA Directive 6402, this routine should not be modified.
DEL(DA) ;del node on .01 field of 162.7, unauthorized claim file
+1 ;INPUT: DA = ien of 162.7
+2 IF 1
NEW FBORDER,FBZ
SET FBZ=$$FBZ^FBUCUTL(DA)
SET FBORDER=$$ORDER^FBUCUTL(+$PIECE(FBZ,U,24))
WRITE !
if FBORDER'<40
WRITE "Disposition to Cancel/Withdrawn."
if FBORDER<40
WRITE "Use the Delete Unauthorized Claim option."
WRITE !
+3 QUIT
DEV(X) ;input transform on field 33, UNAUTHORIZED CLAIM PRINTER, file 161.4
+1 ;check x, and if x is a device, with subtype beginning with p(rinter)
+2 ;INPUT: X - FM variable, input
+3 ;OUTPUT: 1 to kill x (invalid entry), otherwise 0
+4 QUIT $SELECT('$DATA(X):1,'$$DEVICE(X):1,1:0)
+5 ;
SUBTYPE(X) ;extrinsic call for subtype check
+1 ;INPUT: X = internal entry of device
+2 ;OUTPUT: 1 if subtype is a printer
+3 NEW Z1,Z2
SET Z1=$SELECT('$DATA(X):0,'+X:0,1:X)
SET Z2=0
SET Z2=+$GET(^%ZIS(1,X,"SUBTYPE"))
SET Z2=$PIECE($GET(^%ZIS(2,Z2,0)),U)
+4 QUIT $SELECT(Z2']"":0,$EXTRACT(Z2,1)="P":1,1:0)
+5 ;
DEVICE(X) ;extrinsic call for device ien
+1 ;INPUT: X = name
+2 ;OUTPUT: 1 if device with printer subtype
+3 NEW Z1
SET Z1=0
SET Z1=+$ORDER(^%ZIS(1,"B",X,0))
+4 QUIT $SELECT('Z1:0,'$$SUBTYPE(Z1):0,1:1)
+5 ;
XHELP ;executable help from field 33, UNAUTHORIZED CLAIM PRINTER, file 161.4
+1 ;displays printer selection
+2 DO HOME^%ZIS
HANG 1
WRITE @IOF,!,"Select a printer device name.",!,"NOTE: This is not a pointer field, the exact name must be entered."
+3 WRITE !!,?5,"Printer name:",?40,"Location:",!,?5,"-------------",?40,"---------"
+4 NEW FBX,FBXZ,FBX1
SET FBX=0
FOR
SET FBX=$ORDER(^%ZIS(1,FBX))
if 'FBX
QUIT
IF $$SUBTYPE(FBX)
SET FBXZ=$GET(^%ZIS(1,FBX,0))
SET FBX1=$GET(^(1))
Begin DoDot:1
+5 IF ($Y+5)>IOSL
SET DIR(0)="E"
DO ^DIR
KILL DIR
if $DATA(DTOUT)!($DATA(DUOUT))
QUIT
WRITE @IOF,!!,?5,"Printer name:",?40,"Location:",!,?5,"-------------",?40,"---------"
+6 WRITE !?5,$PIECE(FBXZ,U),?40,$PIECE(FBX1,U)
End DoDot:1
if $DATA(DTOUT)!($DATA(DUOUT))
GOTO XHELPQ
XHELPQ WRITE !
KILL DIR,DTOUT,DUOUT
QUIT
ID(Y) ;display identifiers
+1 NEW FBZ
SET FBZ=$$FBZ^FBUCUTL(+Y)
if Y']""
QUIT
WRITE ?15,$EXTRACT($$VET^FBUCUTL(+$PIECE(FBZ,U,4)),1,20),?38,$EXTRACT($$VEN^FBUCUTL(+$PIECE(FBZ,U,3)),1,20)
+2 WRITE ?61,$EXTRACT($$PROG^FBUCUTL(+$PIECE(FBZ,U,2)),1,14),!,$EXTRACT($PIECE($$PTR^FBUCUTL("^FB(162.92,",+$PIECE(FBZ,U,24)),U),1,16)
+3 WRITE ?19,"TREATMENT FROM: ",$$DATX^FBAAUTL(+$PIECE(FBZ,U,5)),?44,"TREATMENT TO: ",$$DATX^FBAAUTL(+$PIECE(FBZ,U,6))
+4 WRITE !
QUIT
+5 ;
DELA(DA,M) ;delete authorization node
+1 ;INPUT: DA = ien of authorization (161.01)
+2 ; DA(1)= ien of patient (161)
+3 ; M=message (optional) 1 to print;0 to not print
+4 ;VAR: M, 2nd piece = message to print: 1 for payments, 2 for 7078/583
+5 ;OUTPUT: 0 if ok to delete; 1 if should not delete
+6 ; message may write explaining why cannot delete
+7 IF $SELECT('$GET(DA):1,'$GET(DA(1)):1,1:0)
GOTO DELAQ
+8 if '$GET(M)
SET M=0
+9 NEW FBI,FBVAR
+10 SET FBVAR=$PIECE($GET(^FBAAA(DA(1),1,DA,0)),U,9)
+11 ; payments in file 162
IF $DATA(^FBAAC("AFN",DA,DA(1)))
SET $PIECE(M,U,2)=1
+12 IF FBVAR]""
IF $$PAY^FBUCUTL($PIECE(FBVAR,";"),$PIECE(FBVAR,";",2))
SET $PIECE(M,U,2)=1
+13 IF $PIECE(^FBAAA(DA(1),1,DA,0),U,13)=2!($PIECE(^FBAAA(DA(1),1,DA,0),U,13)=3)
SET $PIECE(M,U,2)=3
+14 IF '$PIECE(M,U,2)
IF FBVAR]""
SET $PIECE(M,U,2)=2
+15 IF +M
IF $PIECE(M,U,2)
Begin DoDot:1
+16 if $PIECE(M,U,2)=1
DO EN^DDIOL("Cannot delete Authorization because payments already exist!","","!!")
+17 if $PIECE(M,U,2)=2
DO EN^DDIOL("Cannot delete Authorization because a 7078/583 entry exists!","","!!")
+18 if $PIECE(M,U,2)=3
DO EN^DDIOL("Cannot delete Authorization, please create a Delete type Veteran MRA!","","!!")
+19 DO EN^DDIOL(" ")
End DoDot:1
DELAQ QUIT $SELECT('+$PIECE($GET(M),U,2):0,$PIECE(M,U,2):1,1:0)
