BDGICE3.m

BDGICE3 ;cmi/anch/maw - NEW INCOMPLETE CHART EDIT OPTION 5/12/2008 1:47:45 PM

 ;;5.3;PIMS;**1004,1006,1009**;MAY 28, 2004

 ;

 ;

EDITPRV ;EP - edit the provider but keep track of deficiency - called by BDG IC EDIT PROVIDER protocol

 ; EP; add chart deficiences - called by BDG ICE ADD DEF protocol

 NEW PROV,BDGDEF,COUNT,ACTION,CHOICES,Y,DIE,DR,DA,I,SCREEN,DATE,NEWPRV,BDGNN

 D FULL^VALM1

 L +^BDGIC(BDGN):1 I '$T D MSG^BDGF("Someone Else is editing this record currently",1,1),PAUSE^BDGF Q

 S PROMPT="Select PROVIDER",SCREEN="I $D(^XUSEC(""PROVIDER"",+Y))&($P($G(^VA(200,+Y,""PS"")),U,4)="""")"

 F  D  Q:PROV<1

 . D MSG^BDGF("",1,0)

 . S PROV=+$$READ^BDGF("PO^200:EMQZ",PROMPT,"","",SCREEN)

 . Q:PROV<1

 . ;

 . ; stay in this provider until told to quit

 . S QUIT=0 F  D  Q:QUIT

 . . K BDGDEF D FINDDEF^BDGICE2(BDGN,PROV)                                          ;build array of deficiencies for provider

 . . I '$D(BDGDEF)  D MSG^BDGF($$SP^BDGICE2(5)_"There are no deficiencies for this Provider",2,0) S QUIT=1 Q

 . . ;

 . . D MSG^BDGF($$SP^BDGICE2(5)_"*** "_$$GET1^DIQ(200,PROV,.01)_" Deficiencies ***",2,0)

 . . F COUNT=1:1 Q:'$D(BDGDEF(COUNT))  D MSG^BDGF($P(BDGDEF(COUNT),U),1,0)  ;display deficiencies

 . . ;

 . . D MSG^BDGF("",1,0)

 . . S CHOICES=$$READ^BDGF("LO^1:"_(COUNT-1),"Select Which Deficiency to change Provider for")

 . . D MSG^BDGF("",1,0)

 . . I +CHOICES<1 S QUIT=1 Q

 . . S NEWPRV=+$$READ^BDGF("PO^200:EMQZ","Change to which Provider","","",SCREEN)

 . . I NEWPRV<1 S QUIT=1 Q

 . . I PROV=NEWPRV D MSG^BDGF($$SP^BDGICE2(5)_"You cannot select the same provider",2,0) S QUIT=1 Q

 . . S BDGNN=$$ADDNEW(BDGN,NEWPRV)

 . . I 'BDGNN D MSG^BDGF($$SP^BDGICE2(5)_"Error copying deficiency information from old provider to new",2,0) S QUIT=1 Q

 . . D STUFFNEW(BDGN,BDGNN,$TR(CHOICES,",",""))

 . . D CLOSEOUT(BDGN,PROV,$TR(CHOICES,",",""))

 . . ;

 L -^BDGIC(BDGN)

 D REBUILD^BDGICE2

 Q

 ;

ADDNEW(N,NPRV) ;-- add a new entry for new provider

 K DIC,DA,DD,DO

 S DA(1)=N

 S DIC(0)="L",DIC="^BDGIC("_N_",1,"

 S DIC("P")=$P(^DD(9009016.1,1,0),U,2),DLAYGO=9009016.11

 S X=NPRV

 D FILE^DICN

 Q +Y

 ;

CLOSEOUT(N,P,C) ;-- closeout the previous provider

 K DR,DIE

 S DIE="^BDGIC("_BDGN_",1,",DR=".04////"_DT_";.05///Provider Change;.06///Auto changed BDG IC EDIT PROVIDER protocol action"

 S DA(1)=N,DA=C

 D ^DIE

 K DIE

 Q

 ;

STUFFNEW(N,NN,CH) ;-- now add the new entry

 K DR,DIE

 N DATA,A,B,C,D,E

 S DATA=$G(^BDGIC(N,1,CH,0))

 S A=$P(DATA,U,2)

 S B=$P(DATA,U,3)

 S C=$P(DATA,U,4)

 S D=$P(DATA,U,5)

 S E=$P(DATA,U,6)

 S DIE="^BDGIC("_N_",1,",DA(1)=N,DA=NN

 S DR=".02////"_A_";.03////"_B_";.04////"_C_";.05////"_D_";.06////"_E

 D ^DIE

 K DIE

 Q

 ;

BDGICE3   ;cmi/anch/maw - NEW INCOMPLETE CHART EDIT OPTION 5/12/2008 1:47:45 PM

 +1       ;;5.3;PIMS;**1004,1006,1009**;MAY 28, 2004

 +2       ;

 +3       ;

EDITPRV   ;EP - edit the provider but keep track of deficiency - called by BDG IC EDIT PROVIDER protocol

 +1       ; EP; add chart deficiences - called by BDG ICE ADD DEF protocol

 +2        NEW PROV,BDGDEF,COUNT,ACTION,CHOICES,Y,DIE,DR,DA,I,SCREEN,DATE,NEWPRV,BDGNN

 +3        DO FULL^VALM1

 +4        LOCK +^BDGIC(BDGN):1

           IF '$TEST

               DO MSG^BDGF("Someone Else is editing this record currently",1,1)

               DO PAUSE^BDGF

               QUIT 

 +5        SET PROMPT="Select PROVIDER"

           SET SCREEN="I $D(^XUSEC(""PROVIDER"",+Y))&($P($G(^VA(200,+Y,""PS"")),U,4)="""")"

 +6        FOR 

               Begin DoDot:1

 +7                DO MSG^BDGF("",1,0)

 +8                SET PROV=+$$READ^BDGF("PO^200:EMQZ",PROMPT,"","",SCREEN)

 +9                IF PROV<1

                       QUIT 

 +10      ;

 +11      ; stay in this provider until told to quit

 +12               SET QUIT=0

                   FOR 

                       Begin DoDot:2

 +13      ;build array of deficiencies for provider

                           KILL BDGDEF

                           DO FINDDEF^BDGICE2(BDGN,PROV)

 +14                       IF '$DATA(BDGDEF)

                               DO MSG^BDGF($$SP^BDGICE2(5)_"There are no deficiencies for this Provider",2,0)

                               SET QUIT=1

                               QUIT 

 +15      ;

 +16                       DO MSG^BDGF($$SP^BDGICE2(5)_"*** "_$$GET1^DIQ(200,PROV,.01)_" Deficiencies ***",2,0)

 +17      ;display deficiencies

                           FOR COUNT=1:1

                               IF '$DATA(BDGDEF(COUNT))

                                   QUIT 

                               DO MSG^BDGF($PIECE(BDGDEF(COUNT),U),1,0)

 +18      ;

 +19                       DO MSG^BDGF("",1,0)

 +20                       SET CHOICES=$$READ^BDGF("LO^1:"_(COUNT-1),"Select Which Deficiency to change Provider for")

 +21                       DO MSG^BDGF("",1,0)

 +22                       IF +CHOICES<1

                               SET QUIT=1

                               QUIT 

 +23                       SET NEWPRV=+$$READ^BDGF("PO^200:EMQZ","Change to which Provider","","",SCREEN)

 +24                       IF NEWPRV<1

                               SET QUIT=1

                               QUIT 

 +25                       IF PROV=NEWPRV

                               DO MSG^BDGF($$SP^BDGICE2(5)_"You cannot select the same provider",2,0)

                               SET QUIT=1

                               QUIT 

 +26                       SET BDGNN=$$ADDNEW(BDGN,NEWPRV)

 +27                       IF 'BDGNN

                               DO MSG^BDGF($$SP^BDGICE2(5)_"Error copying deficiency information from old provider to new",2,0)

                               SET QUIT=1

                               QUIT 

 +28                       DO STUFFNEW(BDGN,BDGNN,$TRANSLATE(CHOICES,",",""))

 +29                       DO CLOSEOUT(BDGN,PROV,$TRANSLATE(CHOICES,",",""))

 +30      ;

                       End DoDot:2

                       IF QUIT

                           QUIT 

               End DoDot:1

               IF PROV<1

                   QUIT 

 +31       LOCK -^BDGIC(BDGN)

 +32       DO REBUILD^BDGICE2

 +33       QUIT 

 +34      ;

