BCHUDEL ; IHS/CMI/LAB - DELETE CHR RECORD ;
;;2.0;IHS RPMS CHR SYSTEM;;OCT 23, 2012;Build 27
;
; PASS BCHR as ien of chr record to delete
EN ;EP
D FULL^VALM1
W $C(7),$C(7)
DELETE ;EP; Entry Point to Delete Record ;IHS/CMI/TMJ PATCH #6
Q:'$G(BCHR)
D P
S BCHEV("VFILES",9000010)=$P(^BCHR(BCHR,0),U,15)
S X=0 F S X=$O(^BCHR(BCHR,31,X)) Q:X'=+X S F=$P(^BCHR(BCHR,31,X,0),U),N=$P(^(0),U,2) I F,N S BCHEV("VFILES",F,N)=""
S BCHVFLE=90002 F BCHVL=0:0 S BCHVFLE=$O(^DIC(BCHVFLE)) Q:BCHVFLE>90002.09!(BCHVFLE'=+BCHVFLE) D DELETE2
;S BCHEV("TYPE")="D" D PROTOCOL^BCHUADD1
;update delete file
DELREC ;
;delete record
I $G(BCHSTOP) D EOJ Q
S DIK="^BCHR(",DA=BCHR D ^DIK K DA,DIK
;call protocol
D EOJ
Q
;
DELETE2 ;
S BCHVNM=$P(^DIC(BCHVFLE,0),U)
S BCHVDG=^DIC(BCHVFLE,0,"GL"),BCHVIGR=BCHVDG_"""AD"",BCHR,BCHVDFN)"
S BCHVDFN="" F BCHVI=1:1 S BCHVDFN=$O(@BCHVIGR) Q:BCHVDFN="" W:'$D(ZTQUEUED) "." S DIK=BCHVDG,DA=BCHVDFN D ^DIK
Q
P ;get providers (1-4)
Q:$P(^BCHR(BCHR,0),U,19)="" ;don't bother if never sent
I $P(^BCHR(BCHR,0),U,3)="" Q
S BCHAFF=$$PPAFFL^BCHUTIL(BCHR,"I") I BCHAFF=""!(BCHAFF["?") Q
S BCHDISC=$$PPCLSC^BCHUTIL(BCHR) I BCHDISC=""!(BCHDISC["?") Q
S BCHINI=$$PPINI^BCHUTIL(BCHR)
P1 S X=BCHAFF_BCHDISC_BCHINI
S X=$$LBLK(X,6),BCHP=X
S (Z,C,I)=0 F S I=$O(^BCHRPROB("AD",BCHR,I)) Q:I'=+I S C=C+1,Z=C_"|"
Q:Z=""
S X=BCHP,DIC("DR")=".02///"_$P(^BCHTPROG($P(^BCHR(BCHR,0),U,2),0),U,5)_";.03////"_$P(^BCHR(BCHR,0),U)_";.04///"_$P(^BCHR(BCHR,0),U,25)_";.05////"_DT_";.07////"_Z,DLAYGO=90002.95,DIADD=1,DIC="^BCHEXDEL(",DIC(0)="EL" K DD,DO D FILE^DICN
K DIC,DIE,DR,DA,DIADD,DLAYGO,X,Y
Q
;
DEL ;EP entry point from delete protocol from list manager , select record in list manager and then call EN^BCHUDEL
D EN^VALM2(XQORNOD(0),"OS")
I '$D(VALMY) W !,"No records selected." G EXIT
S BCHR=$O(VALMY(0)) I 'BCHR K BCHR,VALMY,XQORNOD W !,"No record selected." G EXIT
S BCHR=BCHVRECS("IDX",BCHR,BCHR) I 'BCHR K BCHR,BCHR D EXIT Q
I '$D(^BCHR(BCHR,0)) W !,"Not a valid CHR RECORD." K BCHR,BCHR D EXIT Q
DISP ;
D FULL^VALM1
D EN^BCHUDSP
S DIR(0)="Y",DIR("A")="Are you sure you want to DELETE this record",DIR("B")="N" D ^DIR K DIR S:$D(DUOUT) DIRUT=1
I $D(DIRUT) W !!,"Nothing deleted.!",! D EXIT Q
I 'Y W !!,"Nothing deleted.!",! D EXIT Q
D EN^BCHUDEL
W !,"Record deleted."
D EXIT
Q
LBLK(V,L) ;left blank fill
NEW %,I
S %=$L(V),Z=L-% F I=1:1:Z S V=" "_V
Q V
EXIT ;EP
S VALMBCK="R"
D PAUSE^BCHUTIL1
D GATHER^BCHUARL
S VALMCNT=BCHRCNT
D HDR^BCHUAR
K BCHV,BCHF,BCHDR,DFN,BCHR,BCHQUIT,BCHR,BCHV,BCHVDLT
Q
EOJ ; EOJ CLEANUP
K BCHVDFN,BCHVDG,BCHR,BCHVFLE,BCHVI,BCHVIGR,BCHVL,BCHVNM,BCHAFF,BCHDISC,BCHINI,BCHP
K %,X
K D,D0,DA,DIC,DICR,DIE,DIG,DIH,DIU,DIV,DIW,DQ,DR,DIK
Q
BCHUDEL ; IHS/CMI/LAB - DELETE CHR RECORD ;
+1 ;;2.0;IHS RPMS CHR SYSTEM;;OCT 23, 2012;Build 27
+2 ;
+3 ; PASS BCHR as ien of chr record to delete
EN ;EP
+1 DO FULL^VALM1
+2 WRITE $CHAR(7),$CHAR(7)
DELETE ;EP; Entry Point to Delete Record ;IHS/CMI/TMJ PATCH #6
+1 IF '$GET(BCHR)
QUIT
+2 DO P
+3 SET BCHEV("VFILES",9000010)=$PIECE(^BCHR(BCHR,0),U,15)
+4 SET X=0
FOR
SET X=$ORDER(^BCHR(BCHR,31,X))
IF X'=+X
QUIT
SET F=$PIECE(^BCHR(BCHR,31,X,0),U)
SET N=$PIECE(^(0),U,2)
IF F
IF N
SET BCHEV("VFILES",F,N)=""
+5 SET BCHVFLE=90002
FOR BCHVL=0:0
SET BCHVFLE=$ORDER(^DIC(BCHVFLE))
IF BCHVFLE>90002.09!(BCHVFLE'=+BCHVFLE)
QUIT
DO DELETE2
+6 ;S BCHEV("TYPE")="D" D PROTOCOL^BCHUADD1
+7 ;update delete file
DELREC ;
+1 ;delete record
+2 IF $GET(BCHSTOP)
DO EOJ
QUIT
+3 SET DIK="^BCHR("
SET DA=BCHR
DO ^DIK
KILL DA,DIK
+4 ;call protocol
+5 DO EOJ
+6 QUIT
+7 ;
DELETE2 ;
+1 SET BCHVNM=$PIECE(^DIC(BCHVFLE,0),U)
+2 SET BCHVDG=^DIC(BCHVFLE,0,"GL")
SET BCHVIGR=BCHVDG_"""AD"",BCHR,BCHVDFN)"
+3 SET BCHVDFN=""
FOR BCHVI=1:1
SET BCHVDFN=$ORDER(@BCHVIGR)
IF BCHVDFN=""
QUIT
IF '$DATA(ZTQUEUED)
WRITE "."
SET DIK=BCHVDG
SET DA=BCHVDFN
DO ^DIK
+4 QUIT
P ;get providers (1-4)
+1 ;don't bother if never sent
IF $PIECE(^BCHR(BCHR,0),U,19)=""
QUIT
+2 IF $PIECE(^BCHR(BCHR,0),U,3)=""
QUIT
+3 SET BCHAFF=$$PPAFFL^BCHUTIL(BCHR,"I")
IF BCHAFF=""!(BCHAFF["?")
QUIT
+4 SET BCHDISC=$$PPCLSC^BCHUTIL(BCHR)
IF BCHDISC=""!(BCHDISC["?")
QUIT
+5 SET BCHINI=$$PPINI^BCHUTIL(BCHR)
P1 SET X=BCHAFF_BCHDISC_BCHINI
+1 SET X=$$LBLK(X,6)
SET BCHP=X
+2 SET (Z,C,I)=0
FOR
SET I=$ORDER(^BCHRPROB("AD",BCHR,I))
IF I'=+I
QUIT
SET C=C+1
SET Z=C_"|"
+3 IF Z=""
QUIT
+4 SET X=BCHP
SET DIC("DR")=".02///"_$PIECE(^BCHTPROG($PIECE(^BCHR(BCHR,0),U,2),0),U,5)_";.03////"_$PIECE(^BCHR(BCHR,0),U)_";.04///"_$PIECE(^BCHR(BCHR,0),U,25)_";.05////"_DT_";.07////"_Z
SET DLAYGO=90002.95
SET DIADD=1
SET DIC="^BCHEXDEL("
SET DIC(0)="EL"
KILL DD,DO
DO FILE^DICN
+5 KILL DIC,DIE,DR,DA,DIADD,DLAYGO,X,Y
+6 QUIT
+7 ;
DEL ;EP entry point from delete protocol from list manager , select record in list manager and then call EN^BCHUDEL
+1 DO EN^VALM2(XQORNOD(0),"OS")
+2 IF '$DATA(VALMY)
WRITE !,"No records selected."
GOTO EXIT
+3 SET BCHR=$ORDER(VALMY(0))
IF 'BCHR
KILL BCHR,VALMY,XQORNOD
WRITE !,"No record selected."
GOTO EXIT
+4 SET BCHR=BCHVRECS("IDX",BCHR,BCHR)
IF 'BCHR
KILL BCHR,BCHR
DO EXIT
QUIT
+5 IF '$DATA(^BCHR(BCHR,0))
WRITE !,"Not a valid CHR RECORD."
KILL BCHR,BCHR
DO EXIT
QUIT
DISP ;
+1 DO FULL^VALM1
+2 DO EN^BCHUDSP
+3 SET DIR(0)="Y"
SET DIR("A")="Are you sure you want to DELETE this record"
SET DIR("B")="N"
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+4 IF $DATA(DIRUT)
WRITE !!,"Nothing deleted.!",!
DO EXIT
QUIT
+5 IF 'Y
WRITE !!,"Nothing deleted.!",!
DO EXIT
QUIT
+6 DO EN^BCHUDEL
+7 WRITE !,"Record deleted."
+8 DO EXIT
+9 QUIT
LBLK(V,L) ;left blank fill
+1 NEW %,I
+2 SET %=$LENGTH(V)
SET Z=L-%
FOR I=1:1:Z
SET V=" "_V
+3 QUIT V
EXIT ;EP
+1 SET VALMBCK="R"
+2 DO PAUSE^BCHUTIL1
+3 DO GATHER^BCHUARL
+4 SET VALMCNT=BCHRCNT
+5 DO HDR^BCHUAR
+6 KILL BCHV,BCHF,BCHDR,DFN,BCHR,BCHQUIT,BCHR,BCHV,BCHVDLT
+7 QUIT
EOJ ; EOJ CLEANUP
+1 KILL BCHVDFN,BCHVDG,BCHR,BCHVFLE,BCHVI,BCHVIGR,BCHVL,BCHVNM,BCHAFF,BCHDISC,BCHINI,BCHP
+2 KILL %,X
+3 KILL D,D0,DA,DIC,DICR,DIE,DIG,DIH,DIU,DIV,DIW,DQ,DR,DIK
+4 QUIT
