MPIFCMRP ;BPCIO/CMC-PUSHING CMOR TO ANOTHER SITE ;NOV 15, 2000
;;1.0; MASTER PATIENT INDEX VISTA ;**11,21,30,32**;30 Apr 99
;
; Integration Agreements Utilized:
;
; ^DGCN(391.91 IA #2751
;
;Entry point for option: PUSH CMOR REQUEST - create a new request
; to change CMOR when your site is the CMOR.
; No input or output variables.
;
;Only if the site is the CMOR can this option be used
; note: code here is very similar to MPIFEDIT
NEW ;
N DIC,X,Y,DTOUT,DUOUT,PAT
S DIC="^DPT(",DIC(0)="QEAMZ",DIC("A")="Select PATIENT: "
D ^DIC
Q:$D(DTOUT)!$D(DUOUT)!(Y=-1)
S PAT=+Y
D LM(PAT)
Q
LM(PAT) ; list manager entry point to push a change of CMOR with PAT set to the DFN
I +$$GETICN^MPIF001(PAT)<0 W !,"Patient doesn't have ICN, try again" G NEW
I $E($$GETICN^MPIF001(PAT),1,3)=$P($$SITE^VASITE(),"^",3) W !,"Patient has a Local ICN, try again" G NEW
I $$GETVCCI^MPIF001(PAT)<0 W !,"Patient doesn't have a CMOR, try again" G NEW
I $$GETVCCI^MPIF001(PAT)'=$P($$SITE^VASITE(),"^",3) W !,"You are NOT the CMOR, to request to be the CMOR, use option: Create a New CMOR Change Request" G NEW
N TMP,TCNT
S TMP=$O(^DGCN(391.91,"APAT",PAT,"")) I $O(^DGCN(391.91,"APAT",PAT,TMP))="" W !,"Patient isn't SHARED - CAN'T change CMOR" Q
;Pt is shared, but are they shared with another VAMC?
S TMP="",TCNT=0 F S TMP=$O(^DGCN(391.91,"APAT",PAT,TMP)) Q:TMP="" D
.;I $$GET1^DIQ(4,TMP_",",13)'="VAMC" Q
.N TP S TP=$$GET1^DIQ(4,TMP_",",13)
.Q:TP'="VAMC"&(TP'="OC")&(TP'="M&ROC")&(TP'="RO-OC")
.; ^ only valid types of TFs that can be a CMOR
.S TCNT=TCNT+1
I TCNT<2 W !,"Patient isn't SHARED with another VAMC - CAN'T change CMOR" Q
; CHECK IF ALREADY OPEN/PENDING REQUEST
N ENT,STOP,MPIFNM,REQNM
S ENT=0,STOP=0 F S ENT=$O(^MPIF(984.9,"C",PAT,ENT)) Q:ENT=""!(STOP) D
.I $P($G(^MPIF(984.9,ENT,0)),"^",6)<4 S STOP=1
I STOP W !!,"Already have request for this patient" G NEW
N N0,PHONE,DA,DIE,DR,DIR,ERROR,DIK,Y,DIRUT,REQ,TDA,PERS
S DA=$$ADD^MPIFNEW(),TDA=DA,PHONE=""
S DIE="^MPIF(984.9,",DR=".04///`"_PAT D ^DIE
S REQ=$P($G(^MPIF(984.9,DA,0)),"^")
W !,"REQUEST NUMBER:",REQ
EDIT I $D(DUZ) D
.S PHONE=$P($G(^MPIF(984.9,+$O(^MPIF(984.9,"AD",DUZ,""),-1),0)),"^",5)
.N DA,DIC,DIQ S DIQ="MPIFNM",DR=".01;.132",DIQ(0)="E",DIC="^VA(200,",DA=DUZ
.D EN^DIQ1
.S REQNM=MPIFNM(200,DUZ,.01,"E")
I '$D(DUZ) S (PHONE,REQNM)=""
;
REASON S DIR("A")="Reason for Request",DIR("?")="Answer must be 3-60 characters in length.",DIR(0)="F^3:60" D ^DIR
I Y="" W !,"Answer must be 3-60 characters in length." G REASON
I X="^" S DIK="^MPIF(984.9," D ^DIK W "... Request deleted" Q
S DIE="^MPIF(984.9,",DR="1.02///"_X D ^DIE
REQNM S DIR("A")="Requestor's Name",DIR("B")=REQNM,DIR("?")="Answer must be a valid user",DIR(0)="P^200:EQZ" D ^DIR K DIR("B")
I Y="" W !,"Must pick valid user" G REQNM
I X="^" S DIK="^MPIF(984.9," D ^DIK W "... Request deleted" Q
S PERS=+Y
S DIE="^MPIF(984.9,",DR=".02///`"_+Y D ^DIE
PHONE S DIR("A")="Requestor's Phone",DIR("B")=PHONE,DIR("?")="Answer must be 4-20 charaters in length.",DIR(0)="F" D ^DIR K DIR("B")
I Y="" W !,"Answer must be 4-20 charaters in length." G PHONE
I X="^" S DIK="^MPIF(984.9," D ^DIK W "... Request deleted" Q
S DIE="^MPIF(984.9,",DR=".05///"_X D ^DIE
;
CMOR S DIC("A")="Select Site to Be CMOR: ",DIC="^DIC(4,",DIC(0)="QEAM"
S DIC("S")="I $D(^DGCN(391.91,""APAT"",PAT,Y)) I +$$SITE^VASITE'=+Y N TYPE S TYPE=$$GET1^DIQ(4,+Y_"","",13) I TYPE=""VAMC""!(TYPE=""RO-OC"")!(TYPE=""OC"")!(TYPE=""M&ROC"")"
D ^DIC
I X="^" S DIK="^MPIF(984.9," D ^DIK W "... Request deleted" Q
N TSITE S TSITE=+Y
S DIE="^MPIF(984.9,",DR=".07///`"_TSITE_";1.03///3;.09///`"_TSITE D ^DIE
;update site, type of action and cmor after approval
;
I $$CHK^MPIFEDIT(DA) W !,"This request is missing required data." G EDIT
;
APP S DIR("A")="Select Request Action (SEND/EDIT/DELETE)? ",DIR("B")="SEND",DIR(0)="SAO^SEND:SEND;EDIT:EDIT;DELETE:DELETE"
D ^DIR K DIR
S DA=TDA
I $E(Y)="D"!$D(DIRUT) D Q
.S DIK="^MPIF(984.9," D ^DIK W "... Request deleted"
.Q
I $E(Y)="E" G REASON
S DR=".08////^S X=2;.06////^S X=2",DIE="^MPIF(984.9," D ^DIE W !,"... Request will be sent"
; removed event queue due to delivery issues - this msg must be sent first followed by the actual change cmor msg.
N ERR,MPIFHL7 S ERR="ERRS",MPIFHL7=""
D EN^MPIFREQ("CMOR CHANGE REQUEST",DA,.ERR,MPIFHL7)
;
;NOW CHANGE CMOR AND SEND CHANGE CMOR MESSAGE
N TEXT,DIR,DR,CMOR,TMP,ERROR
S TEXT="Auto change - pushed CMOR",ERROR=0
S DIE="^MPIF(984.9,",DA=TDA,DR=".06///^S X=4;3.01///^S X=TEXT"
D ^DIE
S CMOR=$P($G(^MPIF(984.9,TDA,0)),"^",7)
I CMOR="" D Q
.W !,"New CMOR Not Defined, edit request"
.S ^DIE="^MPIF(984.9,",DA=TDA,DR=".06///^S X=1" D ^DIE
S TMP=$$CHANGE^MPIF001(PAT,CMOR)
I +TMP<0 S ^DIE="^MPIF(984.9,",DA=TDA,DR=".06///^S X=1" D ^DIE Q
D BROAD^MPIFCMOR(DA,.ERROR)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMPIFCMRP 4908 printed Dec 13, 2024@02:11:01 Page 2
MPIFCMRP ;BPCIO/CMC-PUSHING CMOR TO ANOTHER SITE ;NOV 15, 2000
+1 ;;1.0; MASTER PATIENT INDEX VISTA ;**11,21,30,32**;30 Apr 99
+2 ;
+3 ; Integration Agreements Utilized:
+4 ;
+5 ; ^DGCN(391.91 IA #2751
+6 ;
+7 ;Entry point for option: PUSH CMOR REQUEST - create a new request
+8 ; to change CMOR when your site is the CMOR.
+9 ; No input or output variables.
+10 ;
+11 ;Only if the site is the CMOR can this option be used
+12 ; note: code here is very similar to MPIFEDIT
NEW ;
+1 NEW DIC,X,Y,DTOUT,DUOUT,PAT
+2 SET DIC="^DPT("
SET DIC(0)="QEAMZ"
SET DIC("A")="Select PATIENT: "
+3 DO ^DIC
+4 if $DATA(DTOUT)!$DATA(DUOUT)!(Y=-1)
QUIT
+5 SET PAT=+Y
+6 DO LM(PAT)
+7 QUIT
LM(PAT) ; list manager entry point to push a change of CMOR with PAT set to the DFN
+1 IF +$$GETICN^MPIF001(PAT)<0
WRITE !,"Patient doesn't have ICN, try again"
GOTO NEW
+2 IF $EXTRACT($$GETICN^MPIF001(PAT),1,3)=$PIECE($$SITE^VASITE(),"^",3)
WRITE !,"Patient has a Local ICN, try again"
GOTO NEW
+3 IF $$GETVCCI^MPIF001(PAT)<0
WRITE !,"Patient doesn't have a CMOR, try again"
GOTO NEW
+4 IF $$GETVCCI^MPIF001(PAT)'=$PIECE($$SITE^VASITE(),"^",3)
WRITE !,"You are NOT the CMOR, to request to be the CMOR, use option: Create a New CMOR Change Request"
GOTO NEW
+5 NEW TMP,TCNT
+6 SET TMP=$ORDER(^DGCN(391.91,"APAT",PAT,""))
IF $ORDER(^DGCN(391.91,"APAT",PAT,TMP))=""
WRITE !,"Patient isn't SHARED - CAN'T change CMOR"
QUIT
+7 ;Pt is shared, but are they shared with another VAMC?
+8 SET TMP=""
SET TCNT=0
FOR
SET TMP=$ORDER(^DGCN(391.91,"APAT",PAT,TMP))
if TMP=""
QUIT
Begin DoDot:1
+9 ;I $$GET1^DIQ(4,TMP_",",13)'="VAMC" Q
+10 NEW TP
SET TP=$$GET1^DIQ(4,TMP_",",13)
+11 if TP'="VAMC"&(TP'="OC")&(TP'="M&ROC")&(TP'="RO-OC")
QUIT
+12 ; ^ only valid types of TFs that can be a CMOR
+13 SET TCNT=TCNT+1
End DoDot:1
+14 IF TCNT<2
WRITE !,"Patient isn't SHARED with another VAMC - CAN'T change CMOR"
QUIT
+15 ; CHECK IF ALREADY OPEN/PENDING REQUEST
+16 NEW ENT,STOP,MPIFNM,REQNM
+17 SET ENT=0
SET STOP=0
FOR
SET ENT=$ORDER(^MPIF(984.9,"C",PAT,ENT))
if ENT=""!(STOP)
QUIT
Begin DoDot:1
+18 IF $PIECE($GET(^MPIF(984.9,ENT,0)),"^",6)<4
SET STOP=1
End DoDot:1
+19 IF STOP
WRITE !!,"Already have request for this patient"
GOTO NEW
+20 NEW N0,PHONE,DA,DIE,DR,DIR,ERROR,DIK,Y,DIRUT,REQ,TDA,PERS
+21 SET DA=$$ADD^MPIFNEW()
SET TDA=DA
SET PHONE=""
+22 SET DIE="^MPIF(984.9,"
SET DR=".04///`"_PAT
DO ^DIE
+23 SET REQ=$PIECE($GET(^MPIF(984.9,DA,0)),"^")
+24 WRITE !,"REQUEST NUMBER:",REQ
EDIT IF $DATA(DUZ)
Begin DoDot:1
+1 SET PHONE=$PIECE($GET(^MPIF(984.9,+$ORDER(^MPIF(984.9,"AD",DUZ,""),-1),0)),"^",5)
+2 NEW DA,DIC,DIQ
SET DIQ="MPIFNM"
SET DR=".01;.132"
SET DIQ(0)="E"
SET DIC="^VA(200,"
SET DA=DUZ
+3 DO EN^DIQ1
+4 SET REQNM=MPIFNM(200,DUZ,.01,"E")
End DoDot:1
+5 IF '$DATA(DUZ)
SET (PHONE,REQNM)=""
+6 ;
REASON SET DIR("A")="Reason for Request"
SET DIR("?")="Answer must be 3-60 characters in length."
SET DIR(0)="F^3:60"
DO ^DIR
+1 IF Y=""
WRITE !,"Answer must be 3-60 characters in length."
GOTO REASON
+2 IF X="^"
SET DIK="^MPIF(984.9,"
DO ^DIK
WRITE "... Request deleted"
QUIT
+3 SET DIE="^MPIF(984.9,"
SET DR="1.02///"_X
DO ^DIE
REQNM SET DIR("A")="Requestor's Name"
SET DIR("B")=REQNM
SET DIR("?")="Answer must be a valid user"
SET DIR(0)="P^200:EQZ"
DO ^DIR
KILL DIR("B")
+1 IF Y=""
WRITE !,"Must pick valid user"
GOTO REQNM
+2 IF X="^"
SET DIK="^MPIF(984.9,"
DO ^DIK
WRITE "... Request deleted"
QUIT
+3 SET PERS=+Y
+4 SET DIE="^MPIF(984.9,"
SET DR=".02///`"_+Y
DO ^DIE
PHONE SET DIR("A")="Requestor's Phone"
SET DIR("B")=PHONE
SET DIR("?")="Answer must be 4-20 charaters in length."
SET DIR(0)="F"
DO ^DIR
KILL DIR("B")
+1 IF Y=""
WRITE !,"Answer must be 4-20 charaters in length."
GOTO PHONE
+2 IF X="^"
SET DIK="^MPIF(984.9,"
DO ^DIK
WRITE "... Request deleted"
QUIT
+3 SET DIE="^MPIF(984.9,"
SET DR=".05///"_X
DO ^DIE
+4 ;
CMOR SET DIC("A")="Select Site to Be CMOR: "
SET DIC="^DIC(4,"
SET DIC(0)="QEAM"
+1 SET DIC("S")="I $D(^DGCN(391.91,""APAT"",PAT,Y)) I +$$SITE^VASITE'=+Y N TYPE S TYPE=$$GET1^DIQ(4,+Y_"","",13) I TYPE=""VAMC""!(TYPE=""RO-OC"")!(TYPE=""OC"")!(TYPE=""M&ROC"")"
+2 DO ^DIC
+3 IF X="^"
SET DIK="^MPIF(984.9,"
DO ^DIK
WRITE "... Request deleted"
QUIT
+4 NEW TSITE
SET TSITE=+Y
+5 SET DIE="^MPIF(984.9,"
SET DR=".07///`"_TSITE_";1.03///3;.09///`"_TSITE
DO ^DIE
+6 ;update site, type of action and cmor after approval
+7 ;
+8 IF $$CHK^MPIFEDIT(DA)
WRITE !,"This request is missing required data."
GOTO EDIT
+9 ;
APP SET DIR("A")="Select Request Action (SEND/EDIT/DELETE)? "
SET DIR("B")="SEND"
SET DIR(0)="SAO^SEND:SEND;EDIT:EDIT;DELETE:DELETE"
+1 DO ^DIR
KILL DIR
+2 SET DA=TDA
+3 IF $EXTRACT(Y)="D"!$DATA(DIRUT)
Begin DoDot:1
+4 SET DIK="^MPIF(984.9,"
DO ^DIK
WRITE "... Request deleted"
+5 QUIT
End DoDot:1
QUIT
+6 IF $EXTRACT(Y)="E"
GOTO REASON
+7 SET DR=".08////^S X=2;.06////^S X=2"
SET DIE="^MPIF(984.9,"
DO ^DIE
WRITE !,"... Request will be sent"
+8 ; removed event queue due to delivery issues - this msg must be sent first followed by the actual change cmor msg.
+9 NEW ERR,MPIFHL7
SET ERR="ERRS"
SET MPIFHL7=""
+10 DO EN^MPIFREQ("CMOR CHANGE REQUEST",DA,.ERR,MPIFHL7)
+11 ;
+12 ;NOW CHANGE CMOR AND SEND CHANGE CMOR MESSAGE
+13 NEW TEXT,DIR,DR,CMOR,TMP,ERROR
+14 SET TEXT="Auto change - pushed CMOR"
SET ERROR=0
+15 SET DIE="^MPIF(984.9,"
SET DA=TDA
SET DR=".06///^S X=4;3.01///^S X=TEXT"
+16 DO ^DIE
+17 SET CMOR=$PIECE($GET(^MPIF(984.9,TDA,0)),"^",7)
+18 IF CMOR=""
Begin DoDot:1
+19 WRITE !,"New CMOR Not Defined, edit request"
+20 SET ^DIE="^MPIF(984.9,"
SET DA=TDA
SET DR=".06///^S X=1"
DO ^DIE
End DoDot:1
QUIT
+21 SET TMP=$$CHANGE^MPIF001(PAT,CMOR)
+22 IF +TMP<0
SET ^DIE="^MPIF(984.9,"
SET DA=TDA
SET DR=".06///^S X=1"
DO ^DIE
QUIT
+23 DO BROAD^MPIFCMOR(DA,.ERROR)
+24 QUIT
