APCDCAF6 ;IHS/OIT/LJF - NEW INCOMPLETE CHART EDIT OPTION ; 23 Mar 2015 12:30 PM
;;2.0;IHS PCC SUITE;**11**;MAY 14, 2009;Build 58
;
;
MSG(DATA,PRE,POST) ;EP; -- writes line to device;IHS/ITSC/LJF PATCH 1003
NEW I,FORMAT
S FORMAT="" I $G(PRE)>0 F I=1:1:PRE S FORMAT=FORMAT_"!"
D EN^DDIOL(DATA,"",FORMAT)
I $G(POST)>0 F I=1:1:POST D EN^DDIOL("","","!")
Q
CDE ;EP
K DIR
S DIR(0)="NO^1:"_APCDRCNT,DIR("A")="Which Visit"
D ^DIR K DIR S:$D(DUOUT) DIRUT=1
I Y="" W !,"No VISIT selected." D EOP^APCDCAF G CDEX
I $D(DIRUT) W !,"No VISIT selected." D EOP^APCDCAF G CDEX
S APCDVSIT=^TMP("APCDCAF",$J,"IDX",Y,Y)
K VALMBCK
S APCDCAFV=APCDVSIT,APCDPAT=$P(^AUPNVSIT(APCDVSIT,0),U,5) D EN(APCDVSIT)
;
CDEX ;
K DIR,DIRUT,DUOUT,Y,APCDVSIT,APCDCAF,APCDCAFV
D KILL^AUPNPAT
D BACK^APCDCAF
Q
HRCN(PAT,SITE) ;EP; return chart number for patient at this site
;
I $G(PAT)="" Q ""
Q $P($G(^AUPNPAT(PAT,41,SITE,0)),U,2)
;
EN(APCDVSIT) ;EP; -- main entry point for OUTPT CHART DEFICIENY
; called with APCDVSIT set
NEW VALMCNT D TERM^VALM0,CLEAR^VALM1
NEW APCDDALL S APCDDALL=1
D EN^VALM("APCDCAF CDE EDIT")
D CLEAR^VALM1
Q
;
HDR ;EP; -- header code
NEW X
S X=$$PAD($G(IORVON)_$$GET1^DIQ(2,+$G(APCDPAT),.01)_$G(IORVOFF),35)_"#"_$$HRCN(+$G(APCDPAT),DUZ(2))
S VALMHDR(1)=X
;
S X=$$PAD("Visit Date: "_$$GET1^DIQ(9000010,APCDVSIT,.01),40)_"Service Category: "_$$GET1^DIQ(9000010,APCDVSIT,.07)
S VALMHDR(2)=X
S X=$$PAD("Hospital Location: "_$$GET1^DIQ(9000010,APCDVSIT,.22),40)_"Clinic: "_$$GET1^DIQ(9000010,APCDVSIT,.08)
S VALMHDR(3)=X
S X="Primary Provider: "_$$PRIMPROV^APCLV(APCDVSIT,"N")
S VALMHDR(4)=X
Q
;
INIT ;EP; -- init variables and list array
D INIT^APCDCAF7
Q
;
SET(DATA,COUNT) ; stuff data into display lie
S COUNT=COUNT+1
S APCDCDEV(COUNT,0)=DATA
Q
;
HELP ;EP; -- help code
S X="?" D DISP^XQORM1 W !!
Q
;
EXIT ;EP; -- exit code
K APCDDALL,APCDVSIT
Q
;
EXPND ; -- expand code
Q
;
REBUILD ; EP; rebuild display
;
D TERM^VALM0
D HDR,INIT
S VALMBCK="R"
Q
;
EDITTD ; EP; edit tracking dates - called by APCD ICE DATES
D FULL^VALM1 NEW ITEM,FIELD,DIE,DA,DR,Y
I '$D(^AUPNCANT(APCDVSIT,0)) D ADDCANT^APCDCAF1
S DIE="^AUPNCANT(",DA=APCDVSIT
L +^AUPNCANT(APCDVSIT):1 I '$T D MSG("Another person is editing this entry!",2,0) D PAUSE^APCDALV1,REBUILD Q
NEW APCDX
S APCDX=$O(^AUPNCANT(APCDVSIT,12,"AC",0))
S DR=".03//"_$$FMTE^XLFDT(APCDX)
D ^DIE
K DA,DR,DIE
L -^AUPNCANT(APCDVSIT)
W !,"Reviewed/Complete: ",$$DMRC(APCDVSIT)
D PAUSE^APCDALV1
D REBUILD
Q
;
CAN ; EP; CHART AUDIT NOTE EDIT
NEW DIE,DA,DR
D FULL^VALM1
I '$D(^AUPNCANT(APCDVSIT)) D ADDCANT^APCDCAF1
I '$D(^AUPNCANT(APCDVSIT)) W !!,"adding entry to chart audit notes failed." H 3 G CANX
W ! S DA=APCDVSIT,DIE="^AUPNCANT(",DR=1100 D ^DIE K DIE,DA,DR
;
CANX ;
D PAUSE^APCDALV1,REBUILD
Q
;
READ(TYPE,PROMPT,DEFAULT,HELP,SCREEN,DIRA) ;EP; calls reader, returns response
NEW DIR,Y,DIRUT
S DIR(0)=TYPE
I $E(TYPE,1)="P",$P(TYPE,":",2)["L" S DLAYGO=+$P(TYPE,U,2)
I $D(SCREEN),SCREEN]"" S DIR("S")=SCREEN
I $G(PROMPT)]"" S DIR("A")=PROMPT
I $G(DEFAULT)]"" S DIR("B")=DEFAULT
I $D(HELP) S DIR("?")=HELP
I $D(DIRA(1)) S Y=0 F S Y=$O(DIRA(Y)) Q:Y="" S DIR("A",Y)=DIRA(Y)
D ^DIR
Q Y
;
ADDDEF ; EP; add chart deficiences - called by APCD ICE ADD DEF protocol
NEW PROV,APCDDEF,COUNT,ACTION,CHOICES,Y,DIE,DR,DA,I,SCREEN,DATE
D FULL^VALM1
L +^AUPNCANT(APCDVSIT):1 I '$T D MSG("Someone Else is editing this record currently",1,1),PAUSE^APCDALV1 Q
S PROMPT="Select PROVIDER",SCREEN="" ;,SCREEN="I $D(^XUSEC(""PROVIDER"",+Y))&($P($G(^VA(200,+Y,""PS"")),U,4)="""")"
F D Q:PROV<1
. D MSG("",1,0)
. S PROV=+$$READ("PO^200:EMQZ",PROMPT,"","",SCREEN)
. Q:PROV<1
. ;
. ; stay in this provider until told to quit
. S QUIT=0 F D Q:QUIT
. . K APCDDEF D FINDDEF(APCDVSIT,PROV) ;build array of deficiencies for provider
. . I '$D(APCDDEF) D ADDMORE(APCDVSIT,PROV) S QUIT=1 Q ;if none yet, go to add mode
. . ;
. . D MSG($$SP(5)_"*** "_$$GET1^DIQ(200,PROV,.01)_" Deficiencies ***",2,0)
. . F COUNT=1:1 Q:'$D(APCDDEF(COUNT)) D MSG($P(APCDDEF(COUNT),U),1,0) ;display deficiencies
. . ;
. . D MSG("",1,0)
. . S ACTION(1)=" 1. ADD New Deficiencies"
. . S ACTION(2)=" 2. EDIT Selected Deficiencies"
. . S ACTION(3)=" 3. RESOLVE Selected Deficiencies"
. . S ACTION(4)=" 4. DELETE Selected Deficiencies"
. . S ACTION(5)=" 5. QUIT"
. . S Y=$$READ("NO^1:5","Select Action",5,"","",.ACTION) Q:Y<1
. . I Y=5 S QUIT=1 Q
. . I Y=1 D ADDMORE(APCDVSIT,PROV) Q
. . S ACTION=Y
. . ;
. . S CHOICES=$$READ("LO^1:"_(COUNT-1),"Select Which Deficiencies to "_$S(ACTION=2:"EDIT",ACTION=4:"DELETE",1:"RESOLVE"))
. . Q:CHOICES<1
. . ;
. . ; close multiple deficiencies
. . I ACTION=3 D Q
. . . S DATE=$$READ("D^::EX","Enter DATE RESOLVED") Q:'DATE
. . . S DIE="^AUPNCANT("_APCDVSIT_",12,",DR=".03///"_DATE_";.11///R;.06////"_DT_";.07////"_DUZ,DA(1)=APCDVSIT
. . . F I=1:1 S J=$P(CHOICES,",",I) Q:J="" W !?3,"Closing "_$E($P(APCDDEF(J),U),5,40) S DA=$P(APCDDEF(J),U,2) D ^DIE
. . . K DA,DR,DIE ;
. . I ACTION=4 D Q ;DELETE SELECTED DEFICIENCIES
. . . S DATE=$$READ("DO^::EX","Enter DATE DELETED") Q:'DATE
. . . S DIE="^AUPNCANT("_APCDVSIT_",12,",DR=".08///"_DATE_";.11///D;.06////"_DT_";.07////"_DUZ_";.09",DA(1)=APCDVSIT
. . . F I=1:1 S J=$P(CHOICES,",",I) Q:J="" W !?3,"Deleting "_$E($P(APCDDEF(J),U),5,40) S DA=$P(APCDDEF(J),U,2) D ^DIE
. . . K DA,DR,DIE ;
. . ; else edit selected deficiencies
. . S DIE="^AUPNCANT("_APCDVSIT_",12,",DR=".06////"_DT_";.07////"_DUZ_";.02;.1",DA(1)=APCDVSIT
. . F I=1:1 S J=$P(CHOICES,",",I) Q:J="" D
. . . D MSG($P(APCDDEF(J),U),2,0)
. . . S DA=$P(APCDDEF(J),U,2)
. . . D ^DIE
L -^AUPNCANT(APCDVSIT)
D VCAUPD
D REBUILD
Q
;
FINDDEF(APCDVSIT,PRV) ; return APCDDEF array with current deficiencies for provider PRV -pending ONLY
NEW COUNT,IEN,LINE,IENS
S (IEN,COUNT)=0
F S IEN=$O(^AUPNCANT(APCDVSIT,12,"B",PROV,IEN)) Q:'IEN D
. S IENS=IEN_","_APCDVSIT
. Q:$$GET1^DIQ(9000095.12,IENS,.11,"I")'="P"
. S COUNT=COUNT+1
. S LINE=$$PAD($J(COUNT,3),5)_$$GET1^DIQ(9000095.12,IENS,.02) ;def name
. S LINE=$$PAD(LINE,40)_$$GET1^DIQ(9000095.12,IENS,.11) ;status
. S APCDDEF(COUNT)=LINE_U_IEN
Q
FINDPEND(V) ;EP - are there any pending deficiencies
I '$G(V) Q ""
NEW COUNT,IEN,J
S (IEN,COUNT)=0
F S IEN=$O(^AUPNCANT(V,12,IEN)) Q:IEN'=+IEN!(COUNT) D
. S IENS=IEN_","_V
. Q:$$GET1^DIQ(9000095.12,IENS,.11,"I")'="P"
. S COUNT=COUNT+1
Q COUNT
;
ADDMORE(APCDVSIT,PRV) ; add new deficiencies for provider
NEW DIE,DR,DA,QUIT,DIC,DEF,DLAYGO,Y,IENS
D MSG(" Add Mode for Deficiencies. . .",2,0)
I '$D(^AUPNCANT(APCDVSIT,0)) D ADDCANT^APCDCAF1
S QUIT=0 F D Q:QUIT
. K DIC S DIC="^AUTTCDR(",DIC(0)="AEMQZ"
. D ^DIC S DEF=+Y I Y<1 S QUIT=1 Q
. ;
. I $$HAVEDEF(APCDVSIT,PRV,DEF) Q:'$$READ("Y","This deficiency already defined for this provider. Do you really want to add it again","NO")
. ;
. Q:'$$READ("Y","Okay to add "_Y(0,0)_" for this provider","YES")
. K DIC,DA,DD,DO
. S DIC="^AUPNCANT("_APCDVSIT_",12,",DA(1)=APCDVSIT,X=PRV,DIC(0)="L"
. S DIC("P")=$P(^DD(9000095,1200,0),U,2),DLAYGO=9000095.12
. S DIC("DR")=".02///"_DEF_";.04////"_DT_";.05////"_DUZ_";.06////"_DT_";.07////"_DUZ_";.11///P"
. D FILE^DICN Q:Y=-1
. ;
. S DIE="^AUPNCANT("_APCDVSIT_",12,",DA(1)=APCDVSIT,DA=+Y,DR=".03;.1" D ^DIE
. S IENS=DA_","_APCDVSIT
. I $$GET1^DIQ(9000095.12,IENS,.03,"I")]"" S DR=".11///R" D ^DIE
. K DIE,DA,DR
Q
;
HAVEDEF(APCDVSIT,PRV,DEF) ;returns 1 if this record & this provider already have this deficincy defined
NEW IEN,FOUND
S (IEN,FOUND)=0 F S IEN=$O(^AUPNCANT(APCDVSIT,12,"B",PRV,IEN)) Q:'IEN Q:FOUND D
. I $P(^AUPNCANT(APCDVSIT,12,IEN,0),U,11)'="P"
. I $P(^AUPNCANT(APCDVSIT,12,IEN,0),U,2)=DEF S FOUND=1
Q FOUND
;
UPDATE ;EP
D FULL^VALM1
S APCDERR=$$ERRORCHK^APCDCAF(APCDVSIT)
I APCDERR]"" W !!,"This visit has the following error: ",APCDERR,!,"You cannot mark a visit as Reviewed/Completed if there is an error." D PAUSE^APCDALV1 G UPDATEX
S AUPNVSIT=APCDVSIT D MOD^AUPNVSIT K AUPNVSIT
UPD0 ;
K DIC,DD,D0,DO
S X=$$NOW^XLFDT,DIC="^AUPNVCA(",DIC(0)="L",DIADD=1,DLAYGO=9000010.45
S DIC("DR")=".02////"_$P(^AUPNVSIT(APCDVSIT,0),U,5)_";.03////"_APCDVSIT_";.04///R;.05////"_DUZ_";1216////"_$$NOW^XLFDT D FILE^DICN
I Y=-1 W !!,"updating status failed" D PAUSE^APCDALV1 G UPDATEX
K DIC,DD,D0,DIADD,DLAYGO
S (APCDVCA,DA)=+Y
UPD1 ;
;
S DIE="^AUPNVSIT(",DA=APCDVSIT,DR=".13////"_DT_";1111///R" D ^DIE K DIE,DA,DR
D RNU^APCDCAF4
UPDATEX ;
K DIADD,DLAYGO
D ^XBFMK
K APCDCAR,APCDCVA
D REBUILD
Q
;
VCAUPD ;
NEW APCDVCA
K DIC,DD,D0,DO
S X=$$NOW^XLFDT,DIC="^AUPNVCA(",DIC(0)="L",DIADD=1,DLAYGO=9000010.45
S DIC("DR")=".02////"_$P(^AUPNVSIT(APCDVSIT,0),U,5)_";.03////"_APCDVSIT_";.05////"_DUZ_";1216////"_$$NOW^XLFDT D FILE^DICN
I Y=-1 W !!,"updating status failed" D PAUSE^APCDALV1 Q
K DIC,DD,D0,DIADD,DLAYGO
S (APCDVCA,DA)=+Y
VCAUPD1 ;
D ^XBFMK
S S=0
I $$ERRORCHK^APCDCAF(APCDVSIT)]"" S S=1
I $$FINDPEND(APCDVSIT) S S=1
I S S APCDCAR="I",DA=APCDVCA,DIE="^AUPNVCA(",DR=".04///I" D ^DIE K DA,DIE,DR G VCAUPD2
I 'S S DA=APCDVCA,DIE="^AUPNVCA(",DR=".04" D ^DIE K DA,DIE,DR
D ^XBFMK
S APCDCAR=$P(^AUPNVCA(APCDVCA,0),U,4)
I APCDCAR="" W !!,"You must enter a status" G VCAUPD1
S APCDERR=$$ERRORCHK^APCDCAF(APCDVSIT)
I APCDERR]"",APCDCAR="R" W !!,"This visit has the following error: ",APCDERR,!,"You cannot mark a visit as Reviewed/Completed if there is an error." S DA=APCDVCA,DIE="^AUPNVCA(",DR=".04///I" D ^DIE G VCAUPD1
VCAUPD2 ;
S DIE="^AUPNVSIT(",DA=APCDVSIT,DR=".13////"_DT_";1111////"_APCDCAR D ^DIE K DIE,DA,DR
Q
;
;
PAD(D,L) ;EP pad length of data
; -- D=data L=length
Q $E(D_$$REPEAT^XLFSTR(" ",L),1,L)
;
SP(N) ; pad N number of spaces
Q $$PAD(" ",N)
;
DSOKAY() ; EP; does site use day surgery?
Q $$GET1^DIQ(9009020.1,$$DIV^BSDU,201,"I")
;
LABEL(FIELD) ; returns field's title or label
NEW X
S X=$$GET1^DID(9000095,FIELD,"","TITLE")
I X="" S X=$$GET1^DID(9000095,FIELD,"","LABEL")
Q X
;
PENDING(IEN) ; return 1 if chart has at least one pending deficiency
NEW IEN2,FOUND,IENS
S (IEN2,FOUND)=0 F S IEN2=$O(^AUPNCANT(IEN,1,IEN2)) Q:'IEN2 Q:FOUND D
. S IENS=IEN2_","_IEN
. Q:$$GET1^DIQ(9000095.12,IENS,.11)'="P"
. S FOUND=1
Q FOUND
DELQDT(IEN,PVN) ;EP called by computed code for DATE DELINQUENT
; IEN = internal entry in file
; PVN = internal entry for provider multiple
I ('$G(IEN))!('$G(PVN)) Q "??"
NEW VD,DAYS
S VD=$$VD^APCLV(IEN) ;VISIT date
I 'VD Q "??"
S DAYS=$$GET1^DIQ(9001001.2,DUZ(2),.38) ;Days to delinquency
I 'DAYS Q "??"
Q $$FMADD^XLFDT(VD,DAYS)
;
ICTIME(IEN,PVN) ;EP; called by computed code for Completion Time
; IEN = internal entry in file
; PVN = internal entry for provider multiple
I ('$G(IEN))!('$G(PVN)) Q "??"
NEW DONE,DSCH
S DONE=$$GET1^DIQ(9000095.12,PVN_","_IEN,.03,"I") ;date resolved
I 'DONE Q ""
S DSCH=$$GET1^DIQ(900095.12,PVN_","_IEN,.04,"I") ;date added
I 'DSCH Q "??"
Q $$FMDIFF^XLFDT(DONE,DSCH)
DISPV ;EP
NEW APCDCAFV
S APCDCAFV=APCDVSIT D ^APCDVD S APCDVSIT=APCDCAFV
DISPX ;
K DIR,DIRUT,DUOUT,Y
D REBUILD
Q
;
DMRC(V) ;EP - date marked reviewed/complete
I '$G(V) Q ""
NEW X,Y
I '$D(^AUPNVSIT(V,11)) Q "NOT YET COMPLETE"
I $P(^AUPNVSIT(V,11),U,11)'="R" Q "NOT YET COMPLETE"
S X=0,Y="" F S X=$O(^AUPNVCA("AD",V,X)) Q:X'=+X I $P($G(^AUPNVCA(X,0)),U,4)="R" S Y=X
I 'Y Q "NOT YET COMPLETE"
Q $$GET1^DIQ(9000010.45,Y,.01)
;
ICSTAT(IEN,PVN) ;EP; called by computed code for Resolution Status
; IEN = internal entry in file
; PVN = internal entry for provider multiple
I ('$G(IEN))!('$G(PVN)) Q "??"
I $$GET1^DIQ(9000095.12,PVN_","_IEN,.03)]"" Q "Resolved"
I $$GET1^DIQ(9000095.12,PVN_","_IEN,.08)]"" Q "Deleted"
Q "Pending"
EDITPRV ;EP - edit the provider but keep track of deficiency
NEW PROV,APCDDEF,COUNT,ACTION,CHOICES,Y,DIE,DR,DA,I,SCREEN,DATE,NEWPRV,APCDNN,APCDALL
D FULL^VALM1
L +^AUPNCANT(APCDVSIT):1 I '$T D MSG("Someone Else is editing this record currently",1,1),PAUSE^APCDALV1 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("",1,0)
. S PROV=+$$READ("PO^200:EMQZ",PROMPT,"","",SCREEN)
. Q:PROV<1
. ;
. ; stay in this provider until told to quit
. S QUIT=0 F D Q:QUIT
. . K APCDDEF D FINDDEF(APCDVSIT,PROV) ;build array of deficiencies for provider
. . I '$D(APCDDEF) D MSG($$SP(5)_"There are no Pending deficiencies for this Provider",2,0) S QUIT=1 Q
. . ;
. . D MSG($$SP(5)_"*** "_$$GET1^DIQ(200,PROV,.01)_" Deficiencies ***",2,0)
. . F COUNT=1:1 Q:'$D(APCDDEF(COUNT)) D MSG($P(APCDDEF(COUNT),U),1,0) ;display deficiencies
. . ;
. . D MSG("",1,0)
. . S CHOICES=$$READ("LO^1:"_(COUNT-1),"Select Which Deficiency to change Provider for")
. . D MSG("",1,0)
. . I +CHOICES<1 S QUIT=1 Q
. . S NEWPRV=+$$READ("PO^200:EMQZ","Change to which Provider","","",SCREEN)
. . I NEWPRV<1 S QUIT=1 Q
. . I PROV=NEWPRV D MSG($$SP(5)_"You cannot select the same provider",2,0) S QUIT=1 Q
. . S APCDNN=$$ADDNEW(APCDVSIT,NEWPRV)
. . I 'APCDNN D MSG($$SP(5)_"Error copying deficiency information from old provider to new",2,0) S QUIT=1 Q
. . D STUFFNEW(APCDVSIT,APCDNN,$TR(CHOICES,",",""))
. . D CLOSEOUT(APCDVSIT,PROV,$TR(CHOICES,",",""))
. . W !!,"Provider changed from ",$$VAL^XBDIQ1(200,PROV,.01)," to ",$$VAL^XBDIQ1(200,NEWPRV,.01)
. . ;
L -^AUPNCANT(APCDVSIT)
D REBUILD
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="^AUPNCANT("_N_",12,"
S DIC("P")=$P(^DD(9000095,1200,0),U,2),DLAYGO=9000095.12
S X=NPRV
S DIC("DR")=";.06////"_DT_";.07////"_DUZ
D FILE^DICN
Q +Y
;
CLOSEOUT(N,P,C) ;-- closeout the previous provider
K DR,DIE
S DIE="^AUPNCANT("_N_",12,",DR=".11///D;.08////"_DT_";.09///Provider Change;.1///Auto changed Change PROVIDER protocol action"
S DA(1)=N,DA=$P(APCDDEF(C),U,2)
D ^DIE
K DIE
Q
;
STUFFNEW(N,NN,CH) ;-- now add the new entry
K DR,DIE
N DATA,A,B,C,D,E,J
S J=$P(APCDDEF(CH),U,2)
S DATA=$G(^AUPNCANT(N,12,J,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,10)
S DIE="^AUPNCANT("_N_",12,",DA(1)=N,DA=NN
S DR=".02////"_A_";.03////"_B_";.04////"_C_";.05////"_D_";.1////"_E_";.11///P"
D ^DIE
K DIE
Q
;
APCDCAF6 ;IHS/OIT/LJF - NEW INCOMPLETE CHART EDIT OPTION ; 23 Mar 2015 12:30 PM
+1 ;;2.0;IHS PCC SUITE;**11**;MAY 14, 2009;Build 58
+2 ;
+3 ;
MSG(DATA,PRE,POST) ;EP; -- writes line to device;IHS/ITSC/LJF PATCH 1003
+1 NEW I,FORMAT
+2 SET FORMAT=""
IF $GET(PRE)>0
FOR I=1:1:PRE
SET FORMAT=FORMAT_"!"
+3 DO EN^DDIOL(DATA,"",FORMAT)
+4 IF $GET(POST)>0
FOR I=1:1:POST
DO EN^DDIOL("","","!")
+5 QUIT
CDE ;EP
+1 KILL DIR
+2 SET DIR(0)="NO^1:"_APCDRCNT
SET DIR("A")="Which Visit"
+3 DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+4 IF Y=""
WRITE !,"No VISIT selected."
DO EOP^APCDCAF
GOTO CDEX
+5 IF $DATA(DIRUT)
WRITE !,"No VISIT selected."
DO EOP^APCDCAF
GOTO CDEX
+6 SET APCDVSIT=^TMP("APCDCAF",$JOB,"IDX",Y,Y)
+7 KILL VALMBCK
+8 SET APCDCAFV=APCDVSIT
SET APCDPAT=$PIECE(^AUPNVSIT(APCDVSIT,0),U,5)
DO EN(APCDVSIT)
+9 ;
CDEX ;
+1 KILL DIR,DIRUT,DUOUT,Y,APCDVSIT,APCDCAF,APCDCAFV
+2 DO KILL^AUPNPAT
+3 DO BACK^APCDCAF
+4 QUIT
HRCN(PAT,SITE) ;EP; return chart number for patient at this site
+1 ;
+2 IF $GET(PAT)=""
QUIT ""
+3 QUIT $PIECE($GET(^AUPNPAT(PAT,41,SITE,0)),U,2)
+4 ;
EN(APCDVSIT) ;EP; -- main entry point for OUTPT CHART DEFICIENY
+1 ; called with APCDVSIT set
+2 NEW VALMCNT
DO TERM^VALM0
DO CLEAR^VALM1
+3 NEW APCDDALL
SET APCDDALL=1
+4 DO EN^VALM("APCDCAF CDE EDIT")
+5 DO CLEAR^VALM1
+6 QUIT
+7 ;
HDR ;EP; -- header code
+1 NEW X
+2 SET X=$$PAD($GET(IORVON)_$$GET1^DIQ(2,+$GET(APCDPAT),.01)_$GET(IORVOFF),35)_"#"_$$HRCN(+$GET(APCDPAT),DUZ(2))
+3 SET VALMHDR(1)=X
+4 ;
+5 SET X=$$PAD("Visit Date: "_$$GET1^DIQ(9000010,APCDVSIT,.01),40)_"Service Category: "_$$GET1^DIQ(9000010,APCDVSIT,.07)
+6 SET VALMHDR(2)=X
+7 SET X=$$PAD("Hospital Location: "_$$GET1^DIQ(9000010,APCDVSIT,.22),40)_"Clinic: "_$$GET1^DIQ(9000010,APCDVSIT,.08)
+8 SET VALMHDR(3)=X
+9 SET X="Primary Provider: "_$$PRIMPROV^APCLV(APCDVSIT,"N")
+10 SET VALMHDR(4)=X
+11 QUIT
+12 ;
INIT ;EP; -- init variables and list array
+1 DO INIT^APCDCAF7
+2 QUIT
+3 ;
SET(DATA,COUNT) ; stuff data into display lie
+1 SET COUNT=COUNT+1
+2 SET APCDCDEV(COUNT,0)=DATA
+3 QUIT
+4 ;
HELP ;EP; -- help code
+1 SET X="?"
DO DISP^XQORM1
WRITE !!
+2 QUIT
+3 ;
EXIT ;EP; -- exit code
+1 KILL APCDDALL,APCDVSIT
+2 QUIT
+3 ;
EXPND ; -- expand code
+1 QUIT
+2 ;
REBUILD ; EP; rebuild display
+1 ;
+2 DO TERM^VALM0
+3 DO HDR
DO INIT
+4 SET VALMBCK="R"
+5 QUIT
+6 ;
EDITTD ; EP; edit tracking dates - called by APCD ICE DATES
+1 DO FULL^VALM1
NEW ITEM,FIELD,DIE,DA,DR,Y
+2 IF '$DATA(^AUPNCANT(APCDVSIT,0))
DO ADDCANT^APCDCAF1
+3 SET DIE="^AUPNCANT("
SET DA=APCDVSIT
+4 LOCK +^AUPNCANT(APCDVSIT):1
IF '$TEST
DO MSG("Another person is editing this entry!",2,0)
DO PAUSE^APCDALV1
DO REBUILD
QUIT
+5 NEW APCDX
+6 SET APCDX=$ORDER(^AUPNCANT(APCDVSIT,12,"AC",0))
+7 SET DR=".03//"_$$FMTE^XLFDT(APCDX)
+8 DO ^DIE
+9 KILL DA,DR,DIE
+10 LOCK -^AUPNCANT(APCDVSIT)
+11 WRITE !,"Reviewed/Complete: ",$$DMRC(APCDVSIT)
+12 DO PAUSE^APCDALV1
+13 DO REBUILD
+14 QUIT
+15 ;
CAN ; EP; CHART AUDIT NOTE EDIT
+1 NEW DIE,DA,DR
+2 DO FULL^VALM1
+3 IF '$DATA(^AUPNCANT(APCDVSIT))
DO ADDCANT^APCDCAF1
+4 IF '$DATA(^AUPNCANT(APCDVSIT))
WRITE !!,"adding entry to chart audit notes failed."
HANG 3
GOTO CANX
+5 WRITE !
SET DA=APCDVSIT
SET DIE="^AUPNCANT("
SET DR=1100
DO ^DIE
KILL DIE,DA,DR
+6 ;
CANX ;
+1 DO PAUSE^APCDALV1
DO REBUILD
+2 QUIT
+3 ;
READ(TYPE,PROMPT,DEFAULT,HELP,SCREEN,DIRA) ;EP; calls reader, returns response
+1 NEW DIR,Y,DIRUT
+2 SET DIR(0)=TYPE
+3 IF $EXTRACT(TYPE,1)="P"
IF $PIECE(TYPE,":",2)["L"
SET DLAYGO=+$PIECE(TYPE,U,2)
+4 IF $DATA(SCREEN)
IF SCREEN]""
SET DIR("S")=SCREEN
+5 IF $GET(PROMPT)]""
SET DIR("A")=PROMPT
+6 IF $GET(DEFAULT)]""
SET DIR("B")=DEFAULT
+7 IF $DATA(HELP)
SET DIR("?")=HELP
+8 IF $DATA(DIRA(1))
SET Y=0
FOR
SET Y=$ORDER(DIRA(Y))
IF Y=""
QUIT
SET DIR("A",Y)=DIRA(Y)
+9 DO ^DIR
+10 QUIT Y
+11 ;
ADDDEF ; EP; add chart deficiences - called by APCD ICE ADD DEF protocol
+1 NEW PROV,APCDDEF,COUNT,ACTION,CHOICES,Y,DIE,DR,DA,I,SCREEN,DATE
+2 DO FULL^VALM1
+3 LOCK +^AUPNCANT(APCDVSIT):1
IF '$TEST
DO MSG("Someone Else is editing this record currently",1,1)
DO PAUSE^APCDALV1
QUIT
+4 ;,SCREEN="I $D(^XUSEC(""PROVIDER"",+Y))&($P($G(^VA(200,+Y,""PS"")),U,4)="""")"
SET PROMPT="Select PROVIDER"
SET SCREEN=""
+5 FOR
Begin DoDot:1
+6 DO MSG("",1,0)
+7 SET PROV=+$$READ("PO^200:EMQZ",PROMPT,"","",SCREEN)
+8 IF PROV<1
QUIT
+9 ;
+10 ; stay in this provider until told to quit
+11 SET QUIT=0
FOR
Begin DoDot:2
+12 ;build array of deficiencies for provider
KILL APCDDEF
DO FINDDEF(APCDVSIT,PROV)
+13 ;if none yet, go to add mode
IF '$DATA(APCDDEF)
DO ADDMORE(APCDVSIT,PROV)
SET QUIT=1
QUIT
+14 ;
+15 DO MSG($$SP(5)_"*** "_$$GET1^DIQ(200,PROV,.01)_" Deficiencies ***",2,0)
+16 ;display deficiencies
FOR COUNT=1:1
IF '$DATA(APCDDEF(COUNT))
QUIT
DO MSG($PIECE(APCDDEF(COUNT),U),1,0)
+17 ;
+18 DO MSG("",1,0)
+19 SET ACTION(1)=" 1. ADD New Deficiencies"
+20 SET ACTION(2)=" 2. EDIT Selected Deficiencies"
+21 SET ACTION(3)=" 3. RESOLVE Selected Deficiencies"
+22 SET ACTION(4)=" 4. DELETE Selected Deficiencies"
+23 SET ACTION(5)=" 5. QUIT"
+24 SET Y=$$READ("NO^1:5","Select Action",5,"","",.ACTION)
IF Y<1
QUIT
+25 IF Y=5
SET QUIT=1
QUIT
+26 IF Y=1
DO ADDMORE(APCDVSIT,PROV)
QUIT
+27 SET ACTION=Y
+28 ;
+29 SET CHOICES=$$READ("LO^1:"_(COUNT-1),"Select Which Deficiencies to "_$SELECT(ACTION=2:"EDIT",ACTION=4:"DELETE",1:"RESOLVE"))
+30 IF CHOICES<1
QUIT
+31 ;
+32 ; close multiple deficiencies
+33 IF ACTION=3
Begin DoDot:3
+34 SET DATE=$$READ("D^::EX","Enter DATE RESOLVED")
IF 'DATE
QUIT
+35 SET DIE="^AUPNCANT("_APCDVSIT_",12,"
SET DR=".03///"_DATE_";.11///R;.06////"_DT_";.07////"_DUZ
SET DA(1)=APCDVSIT
+36 FOR I=1:1
SET J=$PIECE(CHOICES,",",I)
IF J=""
QUIT
WRITE !?3,"Closing "_$EXTRACT($PIECE(APCDDEF(J),U),5,40)
SET DA=$PIECE(APCDDEF(J),U,2)
DO ^DIE
+37 ;
KILL DA,DR,DIE
End DoDot:3
QUIT
+38 ;DELETE SELECTED DEFICIENCIES
IF ACTION=4
Begin DoDot:3
+39 SET DATE=$$READ("DO^::EX","Enter DATE DELETED")
IF 'DATE
QUIT
+40 SET DIE="^AUPNCANT("_APCDVSIT_",12,"
SET DR=".08///"_DATE_";.11///D;.06////"_DT_";.07////"_DUZ_";.09"
SET DA(1)=APCDVSIT
+41 FOR I=1:1
SET J=$PIECE(CHOICES,",",I)
IF J=""
QUIT
WRITE !?3,"Deleting "_$EXTRACT($PIECE(APCDDEF(J),U),5,40)
SET DA=$PIECE(APCDDEF(J),U,2)
DO ^DIE
+42 ;
KILL DA,DR,DIE
End DoDot:3
QUIT
+43 ; else edit selected deficiencies
+44 SET DIE="^AUPNCANT("_APCDVSIT_",12,"
SET DR=".06////"_DT_";.07////"_DUZ_";.02;.1"
SET DA(1)=APCDVSIT
+45 FOR I=1:1
SET J=$PIECE(CHOICES,",",I)
IF J=""
QUIT
Begin DoDot:3
+46 DO MSG($PIECE(APCDDEF(J),U),2,0)
+47 SET DA=$PIECE(APCDDEF(J),U,2)
+48 DO ^DIE
End DoDot:3
End DoDot:2
IF QUIT
QUIT
End DoDot:1
IF PROV<1
QUIT
+49 LOCK -^AUPNCANT(APCDVSIT)
+50 DO VCAUPD
+51 DO REBUILD
+52 QUIT
+53 ;
FINDDEF(APCDVSIT,PRV) ; return APCDDEF array with current deficiencies for provider PRV -pending ONLY
+1 NEW COUNT,IEN,LINE,IENS
+2 SET (IEN,COUNT)=0
+3 FOR
SET IEN=$ORDER(^AUPNCANT(APCDVSIT,12,"B",PROV,IEN))
IF 'IEN
QUIT
Begin DoDot:1
+4 SET IENS=IEN_","_APCDVSIT
+5 IF $$GET1^DIQ(9000095.12,IENS,.11,"I")'="P"
QUIT
+6 SET COUNT=COUNT+1
+7 ;def name
SET LINE=$$PAD($JUSTIFY(COUNT,3),5)_$$GET1^DIQ(9000095.12,IENS,.02)
+8 ;status
SET LINE=$$PAD(LINE,40)_$$GET1^DIQ(9000095.12,IENS,.11)
+9 SET APCDDEF(COUNT)=LINE_U_IEN
End DoDot:1
+10 QUIT
FINDPEND(V) ;EP - are there any pending deficiencies
+1 IF '$GET(V)
QUIT ""
+2 NEW COUNT,IEN,J
+3 SET (IEN,COUNT)=0
+4 FOR
SET IEN=$ORDER(^AUPNCANT(V,12,IEN))
IF IEN'=+IEN!(COUNT)
QUIT
Begin DoDot:1
+5 SET IENS=IEN_","_V
+6 IF $$GET1^DIQ(9000095.12,IENS,.11,"I")'="P"
QUIT
+7 SET COUNT=COUNT+1
End DoDot:1
+8 QUIT COUNT
+9 ;
ADDMORE(APCDVSIT,PRV) ; add new deficiencies for provider
+1 NEW DIE,DR,DA,QUIT,DIC,DEF,DLAYGO,Y,IENS
+2 DO MSG(" Add Mode for Deficiencies. . .",2,0)
+3 IF '$DATA(^AUPNCANT(APCDVSIT,0))
DO ADDCANT^APCDCAF1
+4 SET QUIT=0
FOR
Begin DoDot:1
+5 KILL DIC
SET DIC="^AUTTCDR("
SET DIC(0)="AEMQZ"
+6 DO ^DIC
SET DEF=+Y
IF Y<1
SET QUIT=1
QUIT
+7 ;
+8 IF $$HAVEDEF(APCDVSIT,PRV,DEF)
IF '$$READ("Y","This deficiency already defined for this provider. Do you really want to add it again","NO")
QUIT
+9 ;
+10 IF '$$READ("Y","Okay to add "_Y(0,0)_" for this provider","YES")
QUIT
+11 KILL DIC,DA,DD,DO
+12 SET DIC="^AUPNCANT("_APCDVSIT_",12,"
SET DA(1)=APCDVSIT
SET X=PRV
SET DIC(0)="L"
+13 SET DIC("P")=$PIECE(^DD(9000095,1200,0),U,2)
SET DLAYGO=9000095.12
+14 SET DIC("DR")=".02///"_DEF_";.04////"_DT_";.05////"_DUZ_";.06////"_DT_";.07////"_DUZ_";.11///P"
+15 DO FILE^DICN
IF Y=-1
QUIT
+16 ;
+17 SET DIE="^AUPNCANT("_APCDVSIT_",12,"
SET DA(1)=APCDVSIT
SET DA=+Y
SET DR=".03;.1"
DO ^DIE
+18 SET IENS=DA_","_APCDVSIT
+19 IF $$GET1^DIQ(9000095.12,IENS,.03,"I")]""
SET DR=".11///R"
DO ^DIE
+20 KILL DIE,DA,DR
End DoDot:1
IF QUIT
QUIT
+21 QUIT
+22 ;
HAVEDEF(APCDVSIT,PRV,DEF) ;returns 1 if this record & this provider already have this deficincy defined
+1 NEW IEN,FOUND
+2 SET (IEN,FOUND)=0
FOR
SET IEN=$ORDER(^AUPNCANT(APCDVSIT,12,"B",PRV,IEN))
IF 'IEN
QUIT
IF FOUND
QUIT
Begin DoDot:1
+3 IF $PIECE(^AUPNCANT(APCDVSIT,12,IEN,0),U,11)'="P"
+4 IF $PIECE(^AUPNCANT(APCDVSIT,12,IEN,0),U,2)=DEF
SET FOUND=1
End DoDot:1
+5 QUIT FOUND
+6 ;
UPDATE ;EP
+1 DO FULL^VALM1
+2 SET APCDERR=$$ERRORCHK^APCDCAF(APCDVSIT)
+3 IF APCDERR]""
WRITE !!,"This visit has the following error: ",APCDERR,!,"You cannot mark a visit as Reviewed/Completed if there is an error."
DO PAUSE^APCDALV1
GOTO UPDATEX
+4 SET AUPNVSIT=APCDVSIT
DO MOD^AUPNVSIT
KILL AUPNVSIT
UPD0 ;
+1 KILL DIC,DD,D0,DO
+2 SET X=$$NOW^XLFDT
SET DIC="^AUPNVCA("
SET DIC(0)="L"
SET DIADD=1
SET DLAYGO=9000010.45
+3 SET DIC("DR")=".02////"_$PIECE(^AUPNVSIT(APCDVSIT,0),U,5)_";.03////"_APCDVSIT_";.04///R;.05////"_DUZ_";1216////"_$$NOW^XLFDT
DO FILE^DICN
+4 IF Y=-1
WRITE !!,"updating status failed"
DO PAUSE^APCDALV1
GOTO UPDATEX
+5 KILL DIC,DD,D0,DIADD,DLAYGO
+6 SET (APCDVCA,DA)=+Y
UPD1 ;
+1 ;
+2 SET DIE="^AUPNVSIT("
SET DA=APCDVSIT
SET DR=".13////"_DT_";1111///R"
DO ^DIE
KILL DIE,DA,DR
+3 DO RNU^APCDCAF4
UPDATEX ;
+1 KILL DIADD,DLAYGO
+2 DO ^XBFMK
+3 KILL APCDCAR,APCDCVA
+4 DO REBUILD
+5 QUIT
+6 ;
VCAUPD ;
+1 NEW APCDVCA
+2 KILL DIC,DD,D0,DO
+3 SET X=$$NOW^XLFDT
SET DIC="^AUPNVCA("
SET DIC(0)="L"
SET DIADD=1
SET DLAYGO=9000010.45
+4 SET DIC("DR")=".02////"_$PIECE(^AUPNVSIT(APCDVSIT,0),U,5)_";.03////"_APCDVSIT_";.05////"_DUZ_";1216////"_$$NOW^XLFDT
DO FILE^DICN
+5 IF Y=-1
WRITE !!,"updating status failed"
DO PAUSE^APCDALV1
QUIT
+6 KILL DIC,DD,D0,DIADD,DLAYGO
+7 SET (APCDVCA,DA)=+Y
VCAUPD1 ;
+1 DO ^XBFMK
+2 SET S=0
+3 IF $$ERRORCHK^APCDCAF(APCDVSIT)]""
SET S=1
+4 IF $$FINDPEND(APCDVSIT)
SET S=1
+5 IF S
SET APCDCAR="I"
SET DA=APCDVCA
SET DIE="^AUPNVCA("
SET DR=".04///I"
DO ^DIE
KILL DA,DIE,DR
GOTO VCAUPD2
+6 IF 'S
SET DA=APCDVCA
SET DIE="^AUPNVCA("
SET DR=".04"
DO ^DIE
KILL DA,DIE,DR
+7 DO ^XBFMK
+8 SET APCDCAR=$PIECE(^AUPNVCA(APCDVCA,0),U,4)
+9 IF APCDCAR=""
WRITE !!,"You must enter a status"
GOTO VCAUPD1
+10 SET APCDERR=$$ERRORCHK^APCDCAF(APCDVSIT)
+11 IF APCDERR]""
IF APCDCAR="R"
WRITE !!,"This visit has the following error: ",APCDERR,!,"You cannot mark a visit as Reviewed/Completed if there is an error."
SET DA=APCDVCA
SET DIE="^AUPNVCA("
SET DR=".04///I"
DO ^DIE
GOTO VCAUPD1
VCAUPD2 ;
+1 SET DIE="^AUPNVSIT("
SET DA=APCDVSIT
SET DR=".13////"_DT_";1111////"_APCDCAR
DO ^DIE
KILL DIE,DA,DR
+2 QUIT
+3 ;
+4 ;
PAD(D,L) ;EP pad length of data
+1 ; -- D=data L=length
+2 QUIT $EXTRACT(D_$$REPEAT^XLFSTR(" ",L),1,L)
+3 ;
SP(N) ; pad N number of spaces
+1 QUIT $$PAD(" ",N)
+2 ;
DSOKAY() ; EP; does site use day surgery?
+1 QUIT $$GET1^DIQ(9009020.1,$$DIV^BSDU,201,"I")
+2 ;
LABEL(FIELD) ; returns field's title or label
+1 NEW X
+2 SET X=$$GET1^DID(9000095,FIELD,"","TITLE")
+3 IF X=""
SET X=$$GET1^DID(9000095,FIELD,"","LABEL")
+4 QUIT X
+5 ;
PENDING(IEN) ; return 1 if chart has at least one pending deficiency
+1 NEW IEN2,FOUND,IENS
+2 SET (IEN2,FOUND)=0
FOR
SET IEN2=$ORDER(^AUPNCANT(IEN,1,IEN2))
IF 'IEN2
QUIT
IF FOUND
QUIT
Begin DoDot:1
+3 SET IENS=IEN2_","_IEN
+4 IF $$GET1^DIQ(9000095.12,IENS,.11)'="P"
QUIT
+5 SET FOUND=1
End DoDot:1
+6 QUIT FOUND
DELQDT(IEN,PVN) ;EP called by computed code for DATE DELINQUENT
+1 ; IEN = internal entry in file
+2 ; PVN = internal entry for provider multiple
+3 IF ('$GET(IEN))!('$GET(PVN))
QUIT "??"
+4 NEW VD,DAYS
+5 ;VISIT date
SET VD=$$VD^APCLV(IEN)
+6 IF 'VD
QUIT "??"
+7 ;Days to delinquency
SET DAYS=$$GET1^DIQ(9001001.2,DUZ(2),.38)
+8 IF 'DAYS
QUIT "??"
+9 QUIT $$FMADD^XLFDT(VD,DAYS)
+10 ;
ICTIME(IEN,PVN) ;EP; called by computed code for Completion Time
+1 ; IEN = internal entry in file
+2 ; PVN = internal entry for provider multiple
+3 IF ('$GET(IEN))!('$GET(PVN))
QUIT "??"
+4 NEW DONE,DSCH
+5 ;date resolved
SET DONE=$$GET1^DIQ(9000095.12,PVN_","_IEN,.03,"I")
+6 IF 'DONE
QUIT ""
+7 ;date added
SET DSCH=$$GET1^DIQ(900095.12,PVN_","_IEN,.04,"I")
+8 IF 'DSCH
QUIT "??"
+9 QUIT $$FMDIFF^XLFDT(DONE,DSCH)
DISPV ;EP
+1 NEW APCDCAFV
+2 SET APCDCAFV=APCDVSIT
DO ^APCDVD
SET APCDVSIT=APCDCAFV
DISPX ;
+1 KILL DIR,DIRUT,DUOUT,Y
+2 DO REBUILD
+3 QUIT
+4 ;
DMRC(V) ;EP - date marked reviewed/complete
+1 IF '$GET(V)
QUIT ""
+2 NEW X,Y
+3 IF '$DATA(^AUPNVSIT(V,11))
QUIT "NOT YET COMPLETE"
+4 IF $PIECE(^AUPNVSIT(V,11),U,11)'="R"
QUIT "NOT YET COMPLETE"
+5 SET X=0
SET Y=""
FOR
SET X=$ORDER(^AUPNVCA("AD",V,X))
IF X'=+X
QUIT
IF $PIECE($GET(^AUPNVCA(X,0)),U,4)="R"
SET Y=X
+6 IF 'Y
QUIT "NOT YET COMPLETE"
+7 QUIT $$GET1^DIQ(9000010.45,Y,.01)
+8 ;
ICSTAT(IEN,PVN) ;EP; called by computed code for Resolution Status
+1 ; IEN = internal entry in file
+2 ; PVN = internal entry for provider multiple
+3 IF ('$GET(IEN))!('$GET(PVN))
QUIT "??"
+4 IF $$GET1^DIQ(9000095.12,PVN_","_IEN,.03)]""
QUIT "Resolved"
+5 IF $$GET1^DIQ(9000095.12,PVN_","_IEN,.08)]""
QUIT "Deleted"
+6 QUIT "Pending"
EDITPRV ;EP - edit the provider but keep track of deficiency
+1 NEW PROV,APCDDEF,COUNT,ACTION,CHOICES,Y,DIE,DR,DA,I,SCREEN,DATE,NEWPRV,APCDNN,APCDALL
+2 DO FULL^VALM1
+3 LOCK +^AUPNCANT(APCDVSIT):1
IF '$TEST
DO MSG("Someone Else is editing this record currently",1,1)
DO PAUSE^APCDALV1
QUIT
+4 ;"I $D(^XUSEC(""PROVIDER"",+Y))&($P($G(^VA(200,+Y,""PS"")),U,4)="""")"
SET PROMPT="Select PROVIDER"
SET SCREEN=""
+5 FOR
Begin DoDot:1
+6 DO MSG("",1,0)
+7 SET PROV=+$$READ("PO^200:EMQZ",PROMPT,"","",SCREEN)
+8 IF PROV<1
QUIT
+9 ;
+10 ; stay in this provider until told to quit
+11 SET QUIT=0
FOR
Begin DoDot:2
+12 ;build array of deficiencies for provider
KILL APCDDEF
DO FINDDEF(APCDVSIT,PROV)
+13 IF '$DATA(APCDDEF)
DO MSG($$SP(5)_"There are no Pending deficiencies for this Provider",2,0)
SET QUIT=1
QUIT
+14 ;
+15 DO MSG($$SP(5)_"*** "_$$GET1^DIQ(200,PROV,.01)_" Deficiencies ***",2,0)
+16 ;display deficiencies
FOR COUNT=1:1
IF '$DATA(APCDDEF(COUNT))
QUIT
DO MSG($PIECE(APCDDEF(COUNT),U),1,0)
+17 ;
+18 DO MSG("",1,0)
+19 SET CHOICES=$$READ("LO^1:"_(COUNT-1),"Select Which Deficiency to change Provider for")
+20 DO MSG("",1,0)
+21 IF +CHOICES<1
SET QUIT=1
QUIT
+22 SET NEWPRV=+$$READ("PO^200:EMQZ","Change to which Provider","","",SCREEN)
+23 IF NEWPRV<1
SET QUIT=1
QUIT
+24 IF PROV=NEWPRV
DO MSG($$SP(5)_"You cannot select the same provider",2,0)
SET QUIT=1
QUIT
+25 SET APCDNN=$$ADDNEW(APCDVSIT,NEWPRV)
+26 IF 'APCDNN
DO MSG($$SP(5)_"Error copying deficiency information from old provider to new",2,0)
SET QUIT=1
QUIT
+27 DO STUFFNEW(APCDVSIT,APCDNN,$TRANSLATE(CHOICES,",",""))
+28 DO CLOSEOUT(APCDVSIT,PROV,$TRANSLATE(CHOICES,",",""))
+29 WRITE !!,"Provider changed from ",$$VAL^XBDIQ1(200,PROV,.01)," to ",$$VAL^XBDIQ1(200,NEWPRV,.01)
+30 ;
End DoDot:2
IF QUIT
QUIT
End DoDot:1
IF PROV<1
QUIT
+31 LOCK -^AUPNCANT(APCDVSIT)
+32 DO REBUILD
+33 QUIT
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="^AUPNCANT("_N_",12,"
+4 SET DIC("P")=$PIECE(^DD(9000095,1200,0),U,2)
SET DLAYGO=9000095.12
+5 SET X=NPRV
+6 SET DIC("DR")=";.06////"_DT_";.07////"_DUZ
+7 DO FILE^DICN
+8 QUIT +Y
+9 ;
CLOSEOUT(N,P,C) ;-- closeout the previous provider
+1 KILL DR,DIE
+2 SET DIE="^AUPNCANT("_N_",12,"
SET DR=".11///D;.08////"_DT_";.09///Provider Change;.1///Auto changed Change PROVIDER protocol action"
+3 SET DA(1)=N
SET DA=$PIECE(APCDDEF(C),U,2)
+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,J
+3 SET J=$PIECE(APCDDEF(CH),U,2)
+4 SET DATA=$GET(^AUPNCANT(N,12,J,0))
+5 SET A=$PIECE(DATA,U,2)
+6 SET B=$PIECE(DATA,U,3)
+7 SET C=$PIECE(DATA,U,4)
+8 SET D=$PIECE(DATA,U,5)
+9 SET E=$PIECE(DATA,U,10)
+10 SET DIE="^AUPNCANT("_N_",12,"
SET DA(1)=N
SET DA=NN
+11 SET DR=".02////"_A_";.03////"_B_";.04////"_C_";.05////"_D_";.1////"_E_";.11///P"
+12 DO ^DIE
+13 KILL DIE
+14 QUIT
+15 ;
