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

PSOEPUT2.m

Go to the documentation of this file.
  1. PSOEPUT2 ;BIR/TJL - ePCS Broker Utilities ;11/1/23 12:05
  1. ;;7.0;OUTPATIENT PHARMACY;**545,743,732**;DEC 1997;Build 10
  1. ;
  1. EPCSHELP(RESULTS,EPCSARY) ;
  1. ;
  1. ;Broker call returns the entries from HELP FILE #9.2
  1. ; RPC: PSO EPCS GET HELP
  1. ;INPUTS EPCSARY - Contains the following elements
  1. ; HELPDA - Help Frame Name
  1. ;
  1. ;OUTPUTS RESULTS - Array of help text in the HELP FRAME File (#9.2)
  1. ;
  1. N HELPDA,DIC,X,Y
  1. S HELPDA=$G(EPCSARY) I HELPDA="" Q
  1. D SETENV K ^TMP("EPCSHELP",$J)
  1. S DIC="^DIC(9.2,",DIC(0)="MN",X=HELPDA
  1. D ^DIC M ^TMP("EPCSHELP",$J)=^DIC(9.2,+Y,1)
  1. I $D(^TMP("EPCSHELP",$J)) D
  1. . S $P(^TMP("EPCSHELP",$J,0),U)=$P(^DIC(9.2,+Y,0),U,2)
  1. S RESULTS=$NA(^TMP("EPCSHELP",$J))
  1. Q
  1. ;
  1. EPCSDATE(RESULTS,EPCSARY) ;
  1. ;
  1. ;Broker call returns an FileMan internal date
  1. ; RPC: PSO EPCS SYSTEM DATE TIME
  1. ;INPUTS EPCSARY - Contains the following elements
  1. ; DTSTR - Date String (e.g., 'N' for 'Now')
  1. ;
  1. ;OUTPUTS RESULTS - A valid FileMan date format^External format
  1. ;
  1. N EPCSDATE,DIC,X,Y,DATESTR
  1. D SETENV
  1. S DATESTR=$P(EPCSARY,U) I DATESTR="" Q
  1. S X=DATESTR,%DT="XT",%DT(0)="-NOW" D ^%DT
  1. I +Y<1 S RESULTS="0^Invalid Date/Time" Q
  1. S RESULTS=Y D D^DIQ
  1. S RESULTS=RESULTS_U_Y
  1. Q
  1. ;
  1. SRCLST(RESULTS,EPCSARY) ;
  1. ;
  1. ; This broker entry returns an array of codes from a file
  1. ; based on a search string.
  1. ; RPC: PSO EPCS GET LIST
  1. ;
  1. ;INPUTS EPCSARY - Contains the following subscripted elements
  1. ; EPCSFILE - File to search
  1. ; EPCSSTR - Search string
  1. ; EPCSDIR - Search order
  1. ; EPCSNUM - (Optional) # records to return [default=44]
  1. ;OUTPUTS RESULTS - Array of values based on the search criteria.
  1. ;
  1. N EPCSFILE,EPCSSTR,EPCSDIR,EPCSORD,EPCSNUM
  1. D SETENV
  1. S EPCSFILE=$P(EPCSARY,U),EPCSSTR=$P(EPCSARY,U,2),EPCSDIR=$P(EPCSARY,U,3)
  1. S EPCSORD=$S(EPCSDIR=-1:"B",1:"I")
  1. K ^TMP($J,"EPCSFIND"),^TMP("EPCSSRCH",$J)
  1. I EPCSFILE="" Q
  1. S EPCSNUM=$S(+$P(EPCSARY,U,4)>0:$P(EPCSARY,U,4),1:44)
  1. I EPCSFILE=200 D PROV(EPCSNUM) ;Providers
  1. D SORT
  1. EXIT K ^TMP("EPCSSRCH",$J)
  1. S RESULTS=$NA(^TMP($J,"EPCSFIND"))
  1. Q
  1. ;
  1. SORT ;Order the data to be returned by the broker
  1. N COUNT
  1. S COUNT=0
  1. F S COUNT=$O(^TMP("EPCSSRCH",$J,"DILIST","ID",COUNT)) Q:'COUNT D
  1. .S ^TMP($J,"EPCSFIND",COUNT)=$G(^TMP("EPCSSRCH",$J,"DILIST","ID",COUNT,.01))_U_^TMP("EPCSSRCH",$J,"DILIST",2,COUNT)
  1. Q
  1. ;
  1. PROV(EPCSNUM) ;Return a set of providers from the NEW PERSON file
  1. ;Input Variables:-
  1. ; EPCSNUM - # of records to return
  1. ; FROM - text to begin $O from
  1. ; DATE - checks for an active person class on this date (optional)
  1. ; EPCSDIR - $O direction
  1. ; REPORT - Set to "R" to get all entries from file 200 OR set to blank
  1. ; if only users with a person class should be returned.
  1. ;
  1. ;Output Variables:-
  1. ; ^TMP($J,"EPCSFIND",1..n - returned array
  1. ; IEN of file 200^Provider Name^occupation^specialty^subspecialty
  1. ;
  1. N I,IEN,COUNT,FROM,DATE,EPCSUTN,REPORT S I=0,COUNT=$S(+$G(EPCSNUM)>0:EPCSNUM,1:44)
  1. S FROM=$P(EPCSSTR,"|"),DATE=$P(EPCSSTR,"|",2),REPORT=$P(EPCSSTR,"|",3)
  1. F Q:I'<COUNT S FROM=$O(^VA(200,"B",FROM),EPCSDIR) Q:FROM="" D
  1. . S IEN="" F S IEN=$O(^VA(200,"B",FROM,IEN),EPCSDIR) Q:'IEN D
  1. . . I IEN<1 Q ; Don't include special users postmaster and sharedmail
  1. . . I REPORT="R" S I=I+1,^TMP($J,"EPCSFIND",I)=IEN_"^"_FROM_"^" Q
  1. . . S EPCSUTN=$$GET^XUA4A72(IEN,DATE)
  1. . . S I=I+1,^TMP($J,"EPCSFIND",I)=IEN_"^"_FROM_"^"_$P(EPCSUTN,"^",2,4)
  1. Q
  1. SETENV ;
  1. I '$G(DUZ) D
  1. . S DUZ=.5,DUZ(0)="@",U="^",DTIME=300
  1. . D NOW^%DTC S DT=X
  1. Q
  1. DELMULT(RETURN,NPIEN,DEATXT) ; Remove DEA multiple (#53.21) from the NEW PERSON file (#200)
  1. ; INPUT: NPIEN - NEW PERSON FILE #200 INTERNAL ENTRY NUMBER
  1. ; DEATXT - PROPERLY FORMATTED DEA NUMBER
  1. ; OUTPUT: RETURN - 1 for SUCCESS, 0 for UNSUCCESSFUL
  1. N FDA,IENS,MSGROOT,NPDEAIEN,DNDEAIEN,DEATYPE,DA,DIE,DR
  1. S RETURN=0 Q:'$G(NPIEN) Q:$G(DEATXT)=""
  1. S NPDEAIEN=$O(^VA(200,NPIEN,"PS4","B",DEATXT,0)) I 'NPDEAIEN Q
  1. S DNDEAIEN=$$GET1^DIQ(200.5321,NPDEAIEN_","_NPIEN_",",.03,"I")
  1. S DEATYPE=$$GET1^DIQ(8991.9,DNDEAIEN,.07,"I")
  1. S FDA(1,200.5321,NPDEAIEN_","_NPIEN_",",.01)="@"
  1. D UPDATE^DIE(,"FDA(1)",,"MSGROOT") Q:$D(MSGROOT)
  1. S RETURN=1
  1. Q
  1. ;
  1. ASK(TYPE,NAME,DELEG) ;Ask user if Allocate/De-allocate or Delegate/Un-delegate - returns y/n
  1. ;TYPE - flag weather Allocate/De-allocate or Delegate/Un-delegate
  1. ;Name - user's name
  1. N DIR,Y
  1. S DELEG=$G(DELEG,"")
  1. I DELEG S DIR("A")=$S(TYPE=1:"Un-delegate",1:"Delegate")_" PSDRPH for "_NAME
  1. I 'DELEG S DIR("A")=$S(TYPE=1:"De-allocate",1:"Allocate")_" PSDRPH for "_NAME
  1. S DIR("B")="Y"
  1. S DIR(0)="Y" D ^DIR K DIR
  1. Q Y
  1. ;
  1. PSDKEY(RESULTS,PSOSUBJ,PSOACTOR,PSOACTION) ;Allocate/De-allocate the PSDRPH key
  1. ; RESULTS - Success or Failure of the allocation/deallocation of the PSDRPH key.
  1. ; PSOSUBJ - The user to whom the PSDRPH key is being allocated/deallocated
  1. ; PSOACTOR - The user performing the allocation/deallocation of the PSDRPH key.
  1. ; PSOACTION - Action to perform - 1=Allocate, 0=Deallocate
  1. ;
  1. N PSOKEY,PSOMSG,PSOKSTAT,PSOIGNORE,PSOINPUT
  1. S PSOIGNORE=0 K RESULTS
  1. S PSOKSTAT=$$FIND1^DIC(200.051,","_PSOSUBJ_",",,"PSDRPH",,,"ERROR")
  1. S PSOACTION=$G(PSOACTION),PSOSUBJ=$G(PSOSUBJ),PSOACTOR=$G(PSOACTOR)
  1. I (PSOACTION'=1)&(PSOACTION'=0) S RESULTS="0^Invalid Action Code: "_PSOACTION Q
  1. S PSOKEY=$$LKUP^XPDKEY("PSDRPH")
  1. I PSOKEY="" S RESULTS="0^PSDRPH key does not exist" Q
  1. I 'PSOSUBJ S RESULTS="0^Missing or invalid key recipient input parameter." Q
  1. I 'PSOACTOR S RESULTS="0^Missing or invalid key allocator input parameter." Q
  1. I '$$FIND1^DIC(200,,,"`"_PSOSUBJ) S RESULTS="0^Key recipient IEN "_PSOSUBJ_" does not exist in the NEW PERSON file." Q
  1. I '$$FIND1^DIC(200,,,"`"_PSOACTOR) S RESULTS="0^Allocator IEN "_PSOACTOR_" does not exist in the NEW PERSON file." Q
  1. ;
  1. ;De-allocate key
  1. I PSOACTION=0 D
  1. . I 'PSOKSTAT S PSOIGNORE=1 Q ; Key not on file, take no action to avoid unnecessary audit file records
  1. . K DIK S DIK="^VA(200,PSOSUBJ,51,",DA(1)=PSOSUBJ,DA=PSOKEY D ^DIK
  1. ;
  1. ;Allocate key
  1. I PSOACTION=1 D
  1. . I PSOKSTAT S PSOIGNORE=1 Q ; Key already on file, take no action to avoid unnecessary audit file records
  1. . S FDA(200.051,"+1,"_PSOSUBJ_",",.01)="PSDRPH" D UPDATE^DIE("E","FDA","IEN","PSOMSG") D I $L($G(RESULTS)) Q
  1. . I '$$FIND1^DIC(200.051,","_PSOSUBJ_",",,"PSDRPH") S RESULTS="0^PSDRPH NOT FILED-"_$G(PSOMSG("DIERR",1,"TEXT",1))
  1. ;
  1. ;Set and record audit data
  1. I 'PSOIGNORE D
  1. . S NOW=$P($$HTE^XLFDT($H),":",1,2)
  1. . S PSOINPUT="`"_PSOSUBJ_"^"_"`"_PSOACTOR_"^"_PSOACTION D RECORD(PSOINPUT,NOW)
  1. ;
  1. ; Return true if intended state of PSDRPH exists, either by current action or pre-existing state
  1. S RESULTS=1
  1. Q
  1. ;
  1. RECORD(LINE,NOW) ;Record the edited data into audit file #8991.7
  1. N FDA,VALUE,IEN,MSG,I
  1. F I=1:1:3 S VALUE=$P(LINE,U,I),FDA(8991.7,"+1,",(I/100))=VALUE
  1. S FDA(8991.7,"+1,",.04)=NOW
  1. D UPDATE^DIE("E","FDA","IEN","MSG")
  1. Q