- 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 Jan 18, 2025@03:01:16 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)