Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BCHUDEL

BCHUDEL.m

Go to the documentation of this file.
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