Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: MPIFCMRP

MPIFCMRP.m

Go to the documentation of this file. 
  1. 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
  1.  ;
  1.  ; Integration Agreements Utilized:
  1.  ;
  1.  ; ^DGCN(391.91   IA #2751
  1.  ;
  1.  ;Entry point for option: PUSH CMOR REQUEST - create a new request
  1.  ; to change CMOR when your site is the CMOR.
  1.  ; No input or output variables.
  1.  ;
  1.  ;Only if the site is the CMOR can this option be used
  1.  ; note: code here is very similar to MPIFEDIT
  1. NEW ;
  1.  N DIC,X,Y,DTOUT,DUOUT,PAT
  1.  S DIC="^DPT(",DIC(0)="QEAMZ",DIC("A")="Select PATIENT: "
  1.  D ^DIC
  1.  Q:$D(DTOUT)!$D(DUOUT)!(Y=-1)
  1.  S PAT=+Y
  1.  D LM(PAT)
  1.  Q
  1. LM(PAT) ; list manager entry point to push a change of CMOR with PAT set to the DFN
  1.  I +$$GETICN^MPIF001(PAT)<0 W !,"Patient doesn't have ICN, try again" G NEW
  1.  I $E($$GETICN^MPIF001(PAT),1,3)=$P($$SITE^VASITE(),"^",3) W !,"Patient has a Local ICN, try again" G NEW
  1.  I $$GETVCCI^MPIF001(PAT)<0 W !,"Patient doesn't have a CMOR, try again" G NEW
  1.  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
  1.  N TMP,TCNT
  1.  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
  1.  ;Pt is shared, but are they shared with another VAMC?
  1.  S TMP="",TCNT=0 F  S TMP=$O(^DGCN(391.91,"APAT",PAT,TMP)) Q:TMP=""  D
  1.  .;I $$GET1^DIQ(4,TMP_",",13)'="VAMC" Q
  1.  .N TP S TP=$$GET1^DIQ(4,TMP_",",13)
  1.  .Q:TP'="VAMC"&(TP'="OC")&(TP'="M&ROC")&(TP'="RO-OC")
  1.  .; ^ only valid types of TFs that can be a CMOR 
  1.  .S TCNT=TCNT+1
  1.  I TCNT<2 W !,"Patient isn't SHARED with another VAMC - CAN'T change CMOR" Q
  1.  ; CHECK IF ALREADY OPEN/PENDING REQUEST
  1.  N ENT,STOP,MPIFNM,REQNM
  1.  S ENT=0,STOP=0 F  S ENT=$O(^MPIF(984.9,"C",PAT,ENT)) Q:ENT=""!(STOP)  D
  1.  .I $P($G(^MPIF(984.9,ENT,0)),"^",6)<4 S STOP=1
  1.  I STOP W !!,"Already have request for this patient" G NEW
  1.  N N0,PHONE,DA,DIE,DR,DIR,ERROR,DIK,Y,DIRUT,REQ,TDA,PERS
  1.  S DA=$$ADD^MPIFNEW(),TDA=DA,PHONE=""
  1.  S DIE="^MPIF(984.9,",DR=".04///`"_PAT D ^DIE
  1.  S REQ=$P($G(^MPIF(984.9,DA,0)),"^")
  1.  W !,"REQUEST NUMBER:",REQ
  1. EDIT I $D(DUZ) D
  1.  .S PHONE=$P($G(^MPIF(984.9,+$O(^MPIF(984.9,"AD",DUZ,""),-1),0)),"^",5)
  1.  .N DA,DIC,DIQ S DIQ="MPIFNM",DR=".01;.132",DIQ(0)="E",DIC="^VA(200,",DA=DUZ
  1.  .D EN^DIQ1
  1.  .S REQNM=MPIFNM(200,DUZ,.01,"E")
  1.  I '$D(DUZ) S (PHONE,REQNM)=""
  1.  ;
  1. REASON S DIR("A")="Reason for Request",DIR("?")="Answer must be 3-60 characters in length.",DIR(0)="F^3:60" D ^DIR
  1.  I Y="" W !,"Answer must be 3-60 characters in length." G REASON
  1.  I X="^" S DIK="^MPIF(984.9," D ^DIK W "... Request deleted" Q
  1.  S DIE="^MPIF(984.9,",DR="1.02///"_X D ^DIE
  1. 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")
  1.  I Y="" W !,"Must pick valid user" G REQNM
  1.  I X="^" S DIK="^MPIF(984.9," D ^DIK W "... Request deleted" Q
  1.  S PERS=+Y
  1.  S DIE="^MPIF(984.9,",DR=".02///`"_+Y D ^DIE
  1. 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")
  1.  I Y="" W !,"Answer must be 4-20 charaters in length."  G PHONE
  1.  I X="^" S DIK="^MPIF(984.9," D ^DIK W "... Request deleted" Q
  1.  S DIE="^MPIF(984.9,",DR=".05///"_X D ^DIE
  1.  ;
  1. CMOR S DIC("A")="Select Site to Be CMOR: ",DIC="^DIC(4,",DIC(0)="QEAM"
  1.  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"")"
  1.  D ^DIC
  1.  I X="^" S DIK="^MPIF(984.9," D ^DIK W "... Request deleted" Q
  1.  N TSITE S TSITE=+Y
  1.  S DIE="^MPIF(984.9,",DR=".07///`"_TSITE_";1.03///3;.09///`"_TSITE D ^DIE
  1.  ;update site, type of action and cmor after approval
  1.  ;
  1.  I $$CHK^MPIFEDIT(DA) W !,"This request is missing required data." G EDIT
  1.  ;
  1. APP S DIR("A")="Select Request Action (SEND/EDIT/DELETE)? ",DIR("B")="SEND",DIR(0)="SAO^SEND:SEND;EDIT:EDIT;DELETE:DELETE"
  1.  D ^DIR K DIR
  1.  S DA=TDA
  1.  I $E(Y)="D"!$D(DIRUT) D  Q
  1.  .S DIK="^MPIF(984.9," D ^DIK W "... Request deleted"
  1.  .Q
  1.  I $E(Y)="E" G REASON
  1.  S DR=".08////^S X=2;.06////^S X=2",DIE="^MPIF(984.9," D ^DIE W !,"... Request will be sent"
  1.  ; removed event queue due to delivery issues - this msg must be sent first followed by the actual change cmor msg.
  1.  N ERR,MPIFHL7 S ERR="ERRS",MPIFHL7=""
  1.  D EN^MPIFREQ("CMOR CHANGE REQUEST",DA,.ERR,MPIFHL7)
  1.  ;
  1.  ;NOW CHANGE CMOR AND SEND CHANGE CMOR MESSAGE
  1.  N TEXT,DIR,DR,CMOR,TMP,ERROR
  1.  S TEXT="Auto change - pushed CMOR",ERROR=0
  1.  S DIE="^MPIF(984.9,",DA=TDA,DR=".06///^S X=4;3.01///^S X=TEXT"
  1.  D ^DIE
  1.  S CMOR=$P($G(^MPIF(984.9,TDA,0)),"^",7)
  1.  I CMOR="" D  Q
  1.  .W !,"New CMOR Not Defined, edit request"
  1.  .S ^DIE="^MPIF(984.9,",DA=TDA,DR=".06///^S X=1" D ^DIE
  1.  S TMP=$$CHANGE^MPIF001(PAT,CMOR)
  1.  I +TMP<0 S ^DIE="^MPIF(984.9,",DA=TDA,DR=".06///^S X=1" D ^DIE Q
  1.  D BROAD^MPIFCMOR(DA,.ERROR)
  1.  Q