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

PSODEADD.m

Go to the documentation of this file. 
  1. PSODEADD ;DAL/JCH-Add/update DEA NUMBERS file (8991.9) ;19 Jul 2021 06:00
  1.  ;;7.0;OUTPATIENT PHARMACY;**545,731**;DEC 1997;Build 18
  1.  ; Reference to ^XOBWLIB supported by DBIA 5421
  1.  ;
  1. EN ; Entry Point
  1.  N PSOCONN,DEAEDQ,ASTERS,MSGPADC,MSGPADT,PSOABORT,PSOSTOP,PSODONE,PSOWSUP
  1.  S PSOCONN="",DEAEDQ=0,MSGPADC=0,MSGPADT="",PSOSTOP=0,PSODONE=0
  1.  D WSDMSG(.DEAEDQ) Q:$G(DEAEDQ)
  1.  F  Q:'$$ADDEDIT()
  1.  K DIE,DA,DR,DTOUT,DUOUT,DIROUT,DLAYGO,X,Y
  1.  Q
  1.  ;
  1. ADDEDIT() ;  Add/Edit a DEA number
  1.  N PSOLOOP,PSODEAI,PSOBACE,PSODTYPE,PSOBAC,PSOBACI,MANBAC,PSOMISS,PSODNEW,PSODEAE
  1.  S PSOSTOP=0,PSODEAI=0,PSOABORT=0
  1.  ;
  1.  ; Select or Enter New entry in 8991.9
  1.  D ADD(.PSOSTOP,.PSODEAI,.PSODNEW,.PSODEAE)
  1.  ;
  1.  ; No DEA number selected/entered, quit and exit
  1.  Q:'$G(PSODEAI)>0 0
  1.  ;
  1.  ; Get existing BAC as default, prompt for new BAC
  1.  S PSOBACE=$$GET1^DIQ(8991.9,$G(PSODEAI),.02)
  1.  F  S PSOBACI=$$BAC(.PSOBACE,.PSOABORT,PSODNEW,PSODEAI) Q:$G(PSOBACI)!$G(PSOABORT)
  1.  ;
  1.  ; If no BAC, quit. If DEA is new/manual and is missing required fields, delete it
  1.  I 'PSOBACI!$G(PSOABORT) D  Q 1
  1.  .Q:'$G(PSODNEW)                                   ; Don't delete DOJ DEA's
  1.  .D REQD(PSODEAI,.PSOMISS)                         ; Check for required fields
  1.  .I $D(PSOMISS)>1 D ABORT(PSODNEW,PSODEAI,"DEA")   ; Delete new incomplete entry
  1.  ;
  1.  ; Edit/Enter the DEA data in 8991.9
  1.  F  S PSODONE=$$ED89919(+PSODEAI,PSODNEW,.PSOSTOP) Q:$G(PSOSTOP)!PSODONE
  1.  K DIE,DA,DR W !
  1.  Q PSODONE
  1.  ;
  1. ADD(PSOSTOP,PSODEAI,PSODNEW,PSODEAE) ; Add new DEA number
  1.  N DIC,DIE,PSODEAE
  1.  W !!
  1.  S DIC="8991.9",DIC(0)="AELMQ",DLAYGO=8991.9,DIC("A")="Enter DEA number: ",DIC("DR")=""
  1.  D ^DIC I (Y'>0)!$G(DIRUT)!$G(DUOUT) S PSOSTOP=1 Q
  1.  ; Considered 'New' if never updated by DOJ - no date/time in 8991.9:10.3 LAST UPDATED BY DOJ
  1.  S PSODNEW=$S($P(Y,U,3):1,'$$GET1^DIQ(8991.9,+Y,10.3,"I"):2,1:0)
  1.  S PSODEAE=$P(Y,U,2)
  1.  S PSODEAI=+Y
  1.  Q
  1.  ;
  1. BAC(PSOBACE,PSOABORT,PSODNEW,PSODEAI) ; Prompt for Business Activity Code, File New if Necessary
  1.  N DIC,DIE,DA,DR,FDA,ERR,RETURN,PSOBNEW
  1.  N PSOBACI
  1.  I $G(PSOBACE)'="" S DIC("B")=PSOBACE
  1.  S DIC="8991.8",DIC(0)="AELQZ",DLAYGO=8991.8,DIC("A")="Enter Business Activity Code: "
  1.  S DIC("DR")="" D ^DIC
  1.  S PSOBNEW=$P(Y,U,3)  ; PSOBNEW=1 - New entry into file 8991.8
  1.  I (Y'>0)!$D(DTOUT)!$G(DIRUT)!$G(DUOUT) D  Q RETURN
  1.  .S RETURN=0
  1.  .I $G(DUOUT)!$D(DTOUT) S PSOABORT=1 Q
  1.  .S RETURN=$$GET1^DIQ(8991.9,PSODEAI,.02,"I") Q
  1.  .S PSOABORT=$$SURE(PSODNEW) D  Q
  1.  ..I PSOABORT D ABORT(PSODNEW,PSODEAI,"DEA")
  1.  .I Y=-1 W *7,"  Required" S PSOABORT="" Q
  1.  S PSOBACI=+Y,PSOBACE=$P(Y,U,2)
  1.  I PSOBACI>0,$$FIND1^DIC(8991.8,,"QA",+PSOBACI) D FILEBAC(+PSODEAI,+PSOBACI)
  1.  I $$GET1^DIQ(8991.8,+Y,2,"I")!$G(PSOBNEW) D  ; Allow manually entered BAC's to be edited
  1.  .W *7,!!?2," * Now editing Business Activity Code file entry *"
  1.  .K FDA,ERR
  1.  .S FDA(8991.8,+Y_",",.02)=$E(PSOBACE)
  1.  .S FDA(8991.8,+Y_",",.03)=$E(PSOBACE,2,3)
  1.  .S FDA(8991.8,+Y_",",2)=$$NOW^XLFDT()
  1.  .D FILE^DIE("","FDA","ERR")
  1.  .S DIE=8991.8,DA=+Y
  1.  .S DR="1R" D ^DIE
  1.  .I $G(PSOBNEW),($$GET1^DIQ(8991.8,PSOBACI,1)="") D ABORT(PSODNEW,PSOBACI,"BAC") S PSOABORT=1
  1.  .I $G(PSODNEW) D
  1.  ..N PSOBACI S PSOBACI=$$GET1^DIQ(8991.9,PSODEAI,.02,"I") I 'PSOBACI D ABORT(PSODNEW,PSODEAI,"DEA") S PSOABORT=1 Q
  1.  ..I $$GET1^DIQ(8991.8,PSOBACI,1)="" D ABORT(PSODNEW,PSODEAI,"DEA") S PSOABORT=1
  1.  .W *7,!?2," * Finished editing Business Activity Code file entry *",!
  1.  Q PSOBACI
  1.  ;
  1. ED89919(PSODEAI,PSODNEW,PSOSTOP) ; Enter remaining fields in 8991.9
  1.  N ABORT S ABORT=0
  1.  S DIE=8991.9,DA=+PSODEAI
  1.  S PSOBACE=$$GET1^DIQ(8991.9,+PSODEAI,.02,"E")
  1.  S PSODTYPE=$$PROVTYPE^PSODEAUT(PSOBACE)
  1.  S DR=".07///"_+PSODTYPE D ^DIE
  1.  W !,"DEA TYPE: ",$P(PSODTYPE,U,2)
  1.  K DR ;I +PSODTYPE=2 S DR=".03;"  ;P731 detox/x-waiver removal
  1.  S DR=$G(DR)_".04;1.1R;2.1R;2.2R;2.3R;2.4R;2.5R;2.6R;1.2;1.3;1.4;1.5;1.6;1.7" D ^DIE
  1.  ;
  1.  K FDA,ERR
  1.  S FDA(8991.9,+PSODEAI_",",10.1)=$G(DUZ)
  1.  S FDA(8991.9,+PSODEAI_",",10.2)=$$NOW^XLFDT()
  1.  S FDA(8991.9,+PSODEAI_",",10.3)=""
  1.  D FILE^DIE("","FDA","ERR")
  1.  ;
  1.  ; Check for required fields, if new DEA and missing required fields, delete it
  1.  I '$$REQD(+PSODEAI,.PSOMISS) D  Q ABORT
  1.  .Q:'$G(PSODNEW)
  1.  .S ABORT=$S($$SURE(PSODNEW,.PSOMISS):1,1:0)
  1.  .I ABORT D ABORT(PSODNEW,PSODEAI,"DEA")
  1.  K DIE,DA,DR W !
  1.  ; Finished editing, record complete
  1.  Q 1
  1.  ;
  1. WSCHK() ; Check PSO DOJ/DEA WEB SERVICE
  1.  N PSOCONN,DEAEDQ,ASTERS
  1.  S PSOCONN="",DEAEDQ=0
  1.  D FULL^VALM1
  1.  S $P(ASTERS,"*",75)="*"
  1.  W !!,"Checking PSO DOJ/DEA WEB SERVICE connectivity..."
  1.  S PSOCONN=$S($$CONNECT^PSODEADD:"1^Connection established, web service is operational!",1:"0^Unable to establish connection.")
  1.  Q PSOCONN
  1.  ;
  1. CONNECT()  ; -- Send a test to the Web Service and compare the Result
  1.  N SERVER,SERVICE,RESOURCE,REQUEST,SC,RESPONSE,RESPJSON,DATA,PSOERR,PSOECODE
  1.  S SERVER="PSO DOJ/DEA WEB SERVER"
  1.  S SERVICE="PSO DOJ/DEA WEB SERVICE"
  1.  S RESOURCE=""
  1.  S PSOECODE=""
  1.  ;
  1.  ; Get an instance of the REST request object.
  1.  S REQUEST=$$GETREST^XOBWLIB(SERVICE,SERVER)
  1.  ; 
  1.  ; Execute the HTTP Get method
  1.  S SC=$$GETXOBW^PSODEAU0(REQUEST,RESOURCE,.PSOERR,.PSOECODE)
  1.  ;
  1.  ; Execute the HTTP Get method.
  1.  ;S SC=$$GET^XOBWLIB(REQUEST,RESOURCE,.PSOERR,0)
  1.  I 'SC I PSOECODE=404 Q 1   ; Server running, null dea not found=ok
  1.  I 'SC Q "0^General Service Error"
  1.  I 'SC I PSOECODE=6059 Q 0
  1.  Q 1
  1.  ;
  1. ABORT(PSODNEW,PSODIEN,TYPE) ; Quit and undo incomplete new entry
  1.  Q:'PSODNEW         ; Undo incomplete entry
  1.  N PSODMSG,DEAE,BACE
  1.  S:TYPE="DEA" DEAE=$$GET1^DIQ(8991.9,+$G(PSODIEN),.01)
  1.  S:TYPE="BAC" BACE=$$GET1^DIQ(8991.8,$G(PSODIEN),.01)
  1.  D UNDO(+PSODIEN,TYPE)
  1.  S PSODMSG="DELETING INCOMPLETE "_$S($G(TYPE)="DEA":"DEA NUMBER "_$G(DEAE),$G(TYPE)="BAC":"BUSINESS ACTIVITY CODE "_$G(BACE),1:"")
  1.  W !?3,PSODMSG
  1.  Q
  1.  ;
  1. UNDO(IEN,TYPE) ; Remove just-added record if user exits before required data is entered
  1.  N DA,DIK,FILNO
  1.  S DA=IEN
  1.  Q:'$G(DA)
  1.  S FILNO=$S(TYPE="DEA":8991.9,TYPE="BAC":8991.8,1:"")
  1.  Q:FILNO=""
  1.  S DIK="^XTV("_FILNO_","
  1.  Q:'$$FIND1^DIC(FILNO,,"QA",IEN)
  1.  D ^DIK
  1.  Q
  1.  ;
  1. REQD(PSODEAI,PSOMISS)  ; Check required data has been entered
  1.  N FLDS,DEAVALS,FLD,FLDLABEL
  1.  K PSOMISS
  1.  S FLDS=".02;.04;.07;1.1;2.1;2.2;2.3;2.4;2.5;2.6"
  1.  D GETS^DIQ(8991.9,PSODEAI,FLDS,"I","DEAVALS")
  1.  S FLD=0 F  S FLD=$O(DEAVALS(8991.9,PSODEAI_",",FLD)) Q:FLD=""  D
  1.  .Q:$G(DEAVALS(8991.9,PSODEAI_",",FLD,"I"))'=""
  1.  .K DEARTRN
  1.  .D FIELD^DID(8991.9,FLD,,"LABEL","FLDLABEL")
  1.  .S PSOMISS(FLD)=FLDLABEL("LABEL")
  1.  Q $S($D(PSOMISS):0,1:1)
  1.  ;
  1. SURE(PSODNEW,PSOMISS) ; Are they sure they want to quit? Incomplete entry will be deleted
  1.  N DIR,MISSFLD
  1.  Q:'$G(PSODNEW) 1
  1.  Q:'$D(PSOMISS)
  1.  W !!?2," REQUIRED FIELDS ARE MISSING "
  1.  S MISSFLD=0 F  S MISSFLD=$O(PSOMISS(MISSFLD)) Q:MISSFLD=""  D
  1.  .W !?5,$G(PSOMISS(MISSFLD))
  1.  W !!?5,"Exiting now will abort the process"
  1.  W !?5,"and remove the incomplete entry."
  1.  S DIR(0)="S"
  1.  S DIR("A")="Quit or Continue Editing?"
  1.  S DIR(0)="S^C:Continue Editing;Q:Quit and Remove Incomplete Entry"
  1.  D ^DIR
  1.  Q $S(Y="C":0,1:1)
  1.  ;
  1. FILEBAC(PSODEAI,PSOBACI) ; Save Business Activity Code to file 8991.8
  1.  K FDA,ERR
  1.  N FDA S FDA(8991.9,+PSODEAI_",",.02)=+PSOBACI
  1.  D FILE^DIE("","FDA","ERR")
  1.  Q
  1.  ;
  1. WSDMSG(DEAEDQ) ; Should be using the web service if possible
  1.  N DIR
  1.  D FULL^VALM1
  1.  S $P(ASTERS,"*",75)="*"
  1.  S PSOWSUP=$$WSCHK()
  1.  S MSGPADC=55-$L($P(PSOWSUP,U,2)),$P(MSGPADT," ",MSGPADC)=" "
  1.  S DIR("A",1)="    "_$E(ASTERS,1,26)_" WARNING "_$E(ASTERS,1,28)
  1.  S DIR("A",2)="    **   "_$P(PSOWSUP,U,2)_MSGPADT_" **"
  1.  S DIR("A",3)="    **   This option should only be used if a connection to the  **"
  1.  S DIR("A",4)="    **   PSO DOJ/DEA WEB SERVICE cannot be established. DEA data **"
  1.  S DIR("A",5)="    **   entered using this option may not match Department of   **"
  1.  S DIR("A",6)="    **   Justice (DOJ) source data.                              **"
  1.  S DIR("A",7)="    "_$E(ASTERS,1,63)
  1.  S DIR("A")="Do you want to continue"
  1.  S DIR(0)="Y",DIR("B")="N" D ^DIR I 'Y!$G(DIRUT) S DEAEDQ=1 Q
  1.  Q