BMCRDLT.m

BMCRDLT ; IHS/PHXAO/TMJ - REFERRAL DELETE ;

 ;;4.0;REFERRED CARE INFO SYSTEM;;JAN 09, 2006

 ;

 S U="^"

 Q:'$D(BMCRDLT)

 Q:'BMCRDLT

 Q:'$D(^BMCREF(BMCRDLT,0))

 ;

 ;Quit Deletion -reason to quit, ie CHS, ETC.

 Q:$D(^BMCREF(BMCRDSP,41,0))  ;  Quit if CHS Authorization Multiple

 ;Q:$P($G(^BMCREF(BMCRDSP,11)),U,12)]""  ; Quit if CHS Flds 1112 TO 1122

 Q:$P($G(^BMCREF(BMCRDSP,11)),U,13)]""

 Q:$P($G(^BMCREF(BMCRDSP,11)),U,14)]""

 Q:$P($G(^BMCREF(BMCRDSP,11)),U,15)]""

 Q:$P($G(^BMCREF(BMCRDSP,11)),U,16)]""

 Q:$P($G(^BMCREF(BMCRDSP,11)),U,17)]""

 Q:$P($G(^BMCREF(BMCRDSP,11)),U,18)]""

 Q:$P($G(^BMCREF(BMCRDSP,11)),U,19)]""

 ;Q:$P($G(^BMCREF(BMCRDSP,11)),U,20)]""

 ;Q:$P($G(^BMCREF(BMCRDSP,11)),U,21)]""

 ;Q:$P($G(^BMCREF(BMCRDSP,11)),U,22)]""

 Q:$P($G(^BMCREF(BMCRDSP,0)),U,29)]""  ; Quit if PCC Visit Entry

 D DELETE

 D EOJ

 Q

 ;

DELETE ;

 S BMCVFLE=90001 F BMCVL=0:0 S BMCVFLE=$O(^DIC(BMCVFLE)) Q:BMCVFLE>90001.99!(BMCVFLE'=+BMCVFLE)  D DELETE2

 ;S BMCREF=BMCRDLT D DEL^BMCREF K BMCREF

 ;Do not need above line to set Delete Flag but do need to Delete Referral

 ;

 S DA=BMCRDSP,DIK="^BMCREF(" D ^DIK K DIK

 W !!,"Referral Record Deleted - "_BMCRDSP

 Q

 ;

DELETE2 ;

 S BMCVNM=$P(^DIC(BMCVFLE,0),U)

 S BMCVDG=^DIC(BMCVFLE,0,"GL"),BMCVIGR=BMCVDG_"""AD"",BMCRDLT,BMCVDFN)"

 S BMCVDFN="" F BMCVI=1:1 S BMCVDFN=$O(@BMCVIGR) Q:BMCVDFN=""  W:'$D(ZTQUEUED) "." S DIK=BMCVDG,DA=BMCVDFN D ^DIK

 Q

 ;

EOJ ; EOJ CLEANUP

 K BMCVDFN,BMCVDG,BMCRDLT,BMCVFLE,BMCVI,BMCVIGR,BMCVL,BMCVNM,BMCCTR,BMCH,BMCRIO,BMCRREC,BMCRSTAT,BMCSTR

 K %,X

 K D,D0,DA,DIC,DICR,DIE,DIG,DIH,DIU,DIV,DIW,DQ,DR

 Q

BMCRDLT   ; IHS/PHXAO/TMJ - REFERRAL DELETE ;

 +1       ;;4.0;REFERRED CARE INFO SYSTEM;;JAN 09, 2006

 +2       ;

 +3        SET U="^"

 +4        IF '$DATA(BMCRDLT)

               QUIT 

 +5        IF 'BMCRDLT

               QUIT 

 +6        IF '$DATA(^BMCREF(BMCRDLT,0))

               QUIT 

 +7       ;

 +8       ;Quit Deletion -reason to quit, ie CHS, ETC.

 +9       ;  Quit if CHS Authorization Multiple

           IF $DATA(^BMCREF(BMCRDSP,41,0))

               QUIT 

 +10      ;Q:$P($G(^BMCREF(BMCRDSP,11)),U,12)]""  ; Quit if CHS Flds 1112 TO 1122

 +11       IF $PIECE($GET(^BMCREF(BMCRDSP,11)),U,13)]""

               QUIT 

 +12       IF $PIECE($GET(^BMCREF(BMCRDSP,11)),U,14)]""

               QUIT 

 +13       IF $PIECE($GET(^BMCREF(BMCRDSP,11)),U,15)]""

               QUIT 

 +14       IF $PIECE($GET(^BMCREF(BMCRDSP,11)),U,16)]""

               QUIT 

 +15       IF $PIECE($GET(^BMCREF(BMCRDSP,11)),U,17)]""

               QUIT 

 +16       IF $PIECE($GET(^BMCREF(BMCRDSP,11)),U,18)]""

               QUIT 

 +17       IF $PIECE($GET(^BMCREF(BMCRDSP,11)),U,19)]""

               QUIT 

 +18      ;Q:$P($G(^BMCREF(BMCRDSP,11)),U,20)]""

 +19      ;Q:$P($G(^BMCREF(BMCRDSP,11)),U,21)]""

 +20      ;Q:$P($G(^BMCREF(BMCRDSP,11)),U,22)]""

 +21      ; Quit if PCC Visit Entry

           IF $PIECE($GET(^BMCREF(BMCRDSP,0)),U,29)]""

               QUIT 

 +22       DO DELETE

 +23       DO EOJ

 +24       QUIT 

 +25      ;

DELETE    ;

 +1        SET BMCVFLE=90001

           FOR BMCVL=0:0

               SET BMCVFLE=$ORDER(^DIC(BMCVFLE))

               IF BMCVFLE>90001.99!(BMCVFLE'=+BMCVFLE)

                   QUIT 

               DO DELETE2

 +2       ;S BMCREF=BMCRDLT D DEL^BMCREF K BMCREF

 +3       ;Do not need above line to set Delete Flag but do need to Delete Referral

 +4       ;

 +5        SET DA=BMCRDSP

           SET DIK="^BMCREF("

           DO ^DIK

           KILL DIK

 +6        WRITE !!,"Referral Record Deleted - "_BMCRDSP

 +7        QUIT 

 +8       ;

DELETE2   ;

 +1        SET BMCVNM=$PIECE(^DIC(BMCVFLE,0),U)

 +2        SET BMCVDG=^DIC(BMCVFLE,0,"GL")

           SET BMCVIGR=BMCVDG_"""AD"",BMCRDLT,BMCVDFN)"

 +3        SET BMCVDFN=""

           FOR BMCVI=1:1

               SET BMCVDFN=$ORDER(@BMCVIGR)

               IF BMCVDFN=""

                   QUIT 

               IF '$DATA(ZTQUEUED)

                   WRITE "."

               SET DIK=BMCVDG

               SET DA=BMCVDFN

               DO ^DIK

 +4        QUIT 

 +5       ;

EOJ       ; EOJ CLEANUP

 +1        KILL BMCVDFN,BMCVDG,BMCRDLT,BMCVFLE,BMCVI,BMCVIGR,BMCVL,BMCVNM,BMCCTR,BMCH,BMCRIO,BMCRREC,BMCRSTAT,BMCSTR

 +2        KILL %,X

 +3        KILL D,D0,DA,DIC,DICR,DIE,DIG,DIH,DIU,DIV,DIW,DQ,DR

 +4        QUIT