BCHUDEL.m

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