ADDNEW(N,NPRV) ;-- add a new entry for new provider

 +1        KILL DIC,DA,DD,DO

 +2        SET DA(1)=N

 +3        SET DIC(0)="L"

           SET DIC="^BDGIC("_N_",1,"

 +4        SET DIC("P")=$PIECE(^DD(9009016.1,1,0),U,2)

           SET DLAYGO=9009016.11

 +5        SET X=NPRV

 +6        DO FILE^DICN

 +7        QUIT +Y

 +8       ;

CLOSEOUT(N,P,C) ;-- closeout the previous provider

 +1        KILL DR,DIE

 +2        SET DIE="^BDGIC("_BDGN_",1,"

           SET DR=".04////"_DT_";.05///Provider Change;.06///Auto changed BDG IC EDIT PROVIDER protocol action"

 +3        SET DA(1)=N

           SET DA=C

 +4        DO ^DIE

 +5        KILL DIE

 +6        QUIT 

 +7       ;

STUFFNEW(N,NN,CH) ;-- now add the new entry

 +1        KILL DR,DIE

 +2        NEW DATA,A,B,C,D,E

 +3        SET DATA=$GET(^BDGIC(N,1,CH,0))

 +4        SET A=$PIECE(DATA,U,2)

 +5        SET B=$PIECE(DATA,U,3)

 +6        SET C=$PIECE(DATA,U,4)

 +7        SET D=$PIECE(DATA,U,5)

 +8        SET E=$PIECE(DATA,U,6)

 +9        SET DIE="^BDGIC("_N_",1,"

           SET DA(1)=N

           SET DA=NN

 +10       SET DR=".02////"_A_";.03////"_B_";.04////"_C_";.05////"_D_";.06////"_E

 +11       DO ^DIE

 +12       KILL DIE

 +13       QUIT 

 +14      ;