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